Compile lisp;defset from source.

Resolves #976.

build/lisp.tcl

@@ -851,6 +851,12 @@ respond "_" "lisp;_lspsrc;mlmac\r"
 respond "_" "\032"
 type ":kill\r"
 
+# DEFSET
+respond "*" "complr\013"
+respond "_" "lisp;_nilcom;defset\r"
+respond "_" "\032"
+type ":kill\r"
+
 # Lisp display library
 respond "*" ":midas lisp; slave fasl_l; slave\r"
 expect ":KILL"

src/nilcom/defset.107

@@ -0,0 +1,113 @@
+;;;  DEFSETF   				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;  *************************************************************************
+;;;  ***** MacLISP ******* DEFine SETF structures -- a macro *****************
+;;;  *************************************************************************
+;;;  ** (c) Copyright 1981 Massachusetts Institute of Technology *************
+;;;  *************************************************************************
+
+
+(herald DEFSETF /96)
+
+#-NIL (include ((lisp) subload lsp))
+
+#-NIL 
+(eval-when (eval compile)
+  (subload SHARPCONDITIONALS)
+)
+
+
+#+(local MacLISP)
+(eval-when (eval compile)
+  (subload EXTEND)
+  (subload EXTMAC)
+  (subload VECTOR)
+  )
+
+#+(or LISPM (and NIL (not MacLISP)))
+(globalize "DEFSETF" "SETF")
+
+
+
+(eval-when (eval compile)
+  #+(local MacLISP) (and (fboundp '*lexpr) (*lexpr symbolconc))
+  (setq DEFMACRO-DISPLACE-CALL MACROEXPANDED) 
+  #-NIL (subload DEFVST)
+  )
+
+#-NIL
+(eval-when (eval load compile)  
+	    ;; EXTHUK needed for SI:XREF
+   (subload EXTHUK)
+  )
+
+(def-or-autoloadable GENTEMP MACAID)
+
+
+;;;; define SETF structures
+
+; SSETF-<mumble>  is a slight variant on the update format for structures
+;   e.g. (SSETF-<mumble> foo val)  ==>  (SETVST (SETF-<mumble> foo) val)
+
+
+#-LISPM 
+(defmacro (DEFINE-SETFS-STRUCTURE defmacro-for-compiling () defmacro-displace-call () )
+	  (&REST keys)
+    `(PROGN 'COMPILE 
+	    (DEFVST SETF ,. keys)
+	    ,.(mapcar 
+	        '(lambda (x)
+		   `(defmacro ,(intern (symbolconc '|SSETF-| x)) (struct val)
+		       `(SETVST (,',(intern (symbolconc '|SETF-| x)) ,struct) ,val)))
+		keys)))
+
+#+LISPM 
+(defmacro DEFINE-SETFS-STRUCTURE (&rest form)
+     (do ((x form (cdr x))  (funs)  (accessors))
+	 ((null x)
+	   `(progn 'compile 
+		   (defstruct (setf-struct :constructor cons-a-setf)
+			      ,@accessors)
+		   ,@funs))
+       (push (string-append "SETF-" x) accessors)
+       (push `(defmacro ,(string-append "SSETF-" x) (frob val)
+		   `(setf (,',(car accessors) ,frob) ,val))
+	     funs)))
+
+
+(DEFINE-SETFS-STRUCTURE compute i-compute side-effects ret-ok
+			access invert genvals gensyms user-slot
+			function)
+
+
+;;;;  DEFSETF
+
+(defmacro DEFSETF (name (( fun . vars) val) ret-ok invert)
+  (let ((access (gentemp "access-spec"))
+	(funsym (gentemp "Function"))
+	(struct (gentemp "SETF-struct"))
+	(access-name (intern (symbolconc name '| SETF-X-ACCESS|)))
+	(invert-name (intern (symbolconc name '| SETF-X-INVERT|)))
+	(other-funs)
+	(computes (delete () vars)))
+    (if (not (atom name))
+	(desetq (name . other-funs) name))
+    `(PROGN 'COMPILE
+	(|forget-macromemos/|| () ) 			;Invalidate memoizings
+	(DEFUN ,access-name (,struct ,@computes)
+	  (LET ((,funsym (setf-function ,struct)))
+	    `(,,funsym ,,@vars)))
+	(DEFUN ,invert-name (,struct ,val ,@computes)
+	  (let ((,fun (setf-function ,struct)))
+	    ,invert))
+	(DEFUN (,name SETF-X) (,access)
+	   (let (( (,funsym ,@vars) ,access))
+	      (SETF-STRUCT ',access-name		;Access continuation
+			   ',invert-name		;Invert continuation
+			   ',ret-ok			;Return value right?
+			   `(,,@computes)
+			   ,funsym)))
+	,.(mapcar #'(lambda (other-fun)
+		      `(PUTPROP ',other-fun (GET ',name 'SETF-X) 'SETF-X))
+		  other-funs)
+	',name)))
+