;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:8; Readtable:CL -*-

;Support functions mostly for cross compiler.  These are to be compiled with the Hardebeck compiler.


(export '(zl:*plus
	  zl:*times
	  zl:*dif
	  zl:*quo
	  zl:%div
	  zl:sub1)
	:zl)


(defun zl:*plus (a1 a2) (+ a1 a2))
(defun zl:*times (a1 a2) (* a1 a2))
(defun zl:*dif (a1 a2) (- a1 a2))
(defun zl:*quo (a1 a2) (truncate a1 a2))
(defun zl:%div (a1 a2) (/ a1 a2))
(defun zl:sub1 (n) (1- n))

(defun si:*logior (a1 a2) (logior a1 a2))
(defun si:*logand (a1 a2) (logand a1 a2))
(defun si:*logxor (a1 a2) (logxor a1 a2))
(defun si:*min (a1 a2) (li:min-2 a1 a2))
(defun si:*max (a1 a2) (li:max-2 a1 a2))



;;; moved these SI: support functions out of the comment below.
;;; they are safe to load and are even found properly by cross-compiled functions !!!
;;;  ||| 6oct88  pfc

(defun si:ar-1 (array sub)
  (array:aref array sub))

(defun si:ar-2 (array sub1 sub2)
  (array:aref array sub1 sub2))

;(defun zl:ar-1 (array x)
;  (let ((ans (array:aref array x)))
;    (if (characterp ans)
;	(char-int ans)
;	ans)))

(defun si:set-ar-1 (array subscript value)
  (li:setf (array:aref array subscript) value))

(defun si:set-ar-2 (array subscript1 subscript2 value)
  (li:setf (array:aref array subscript1 subscript2) value))

(defun si:simple-make-array-1d-q-short (dimension)
  (array:make-array-internal dimension array:art-q nil nil nil 0 nil nil nil))

(defun si:simple-make-array (dimensions &optional (type array:art-q) area leader-length initial-element)
  (array:make-array-internal dimensions
			     ;;;|||@@@Lambda compiler may emit symbolic type. --Keith@WKF 21-oct-88
			     (if (symbolp type) (symbol-value type) type)
			     nil nil nil 0 leader-length nil area))
			     
(defun si:internal-= (arg1 arg2)
  (= arg1 arg2))

(defun compiler:internal-= (arg1 arg2)	;generated by an optimizer
  (= arg1 arg2))

(defun si:internal-< (arg1 arg2)
  (< arg1 arg2))

(defun compiler:internal-< (arg1 arg2)	;generated by an optimizer
  (< arg1 arg2))

(defun si:internal-> (arg1 arg2)
  (> arg1 arg2))

(defun compiler:internal-> (arg1 arg2)	;generated by an optimizer
  (> arg1 arg2)) 

;; Special handling is needed for any function whoses symbol exists on
;; the LAMBDA in the PRIMITIVES or LISP-INTERNALS packages.
;;;   26sept88 wkf & pfc

;N.B. this cant really win due to fixnums being smaller than the pointer.
;;; +++ Made work, but for 24 bits only!  For now, addresses never get larger. <11-Nov-88 JIM>
(defun %pointer (a1) 
  ;; ||| added this line to cause an error instead
  ;; ||| making believe that it will work JIM 10/17/88
  ;;(li::tail-error "%POINTER called illegally")
  (hw:ldb a1 (byte 24 0) 0))

;this goes into global: on the k, which would be fine if the global package was initialize properly.
(defun assq (x alist)
  (do ((p alist (cdr p)))
      ((null p))
    (if (eq x (caar p))
	(return (car p)))))

;Don't look for symbol value of nil.
;can trash instructions before return since value not used again.
;(defun assq (item alist)
;  (dolist (pair alist nil)
;    (when (eq item (car pair))
;      (return-from assq pair))))

(defun memq (x list)
  (do ((p list (cdr p)))
      ((null p))
    (if (eq x (car p))
	(return p))))

(DEFUN MEMBER-EQL (ITEM LIST)
  (IF (TYPEP ITEM '(OR (NOT NUMBER) FIXNUM))
      (MEMQ ITEM LIST)
 ;  (LOOP FOR X ON LIST DO (WHEN (EQL (CAR X) ITEM) (RETURN X)))
    ((LAMBDA (X)
       (PROG NIL
	  NEXT-LOOP
	     (AND (NULL X) (GO END-LOOP))
	     (WHEN (EQL (CAR X) ITEM) (RETURN X))
	     (SETQ X (CDR X))
	     (GO NEXT-LOOP)
	  END-LOOP
	     ))
     LIST)
    ))

;;possible common lisp conflict with member.  Put in zl:?
;(DEFUN MEMBER (ITEM IN-LIST)
;  "Return non-NIL if IN-LIST has an element EQUAL to ITEM.
;The value is actually the link of IN-LIST whose CAR is that element."
;  (COND ((OR (FIXNUMP ITEM)
;	     (SYMBOLP ITEM))
;	 (MEMQ ITEM IN-LIST))
;	(T
;	 (DO ((X IN-LIST (CDR X)))
;	     ((NULL X))
;	   (IF (EQUAL (CAR X) ITEM) (RETURN X))))))

;(defun system:common-lisp-listp (ptr)
;  (vinc:listp ptr))

;(defun zl:listp (ptr)
;  (consp ptr))

;(defun zl:nlistp (ptr)
;  (not (zl:listp ptr)))

;(defun zl:assoc (item list)
;  (li:assoc item list :test #'equal))

;(defun assoc-equal (item list)
;  "Obsolete version of zl:assoc."
;  (zl:assoc item list))

;(defun zl:aref (array &rest subscripts)
;  (let ((ans (array:aref-hard array subscripts)))
;    (if (characterp ans)
;	(char-int ans)
;	ans)))

;(defun common-lisp-aref (array &rest subscripts)
;  (array:aref-hard array subscripts))

;;; $$$ Removed commented out zl:get to QRAND. <27-Oct-88 wkf>

;no defsetf's here since we dont intend to compile zetalisp with the Hardebeck compiler.
;  (check that (setf (get ) xx) does a reasonable thing with the cross-compiler, if not, fix.)
;(defsetf zl:get (symbol-or-plist property &optional default) (value)
;  `(zl:set-get ,symbol-or-plist ,property ,value))

;LOCF must compile with cross compiler.
;(defun aloc (array &rest subscripts)
;  (locf (array:aref-hard array subscripts)))

;(defun value-cell-location (symbol)
;  (locf (symbol-value symbol)))

;(defun function-cell-location (symbol)
;  (locf (symbol-function symbol)))

;(defun property-cell-location (symbol)
;  (locf (symbol-plist symbol)))

;(defun get-location-or-nil (symbol-or-plist property &aux symbol)
;  (let ((ans (getf (cond
;		     ((symbolp   symbol-or-plist) (plist symbol-or-plist))
;		     ((listp     symbol-or-plist)  symbol-or-plist)
;		     ((locativep symbol-or-plist) (cdr symbol-or-plist))
;		     ((instancep symbol-or-plist) (li:error "Instances not defined yet."))
;		     ((setq symbol (named-structure-p symbol-or-plist)) (plist symbol))
;		     (t nil))
;		   property)))
;    (when ans
;      (locf ans))))

;(defun consp (ptr)
;  "T if object is a cons, otherwise nil."
;  (vinc:type-test ptr vinc:$$dtp-cons))

;; Same definition as member.
;(DEFUN MEMBER-EQUAL (ITEM IN-LIST)
;  "Return non-NIL if IN-LIST has an element EQUAL to ITEM.
;The value is actually the link of IN-LIST whose CAR is that element."
;  (COND ((OR (FIXNUMP ITEM)
;	     (SYMBOLP ITEM))
;	 (MEMQ ITEM IN-LIST))
;	(T
;	 (DO ((X IN-LIST (CDR X)))
;	     ((NULL X))
;	   (IF (EQUAL (CAR X) ITEM) (RETURN X))))))

(defun fixnump (x)
  (vinc:%fixnump x))

(defun fixp (x)
  (vinc:integerp x))

(defun nsymbolp (ptr)
  (not (symbolp ptr)))

(Defun false ()
  nil)

(defun true ()
  t)

(defun get-pname (symbol)
  "Zetalisp version of symbol-name."
  (symbol-name symbol))

(defun symeval (symbol)
  "Zetalisp version of symbol-value."
  (symbol-value symbol))

(defun fsymeval (symbol)
  "Zetalisp version of symbol-function."
  (symbol-function symbol))

(defun minus (num)
  (- 0 num))

(defun fix (num)
  "Obsolete function use floor instead."
  (floor num))

(defun \\ (numerator modulator &aux (mod-mag (abs modulator)))
  (- numerator (* (truncate (/ numerator mod-mag)) mod-mag)))

(defun setcar (list car)
  (set-car list car))

(defun setcdr (list cdr)
  (set-cdr list cdr))

(defun %bind (pointer value)
  ;this cant really win like this, look at PROGV.
  "Obsolete version of bind, only to be used in compiled code."
  (prog1 (li:error "lose")
	 (foo))
;  (bind pointer value)
  )

(defun set-get (symbol-or-plist property data)
  (let ((plist (if (symbolp symbol-or-plist)
		   (contents-offset symbol-or-plist symbol:*symbol-plist*)
		 symbol-or-plist)))
    (symbol:%putf plist property data)))

;; moved back here to get it right ||| JIM 10/17/88
;; moved to FBIN wher it is used ---pfc

(defun lsh (n nbits)
  (li:%trap-if-not-both-fixnum n nbits)
  (cond ((or (> nbits 24.)
	     (< nbits -24.))
	 0)
	(t
	 (hw:dpb (hw:32logical-shift-up n nbits) vinc:%%fixnum-field 0))
	))

;;This is a stripped down version of fillarray with out error checking and dimensions
(defun fillarray (array source &aux last-i (size (1- (array-dimension array 0))))
  (do ((i 0 (1+ i))
       (sublist source (cdr sublist)))
      ((null sublist)
       (setq last-i i))
    (array:aset (car sublist) array i))
  (do ((i last-i (1+ i))
       (val (car (last source))))
      ((= i size))
    (array:aset val array i)))

;;This is a stripped down version of listarray with out error checking and multiple dimensions
(defun listarray (array &aux (size (1- (array-dimension array 0))) array-list)
  (do ((i (1- size) (1- i)))
      ((< i 0)
       array-list)
    (setq array-list (cons (array:aref array i) array-list))))
  
(defun ncons (car)
  (cons:cons car nil))

(defun ncons-in-area (car area)
  (cons:cons-in-area car nil area))

;----  ones after here temporary until QFCTNS, etc come over.

(defvar *gensym* 0)
(defun gensym (&optional ignore)
  ignore
  (let ((s (make-string 4))
	(n *gensym*))
    (setq *gensym* (1+ *gensym*))
    (setf (aref s 0) #\G)
    (setf (aref s 1) (int-char (hw:ldb n (byte 8 0) 0)))
    (setf (aref s 2) (int-char (hw:ldb n (byte 8 8) 0)))
    (setf (aref s 3) (int-char (hw:ldb n (byte 8 16) 0)))
    s))

;;; $$$ Moved putprop to QRAND. <27-Oct-88 wkf>

;;This version replaces one supplied by QFCTNS which uses LOCF and is not common-lisp style.  --wkf
(defun mapcar (function list &rest more-lists)
  "Maps over successive elements, returns a list of the results."
  (when list
    (let ((remain-lists more-lists) (arg-list (ncons (car list))))
      (prog ((sub-args arg-list))
	    (setq list (cdr list))
	    (or remain-lists (go F2))
	 F1 (or (car remain-lists) (return nil))
	    (rplacd sub-args (setq sub-args (ncons (caar remain-lists))))
	    (rplaca remain-lists (cdar remain-lists))
	    (and (setq remain-lists (cdr remain-lists)) (go F1))
	    (return (let ((sub-ans (ncons (apply function arg-list))))
		      (prog ((answer sub-ans))
			 L  (or list (return answer))
			    (setq remain-lists more-lists
				  arg-list     (ncons (car list))
				  sub-args     arg-list
				  list         (cdr list))
			 L1	(or (car remain-lists) (return answer))
			    (rplacd sub-args (setq sub-args (ncons (caar remain-lists))))
			    (rplaca remain-lists (cdar remain-lists))
			    (and (setq remain-lists (cdr remain-lists)) (go L1))
			    (rplacd sub-ans (setq sub-ans (ncons (apply function arg-list))))
			    (go L))))
	 F2 (return (let ((sub-ans (ncons (apply function arg-list))))
		      (prog ((answer sub-ans))
			 S	(rplacd sub-ans (setq sub-ans (ncons (funcall function (car list)))))
			    (setq list (cdr list))
			    (and list (go S))
			    (return answer))))))))

(defun mapc (function list &rest more-lists &aux (result list))
  "Maps over successive elements, returns second argument."
  (when list
    (if more-lists
	(let ((remain-lists more-lists) (arg-list (ncons (car list))))
	  (prog ((sub-args arg-list))
	     L  (or (car remain-lists) (return))
		(rplacd sub-args (setq sub-args (ncons (caar remain-lists))))
		(rplaca remain-lists (cdar remain-lists))
		(setq remain-lists (cdr remain-lists))
		(and remain-lists (go l))
	     L2 (apply function arg-list)
		(setq remain-lists more-lists
		      list         (cdr list))
		(or list (return))
		(setq arg-list     (ncons (car list))
		      sub-args     arg-list)
		(go l)))
      (tagbody
       L3 (funcall function (car list))
	  (setq list (cdr list))
	  (and list (go L3))))
    result))
  
;;---- Temporary debugger functions.

(defun li:ferror (signal-name &optional format-string &rest args)
  (li:error "ferror" signal-name format-string args)
  nil)

(defun li:cerror (proceedable-flag unused &optional signal-name format-string &rest args)
  (li:error "cerror" proceedable-flag unused signal-name format-string args)
  nil)

;----  ones after here temporary until LMMAC come over.

(DEFun SEND (OBJECT OPERATION &REST ARGUMENTS)
  "Send a message to OBJECT, with operation OPERATION and ARGUMENTS."
  (apply OBJECT OPERATION ARGUMENTS))

(defun no-case-error (proceedable function place value typespec)
  (li:error "No case error: ~a ~a ~a ~a ~a" proceedable function place value typespec)
  nil)

;;----- Temp till QRAND comes over.

(DEFUN FDEFINEDP (FUNCTION-SPEC &AUX HANDLER)
  "Returns T if the function spec has a function definition."
  ;; Then perform type-dependent code
  (COND ((SYMBOLP FUNCTION-SPEC) (symbol:FBOUNDP FUNCTION-SPEC))
	((AND (vinc:CONSP FUNCTION-SPEC)
	      (SETQ HANDLER (li:GET (cons:CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER)))
	 (FUNCALL HANDLER 'FDEFINEDP FUNCTION-SPEC))
	(T (li:ERROR "The function spec ~S is invalid." FUNCTION-SPEC))))

(defun plist (object)
  (symbol:symbol-plist object))

;;; $$$ Removed setprop to QRAND. <28-Oct-88 wkf>

;;; Added to avoid calling all the hair in the world when starting ||| JIM 10/21/88
(defvar si::*bootstrapping-the-lambda-world* t)

;;; Added support for DEFVAR, must move to the right place in LAMBDA code ||| JIM 10/21/88
;;; $$$ Slight reworking <28-Oct-88 wkf>

SI::
(DEFUN DEFVAR-INTERNAL (SYMBOL INITIAL-VALUE DOCUMENTATION)
  (when (OR *BOOTSTRAPPING-THE-LAMBDA-WORLD*
	    (RECORD-SOURCE-FILE-NAME SYMBOL 'DEFVAR))
    (SETF (li:GET SYMBOL 'SPECIAL) (OR (AND (BOUNDP 'FDEFINE-FILE-PATHNAME)
					    FDEFINE-FILE-PATHNAME)
				       T))
    (AND (NOT (EQ INITIAL-VALUE :UNBOUND))
	 (OR (AND (BOUNDP 'FS:THIS-IS-A-PATCH-FILE)
		  FS:THIS-IS-A-PATCH-FILE)
	     (NOT (BOUNDP SYMBOL)))
	 (SET SYMBOL (EVAL INITIAL-VALUE)))
    (when (AND (NOT *BOOTSTRAPPING-THE-LAMBDA-WORLD*)
	       (OR DOCUMENTATION (DOCUMENTATION SYMBOL 'VARIABLE)))
      (SETF (DOCUMENTATION SYMBOL 'VARIABLE) DOCUMENTATION)))
  SYMBOL)