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

;;; Contains:
;;;    - Definitions of the SETF methods required in Common Lisp
;;;      [still have to do: char-bit, mask-field]
;;;    - Common Lisp macros that use generalized variables (GETF, REMF, INCF, DECF, PUSH,
;;;      POP, ASSERT, CTYPECASE, CCASE, SHIFTF, PSETF, ROTATEF)
;;;      [done so far: INCF, DECF, PUSH, POP]
;;;

;;; Yes, this is a simple as it appears, but the effect may not
;;; be.  Unless you know what you are doing, it would probably
;;; be better to use the hairy form.  Also, this is to remain an
;;; implementation feature only.
(define-simple-setf-macro rest            (SET-CDR :args :value))
(define-simple-setf-macro first           (SET-CAR :args :value))
(define-simple-setf-macro second          (SET-CAR (CDR :args) :value))
(define-simple-setf-macro third           (SET-CAR (CDDR :args) :value))
(define-simple-setf-macro fourth          (SET-CAR (CDDDR :args) :value))
(define-simple-setf-macro fifth           (SET-CAR (CDDDDR :args) :value))
(define-simple-setf-macro sixth           (SET-CAR (NTHCDR 5 :args) :value))
(define-simple-setf-macro seventh         (SET-CAR (NTHCDR 6 :args) :value))
(define-simple-setf-macro eighth          (SET-CAR (NTHCDR 7 :args) :value))
(define-simple-setf-macro ninth           (SET-CAR (NTHCDR 8 :args) :value))
(define-simple-setf-macro tenth           (SET-CAR (NTHCDR 9 :args) :value))
(define-simple-setf-macro car             (SET-CAR :args :value))
(define-simple-setf-macro cdr             (SET-CDR :args :value))
(define-simple-setf-macro caar            (SET-CAR (CAR :args) :value))
(define-simple-setf-macro cadr            (SET-CAR (CDR :args) :value))
(define-simple-setf-macro cdar            (SET-CAR (CAR :args) :value))
(define-simple-setf-macro cddr            (SET-CDR (CDR :args) :value))
(define-simple-setf-macro caaar           (SET-CAR (CAAR :args) :value))
(define-simple-setf-macro caadr           (SET-CAR (CADR :args) :value))
(define-simple-setf-macro cadar           (SET-CAR (CDAR :args) :value))
(define-simple-setf-macro caddr           (SET-CAR (CDDR :args) :value))
(define-simple-setf-macro cdaar           (SET-CDR (CAAR :args) :value))
(define-simple-setf-macro cdadr           (SET-CDR (CADR :args) :value))
(define-simple-setf-macro cddar           (SET-CDR (CDAR :args) :value))
(define-simple-setf-macro cdddr           (SET-CDR (CDDR :args) :value))
(define-simple-setf-macro caaaar          (SET-CAR (CAAAR :args) :value))
(define-simple-setf-macro caaadr          (SET-CAR (CAADR :args) :value))
(define-simple-setf-macro caadar          (SET-CAR (CADAR :args) :value))
(define-simple-setf-macro caaddr          (SET-CAR (CADDR :args) :value))
(define-simple-setf-macro cadaar          (SET-CAR (CDAAR :args) :value))
(define-simple-setf-macro cadadr          (SET-CAR (CDADR :args) :value))
(define-simple-setf-macro caddar          (SET-CAR (CDDAR :args) :value))
(define-simple-setf-macro cadddr          (SET-CAR (CDDDR :args) :value))
(define-simple-setf-macro cdaaar          (SET-CDR (CAAAR :args) :value))
(define-simple-setf-macro cdaadr          (SET-CDR (CAADR :args) :value))
(define-simple-setf-macro cdadar          (SET-CDR (CADAR :args) :value))
(define-simple-setf-macro cdaddr          (SET-CDR (CADDR :args) :value))
(define-simple-setf-macro cddaar          (SET-CDR (CDAAR :args) :value))
(define-simple-setf-macro cddadr          (SET-CDR (CDADR :args) :value))
(define-simple-setf-macro cdddar          (SET-CDR (CDDAR :args) :value))
(define-simple-setf-macro cddddr          (SET-CDR (CDDDR :args) :value))
(define-simple-setf-macro nth             (SET-CAR (NTHCDR :args) :value))
;;;(define-simple-setf-macro elt             (SI::SETELT :args :value));***NOT CL***
;;;(define-simple-setf-macro svref           (SI::SET-AR-1 :args :value)) ;***NOT CL***
;;;(define-simple-setf-macro documentation   (SI::SET-DOCUMENTATION :args :value))  ;***NOT CL***
;;;(define-simple-setf-macro symbol-value    (SET :args :value))
;;;(define-simple-setf-macro symbol-function (SI::FDEFINE :args :value))            ;***NOT CL***
;;;(define-simple-setf-macro symbol-plist    (RPLACD (SI::PROPERTY-CELL-LOCATION :args) :value)) ;*** NOT CL***
;;;(define-simple-setf-macro macro-function  (SI::SET-MACRO-FUNCTION :args :value)) ;***NOT CL***

;;; Other required CL SETF methods.
;;;
;;; Note- none of the defsetf'd methods except subseq expand into Common Lisp
;;;       gethash might need to be redone with DEFINE-SETF-METHOD.

(define-setf-method apply (#|*** &environment environment***|# function &rest args)
  (unless (and (consp function)
	       (member (car function) '(function quote))
	       (= (length function) 2)
	       (symbolp (cadr function)))
    (error ;'sys:unknown-setf-reference
	   "In SETF of APPLY, the function applied must be a constant."))
  (multiple-value-bind (tempvars tempargs storevars storeform refform)
      (get-setf-method (cons (cadr function) args) #|*** environment ***|#)
;    (if (memq (cadr function) '(zl:aref cl:aref))	;why special-cased???
;	(setq storeform
;	      `(aset ,(car (last storeform)) . ,(butlast (cdr storeform)))))
    (if (not (eq (car (last storeform)) (car (last tempvars))))
	(error ;'sys:unknown-setf-reference
	  "~S not acceptable within ~S within SETF." function)
      (values tempvars tempargs storevars
	      `(APPLY #',(car storeform) . ,(cdr storeform))
	      `(APPLY #',(car refform) . ,(cdr refform))))))

(defsetf aref (array &rest subscripts) (x)
  `(ASET ,x ,array ,@subscripts))

(defsetf bit (bit-array &rest subscripts) (x)
  `(ASET (THE BIT ,x) ,bit-array ,@subscripts))

(defsetf char (string index) (x)
  `(ASET (THE STRING-CHAR ,x) ,string ,index))

(defsetf fill-pointer (vector) (x)
  `(PROGN (SET-ARRAY-LEADER ,vector 0 ,x)
	  ,x))

;(defsetf get (symbol property-name &optional default) (x)
;  `(SETF (GETF (SYMBOL-PLIST ,symbol) ,property-name ,default) ,x))

;(define-setf-method getf (place indicator &optional default)
;  (multiple-value-bind (temps vals stores store-form access-form)
;      (get-setf-method place)
;    (let ((itemp (gensym))
;	  (dtemp (gensym))
;	  (store (gensym))
;	  (stemp (first stores)))
;      (values (list* itemp dtemp temps)
;	      (list* indicator default vals)
;	      (list store)
;	      (let ((old-plist-temp (gensym)))
;		`(LET ((,old-plist-temp ,access-form))
;		   ,dtemp ;; Ignore default
;		   (IF ,old-plist-temp
;		       ;; If there is an old plist, destructively modify or extend it.
;		       (LABELS ((FOO (PLIST)
;				  (COND ((NULL PLIST)
;					 (RPLACD (LAST ,old-plist-temp)
;						 (LIST ,itemp ,store)))
;					((EQ (CAR PLIST) ,itemp)
;					 (RPLACA (CDR PLIST) ,store))
;					(T
;					 (FOO (CDDR PLIST))))))
;			 (FOO ,old-plist-temp))
;		       ;; If there isn't an old plist, make one.
;		       (LET ((,stemp (LIST ,itemp ,store)))
;			 ,store-form))
;		   ,store))
;	      `(GETF ,access-form ,itemp ,dtemp)))))

(define-setf-method getf (place indicator &optional default)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method place)
    (let ((itemp (gensym 'ind))
	  (dtemp (gensym 'def))
	  (store (gensym 'stor))
	  (stemp (first stores)))
      (values (list* itemp dtemp temps)
	      (list* indicator default vals)
	      (list store)
	      `(LET ((,stemp (%PUTF ,access-form ,itemp ,store))) 
		 ,store-form
		 ,store)
	      `(GETF ,access-form ,itemp ,dtemp)))))

(defsetf gethash (key hash-table &optional default) (value) ;;will this work for incf?
  `(PROGN (PUTHASH ,key ,value ,hash-table)
	  ,value))

(define-setf-method ldb (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (stemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(let ((,stemp (dpb ,store ,btemp ,access-form)))
		 ,store-form
		 ,store)
	      `(ldb ,btemp ,access-form)
	      ))))

(defsetf sbit (simple-bit-array &rest subscripts) (x)
  `(ASET (THE BIT ,x) ,simple-bit-array ,@subscripts))

(defsetf schar (string index) (x)
  `(ASET (THE STRING-CHAR ,x) ,string ,index))

(defsetf subseq (sequence start &optional end) (new-seq)
  `(PROGN (REPLACE ,sequence (THE SEQUENCE ,new-seq) :START-1 ,start :START-2 ,end)
	  ,new-seq))


;;; COMMON LISP READ-MODIFY-WRITE MACROS
;;;

;;; defined by PRIMITIVE-SETF
;(define-modify-macro incf (&optional (delta 1)) +
;  "Increment place's value by DELTA")

;(define-modify-macro decf (&optional (delta 1)) -
;  "Decrement place's value by DELTA")

(define-modify-macro triv-setf (new-value) (lambda (ignore u) u))

(defmacro push (item place)
  "Add ITEM to the front of the list at PLACE."
  (multiple-value-bind (temps values storevars storeform accessform)
      (get-setf-method place)
    (let ((item-temp (gensym)))
      `(LET (,@(mapcar #'list temps values)
	     (,item-temp ,item))
	 (LET ((,(car storevars) (CONS ,item-temp ,accessform)))
	   ,storeform)))))

(defmacro pop (place)
  "Remove the first element from the list at PLACE, and return that element."
  (multiple-value-bind (temps values storevars storeform accessform)
      (get-setf-method place)
    (let ((access-temp (gensym)))
      `(LET* (,@(mapcar #'list temps values)
	      (,access-temp ,accessform)
	      (,(car storevars) (CDR ,access-temp)))
       (PROG1 (CAR ,access-temp)
	      ,storeform)))))

;(defun getf (place property &optional (default nil))
;  "Returns the PROPERTY property from the plist stored in PLACE.
;If there is no such property, DEFAULT is returned.
;PLACE should be such that simply evaluating it would return
;the contents of the property list."
;  (cond ((null place)
;	 default)
;	((eq (car place) property)
;	 (cadr place))
;	(t
;	 (getf (cddr place) property default))))


;;; $$$ From "k-sys:warm;array2" <19-Nov-88 wkf>
(defsetf array-leader set-array-leader)
(defsetf aref (array &rest subscripts) (value)
  `(aset ,value ,array . ,subscripts))

;;; $$$ From "k-sys:warm;lists" <19-Nov-88 wkf>
(defsetf FIRST SET-CAR)

;;; $$$ "k-sys:warm;hash" <19-Nov-88 wkf>
(defsetf %hash-table-size      %hash-table-size-set)
(defsetf %hash-table-use-count %hash-table-use-count-set)
(defsetf %hash-table-test      %hash-table-test-set)
(defsetf %hash-table-rehash-size %hash-table-rehash-size-set)
(defsetf %hash-table-rehash-threshold %hash-table-rehash-threshold-set)
(defsetf %hash-table-data-ptr %hash-table-data-ptr-set)
(defsetf gethash  (key hash-table &optional default) (value)
  `(%sethash ,key ,hash-table ,value))