mirror of
https://github.com/PDP-10/its.git
synced 2026-01-21 10:13:35 +00:00
114 lines
3.1 KiB
Common Lisp
114 lines
3.1 KiB
Common Lisp
;;; 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)))
|
||
|