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

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

(defun *plus (a1 a2) (+ a1 a2))
(defun *times (a1 a2) (* a1 a2))
(defun *dif (a1 a2) (- a1 a2))
(defun *quo (a1 a2) (truncate a1 a2))
(defun %div (a1 a2) (/ a1 a2))
(defun *logior (a1 a2) (lisp:logior a1 a2))
(defun *logand (a1 a2) (lisp:logand a1 a2))
(defun *logxor (a1 a2) (lisp:logxor a1 a2))
(defun *min (a1 a2) (li:min-2 a1 a2))
(defun *max (a1 a2) (li:max-2 a1 a2))
(defun zl:sub1 (n) (1- n))

;N.B. this cant really win due to fixnums being smaller than the pointer.
(defun %pointer (a1) (hw:ldb a1 vinc:%%pointer (hw:unboxed-constant 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))))))

;; 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 zl:listp (ptr)
;  (consp ptr))

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

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

(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 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 common-lisp-aref (array &rest subscripts)
  (array:aref-hard array subscripts))

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

(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)
  )

;clobbers hardebeck get which current package lossage.
;(defun zl:get (symbol-or-plist property &optional default)
;  (let ((plist (if (symbol? symbol-or-plist)
;		   (contents-offset symbol-or-plist symbol:*symbol-plist*)
;		 symbol-or-plist)))
;    (symbol:getf plist property default)))

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

;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))

(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))
	))

;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)))


;;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)))

(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 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))

;;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))

(defun ^ (x y)
  (if (integerp y)
      (do ((abs-y (abs y))
	   (ans    1 (* ans x))
	   (i      0 (1+ i)))
	  ((= i abs-y) (if (minusp y)
			   (\\ 1 ans)
			 ans)))
    (li:tail-error "^ not yet defined for non-integer powers." x y)))
	   
;;; @@@ This should be a defsubst so compiled code can open compile it, but the interpreter
;;; needs to see it also.
(defun expt (x y) (^ x y))

;----  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))

;first arg really has to be a symbol for now.
(defun putprop (symbol-or-plist value property)
  (li:setf (li:get symbol-or-plist property) value)
  value)

;;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))
  
;(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))))

;;---- 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)

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

;;----- 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))

(defun setprop (symbol-or-plist property value)
  (putprop symbol-or-plist value property))