;;; -*- Mode:Lisp; Package:(NC LISP); Readtable:CL; Base:10 -*-

;;;; Rewriters

(export '(defrewrite))

;;; A Rewriter is just like a macro
;;; except the definition is kept in this table
;;; instead of in the function cell because
;;; there needs to be a function of the same name defined

(defvar *rewriter-table* (make-table))

(defun expand-rewriter (exp env)
  (let ((entry (table-entry *rewriter-table* (car exp))))
    (if entry
	(funcall entry exp env)
      exp)))
    
(defmacro defrewrite (name lambda-list &body body)
  (let ((gen-name (gensym name)))
    `(progn
       (defun . ,(cdr (si:expand-defmacro (list* gen-name lambda-list body) nil)))
       (setf (table-entry *rewriter-table* ',name)
	     (symbol-function ',gen-name)))))


(defrewrite eql (x y)
  `(eq ,x ,y))

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

  
(defmacro def-n-arg-fcn (name rest 2-arg-fcn 0-arg-form 1-arg-form)
  `(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
  2-arg-+
  0 (car numbers))

(def-n-arg-fcn - numbers
  2-arg--
  `(error "0 arg minus")
  `(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
  2-arg-logior
  0
  (car numbers))

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

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

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

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

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

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

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

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

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

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



(defmacro def-n-arg-compare (name rest 2-arg)
  `(defrewrite ,name (&rest ,rest)
     `(and ,@(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.
(def-n-arg-compare = numbers 2-arg-=)
(def-n-arg-compare < numbers 2-arg-<)
(def-n-arg-compare > numbers 2-arg->)
(def-n-arg-compare <= numbers 2-arg-<=)
(def-n-arg-compare >= numbers 2-arg->=)

;;; /= is "all different"
(defrewrite /= (&rest numbers)
  `(AND ,@(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
;(defrewrite byte (width position)
;  `(hw:dpb ,width vinc:%%byte-size ,position))

(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
(defrewrite funcall (fn &rest args)
  (if (and (consp fn)
	   (eq (car fn) 'FUNCTION))
      `(,(cadr fn) . ,args)
    `(funcall-internal ,fn . ,args)))

(defrewrite li: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))))


(defrewrite li: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)))))


(defrewrite li: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 (LI:CDR ,var)))
		    vars
		    lists)
	  ,map-result
	  ,map-temp)
	 ((OR ,@(mapcar #'(lambda (var) `(NULL ,var))
			vars))
	  ,map-result)
       (LET ((,map-val (LI:CONS (FUNCALL ,fn ,@(mapcar #'(lambda (var)
							 `(LI:CAR ,var))
						     vars))
				NIL)))
	 (IF ,map-temp
	     (LI:RPLACD ,map-temp ,map-val)
	   (SETQ ,map-result ,map-val))
	 (SETQ ,map-temp ,map-val)))))


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


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

(setf:defsetf li:char array:svset)

(defrewrite li:typep (&whole form)
  (li:rewrite-typep form))


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

(defrewrite li:CHAR/= (&rest characters)
  `(AND ,@(mapcon #'(lambda (args)
		      (if (null (cdr args))
			  (list 'T)
			(let ((arg (car args)))
			  (mapcar #'(lambda (next-arg)
				      `(li:%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)
  `(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?

(define-char-????-predicate li:char-equal	 li:char-equal-2-args	     li:char-equal-3-args)
(define-char-????-predicate li:char-not-equal	 li:char-not-equal-2-args    li:char-not-equal-3-args)
(define-char-????-predicate li:char-lessp	 li:char-lessp-2-args	     li:char-lessp-3-args)
(define-char-????-predicate li:char-greaterp	 li:char-greaterp-2-args     li:char-greaterp-3-args)
(define-char-????-predicate li:char-not-lessp	 li:char-not-lessp-2-args    li:char-not-lessp-3-args)
(define-char-????-predicate li:char-not-greaterp li:char-not-greaterp-2-args li:char-not-greaterp-3-args)


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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