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


;;; &&&  This file used to be in the NC package, however since there are
;;       numerous symbols which the K eventually sees (via rewriters)
;;       before warm-boot on the K.  I made explicit the NC package where needed. <19-Nov-88 wkf>
;;; +++  However, there still some lurking via the primops! <20-Nov-88 wkf>

;;;; Rewriters

(nc:defrewrite not (x)
  `(if ,x nil t))

  
(defmacro def-n-arg-fcn (name rest 2-arg-fcn 0-arg-form 1-arg-form)
  `(nc:defrewrite ,name (&rest ,rest)
     (cond ((null ,rest) ,0-arg-form)
	   ((null (cdr ,rest)) ,1-arg-form)
	   (t
	    (do ((args (cdr ,rest) (cdr args))
		 (form (car ,rest)
		       `(,',2-arg-fcn ,form ,(car args))))
		((null args) form))))))
  
(def-n-arg-fcn + numbers
  nc:2-arg-+					; $$$ A primop therefore nc: <20-Nov-88 wkf>
  0 (car numbers))

(def-n-arg-fcn - numbers
  nc:2-arg--
  `(error "0 arg minus")
  `(nc:2-arg-- 0 ,(car numbers)))

(def-n-arg-fcn * numbers
  new-math::multiply-generic
  1
  (car numbers))

(def-n-arg-fcn / numbers
  new-math::divide-generic
  `(error "0 arg divide")
  `(new-math::divide-generic 1 (car numbers)))

(def-n-arg-fcn logior numbers
  nc:2-arg-logior
  0
  (car numbers))

(def-n-arg-fcn logand numbers
  nc:2-arg-logand
  -1
  (car numbers))

(def-n-arg-fcn logxor numbers
  nc:2-arg-logxor
  0
  (car numbers))

(def-n-arg-fcn logeqv numbers
  nc:2-arg-logxnor
  -1
  (car numbers))

(nc:defrewrite lognot (x)
  `(logxor -1 ,x))

(nc:defrewrite lognand (x y)
  `(lognot (logand ,x ,y)))

(nc:defrewrite lognor (x y)
  `(lognot (logior ,x ,y)))

(nc:defrewrite logandc1 (x y)
  `(logand (lognot ,x) ,y))

(nc:defrewrite logandc2 (x y)
  `(logand ,x (lognot ,y)))

(nc:defrewrite logorc1 (x y)
  `(logior (lognot ,x) ,y))

(nc:defrewrite logorc2 (x y)
  `(logior ,x (lognot ,y)))



(defmacro def-n-arg-compare (name rest 2-arg)
  `(nc:defrewrite ,name (&rest ,rest)
     `(and ,@(nc:maplist #'(lambda (l)
			    (if (null (cdr l))
				't
			      `(,',2-arg ,(car l) ,(cadr l))))
		      ,rest))))

;;; NOTE: +++ Because of Common LISP brain dammage and ambiguity the = functions
;;; might need to be full tree-wise instead of pair-wise.  This is because
;;; of complications involving rationals and different sizes of floats.

;;; $$$ These primops, 2-arg-.., need nc: package prefix <20-Nov-88 wkf>
(def-n-arg-compare = numbers  nc:2-arg-=)
(def-n-arg-compare < numbers  nc:2-arg-<)
(def-n-arg-compare > numbers  nc:2-arg->)
(def-n-arg-compare <= numbers nc:2-arg-<=)
(def-n-arg-compare >= numbers nc:2-arg->=)

;;; /= is "all different"
(nc:defrewrite /= (&rest numbers)
  `(AND ,@(nc:mapcon #'(lambda (args)
			(if (null (cdr args))
			    (list 'T)
			  (let ((arg (car args)))
			    (mapcar #'(lambda (next-arg)
					`(NOT (= ,arg ,next-arg)))
				    (cdr args)))))
		   numbers)))


; currently constant byte specs are lambda byte specs
; computed byte specs are K byte specs
;(nc:defrewrite byte (width position)
;  `(hw:dpb ,width vinc:%%byte-size ,position))

(nc:defrewrite byte-size (byte-spec)
  (setq byte-spec (nlisp:macroexpand byte-spec))
  (if (constantp byte-spec)
      (byte-size (eval byte-spec))
    `(hw:ldb ,byte-spec system:%%byte-specifier-position #|vinc:%%byte-position|# ,byte-spec)))  ;once only


;;; #'(lambda ... would be taken care of by simplify-funcall anyway
(nc:defrewrite funcall (fn &rest args)
  (if (and (consp fn)
	   (eq (car fn) 'FUNCTION))
      `(,(cadr fn) . ,args)
    `(funcall-internal ,fn . ,args)))

(nc:defrewrite apply (function arg &rest more-args)
  `(apply-internal ,function ,arg . ,more-args))


;(ndefmacro mapcar (fn &rest lists)
;  (let ((map-name (gensym 'map))
;	(call-fn (cond ((listp fn)
;			(cond ((eq (car fn) 'lambda) (list fn))	;????
;			      ((eq (car fn) 'function) (list (cadr fn)))
;			      (t (list 'funcall fn))))
;		       (t (list 'funcall fn))))
;	(vars '()))
;    (do ((l lists (cdr lists)))
;		  ((null l))
;		(push (gensym 'v) vars))		   
;  ;; Cons up result
;  (let ((map-result (gensym 'res))
;	(map-temp (gensym 'temp))
;	(map-val (gensym 'val)))
;    `(let ((,map-result)
;	   (,map-temp))
;       (labels ((,map-name ,vars
;		  (if (not (or ,@(mapcar #'(lambda (var) `(null ,var))   ;atom?
;					 vars)))
;		      (progn
;			(let ((,map-val (ncons (,@call-fn . ,(mapcar #'(lambda (var)
;									 `(car ,var))
;								     vars)))))
;			  (if ,map-temp
;			      (rplacd ,map-temp ,map-val)
;			    (setq ,map-result ,map-val))
;			  (setq ,map-temp ,map-val))
;			(,map-name ,@(mapcar #'(lambda (var) `(cdr ,var)) vars))))))
;	 (,map-name . ,lists))
;       ,map-result))))


(nc:defrewrite mapc (fn &rest lists)
  (let ((vars (mapcar #'(lambda (l) (declare (ignore l))
				(gensym 'v))
		      lists)))
    `(DO ,(mapcar #'(lambda (var list) `(,var ,list (CDR ,var)))
		  vars
		  lists)
	 ((OR ,@(mapcar #'(lambda (var) `(NULL ,var))
			vars)))
       (FUNCALL ,fn ,@(mapcar #'(lambda (var)
				  `(CAR ,var))
			      vars)))))


(nc:defrewrite mapcar (fn &rest lists)
  (let ((vars (mapcar #'(lambda (l) (declare (ignore l))
				(gensym 'v))
		      lists))
	(map-result (gensym 'res))
	(map-temp (gensym 'temp))
	(map-val (gensym 'val)))
    `(DO (,@(mapcar #'(lambda (var list) `(,var ,list (CDR ,var)))
		    vars
		    lists)
	  ,map-result
	  ,map-temp)
	 ((OR ,@(mapcar #'(lambda (var) `(NULL ,var))
			vars))
	  ,map-result)
       (LET ((,map-val (CONS (FUNCALL ,fn ,@(mapcar #'(lambda (var)
							 `(CAR ,var))
						     vars))
				NIL)))
	 (IF ,map-temp
	     (RPLACD ,map-temp ,map-val)
	   (SETQ ,map-result ,map-val))
	 (SETQ ,map-temp ,map-val)))))


(nc:defrewrite list (&rest elements)
  (case (length elements)
    (0 'nil)
    (1 (cons 'ncons elements))
    (2 (cons 'list2 elements))
    (3 (cons 'list3 elements))
    (4 (cons 'list4 elements))
    (t (cons 'listn elements))))


(nc:defrewrite char (string index)
  `(svref ,string ,index))

(setf:defsetf char array:svset)

(nc:defrewrite typep (nc:&whole form)
  (rewrite-typep form)) ;;+++ When this doesn't resolve to anything need to call nlisp:typep.  --wkf


(def-n-arg-compare char<  characters %char< )
(def-n-arg-compare char<= characters %char<=)
(def-n-arg-compare char=  characters %char= )
(def-n-arg-compare char>= characters %char>=)
(def-n-arg-compare char>  characters %char> )

(nc:defrewrite CHAR/= (&rest characters)
  `(AND ,@(nc:mapcon #'(lambda (args)
		      (if (null (cdr args))
			  (list 'T)
			(let ((arg (car args)))
			  (mapcar #'(lambda (next-arg)
				      `(%char= ,arg ,next-arg))
				  (cdr args)))))
		  characters)))

;;; CHAR-EQUAL and its brothers are too hairy to open-code.  What we do here is just try
;;; to avoid the expense of &REST arguments for the common cases of these functions.

(defmacro define-char-????-predicate (name 2-arg-function 3-arg-function)
  `(nc:defrewrite ,name (arg1 &optional (arg2 nil arg2-p) (arg3 nil arg3-p) &rest args)
     (cond (args				; are there more than three args?
	    `(,',name ,arg1 ,arg2 ,arg3 ,@args))
	   (arg3-p				; three args?
	    `(,',3-arg-function ,arg1 ,arg2 ,arg3))
	   (arg2-p				; two args?
	    `(,',2-arg-function ,arg1 ,arg2))
	   (t 't))))				; one arg?

;;; +++ Are char-equal-2-args defined? <20-Nov-88 wkf>
(define-char-????-predicate char-equal	 char-equal-2-args	     char-equal-3-args)
(define-char-????-predicate char-not-equal	 char-not-equal-2-args    char-not-equal-3-args)
(define-char-????-predicate char-lessp	 char-lessp-2-args	     char-lessp-3-args)
(define-char-????-predicate char-greaterp	 char-greaterp-2-args     char-greaterp-3-args)
(define-char-????-predicate char-not-lessp	 char-not-lessp-2-args    char-not-lessp-3-args)
(define-char-????-predicate char-not-greaterp char-not-greaterp-2-args char-not-greaterp-3-args)


;;; VINC:TYPE-TEST through DOUBLE-FLOAT-P used to be in "K; TYPE-PREDICATES"

(nc:ndefmacro vinc:type-test (object type)
  `(HW:FIELD= ,object
	      (HW:DPB-UNBOXED ,type vinc:%%data-type 0)
	      VINC:%%DATA-TYPE))

(nc:defrewrite prims:null (x)
  `(if ,x nil t))

(nc:defrewrite vinc:consp (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-CONS))

(nc:defrewrite vinc:atom (object)
  `(NOT (vinc:CONSP ,object)))

(nc:defrewrite vinc:complexp (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-COMPLEX))

(nc:defrewrite vinc:characterp (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-CHARACTER))

(nc:defrewrite vinc:arrayp (object)
  `(HW:FIELD= GR:*RANDOM-ARRAY* ,object VINC:%%DATA-TYPE))

(nc:defrewrite vinc:compiled-function-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-COMPILED-FUNCTION))

(nc:defrewrite vinc:make-fixnum (object) "Puts fixnum type code into object and set Zero and Negative status bits accordingly."
  `(hw:merge-24 gr:*zero* ,object)  ;;||| Chaned 10/13/88 --wkf
  #+Does-not-set-status-bits-for-negative`(HW:DPB-BOXED VINC:$$DTP-FIXNUM VINC::%%DATA-TYPE ,object)
  )

#+Not-currently-used
(nc:defrewrite vinc:make-short-float (object) "Puts short type code on top of object word"
  `(HW:DPB-BOXED VINC:$$DTP-SHORT-FLOAT VINC::%%DATA-TYPE ,object)) ;;||| Added 10/13/88 --wkf

;;; These are not Common Lisp but we find them useful
;;; TYPEP expands into them

(nc:defrewrite vinc:fixnump (object)
  `(HW:FIELD= GR:*ZERO* ,object VINC:%%DATA-TYPE))

(nc:defrewrite vinc:bignump (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-BIGNUM))
  
(nc:defrewrite vinc:short-float-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-SHORT-FLOAT))

(nc:defrewrite vinc:single-float-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-SINGLE-FLOAT))

(nc:defrewrite vinc:long-float-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-DOUBLE-FLOAT))

(nc:defrewrite vinc:double-float-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-DOUBLE-FLOAT))

(nc:defrewrite vinc:structure-p (object)
  `(HW:FIELD= GR:*RANDOM-STRUCTURE* ,object VINC:%%DATA-TYPE))

(nc:defrewrite vinc:instance-p (object)
  `(VINC:TYPE-TEST ,object VINC:$$DTP-INSTANCE))

(nc:defrewrite make-string (nc:&whole form length &key (initial-element nil init-p))
  (if (> (length form) 2)
      (if init-p
	  `(make-string-with-init ,length ,initial-element)
	form)
    `(array::make-string-no-init ,length)))

;;; $$$Added nc:defrewrites that were sprinkled through the system. <18-Nov-88 JIM>

;;; $$$ arithmetic.lisp <18-Nov-88 JIM>

(nc:defrewrite max (nc:&whole form)
  (let ((length-form (length form)))
    (cond ((= length-form 2)
	   (second form))
	  ((= length-form 3)
	   `(MAX-2 . ,(cdr form)))
	  (t form)))
  )

(nc:defrewrite min (nc:&whole form)
  (let ((length-form (length form)))
    (cond ((= length-form 2)
	   (second form))
	  ((= length-form 3)
	   `(MIN-2 . ,(cdr form)))
	  (t form))))  ;;@@@ Is it worth saving consing with a min/max-3+ ???  --wkf

;;; $$$ array2.lisp <18-Nov-88 JIM>

array::
(nc:defrewrite aref (nc:&whole form array &rest subscripts)
  (lisp:case (lisp:length subscripts)
    (1 `(AREF-1  ,array . ,subscripts))
    (2 `(AREF-2  ,array . ,subscripts))
    (t form)))

array::
(nc:defrewrite aset (nc:&whole form value array &rest subscripts)
  (lisp:case (lisp:length subscripts)
    (1 `(ASET-1 ,value ,array . ,subscripts))
    (2 `(ASET-2 ,value ,array . ,subscripts))
    (t form)))

;;; $$$ Added COPY of ARRAY-TYPE-FROM-ELEMENT-TYPE  form array2. <19-Nov-88 wkf>
array::
(defun array-type-from-element-type (type)
  (cond
    ((li:consp type)
     (let ((first (cons:car type))
	   (second (cons:cadr type)))
       (cond
	 ((eq first 'li:signed-byte)
	  (cond
	    ((<= second 2) art-2bs)
	    ((<= second 4) art-4bs)
	    ((<= second 8.) art-8bs)
	    ((= second 16.) art-16bs)
	    ((<= second 32.) art-32bs)
	    (t art-q)))
	 ((eq first 'li:unsigned-byte)
	  (cond
	    ((<= second 1) art-1b)
	    ((<= second 2) art-2b)
	    ((<= second 4) art-4b)
	    ((<= second 8.) art-8b)
	    ((<= second 16.) art-16b)
	    ((<= second 32.) art-32b)
	    (t art-q)))
	 (t art-q))))
    ((eq type 'li:string-char) art-string)
    ((eq type 'li:character) art-fat-string)
    (t art-q))
  )

array::
(nc:defrewrite make-array (nc:&whole form dimensions &rest options &key (element-type t element-type-p))
  (cond
    ((null options)
     (cond ((numberp dimensions)
	    `(MAKE-VECTOR ,dimensions))
	   (t
	    `(MAKE-EASY-ARRAY ,dimensions))))
    ((and element-type-p
	  (null (lisp:cddr options)))
     (let ((type ;; do something clever with constantp here
	     (or (eq element-type t)
		 (and (lisp:consp element-type)
		      (eq (lisp:car element-type) 'QUOTE)
		      (lisp:cadr element-type)))))
       (if type
	   (let ((array-type (array-type-from-element-type type)))
	     (if (numberp dimensions)
		 (cond ((= array-type art-q)
			`(MAKE-VECTOR ,dimensions))
		       ((= array-type art-string)
			`(MAKE-STRING ,dimensions))
		       (t
			`(MAKE-1D-ARRAY ,dimensions ,array-type)))		   
	       `(MAKE-EASY-ARRAY ,dimensions ,array-type)))
	 `(MAKE-EASY-ARRAY-WITH-ELEMENT-TYPE ,dimensions ,element-type))))
    (t form)))