mirror of
https://github.com/PDP-10/its.git
synced 2026-01-20 01:45:49 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
567 lines
19 KiB
Common Lisp
567 lines
19 KiB
Common Lisp
;;; SETF -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; *************************************************************************
|
||
;;; ***** NIL ******** SETF, PUSH, and POP Expanders ***********************
|
||
;;; *************************************************************************
|
||
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
|
||
;;; *************************************************************************
|
||
|
||
(herald SETF /294)
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((LISP) SUBLOAD)))
|
||
(subload SHARPCONDITIONALS)
|
||
)
|
||
|
||
#+(local MacLISP)
|
||
(eval-when (compile)
|
||
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
|
||
'(SETF +INTERNAL-SETF-X +INTERNAL-SETF-X-1 SETF-SIMPLEP-SCAN
|
||
+INTERNAL-CARCDR-SETF +INTERNAL-PUSH-X +INTERNAL-POP-X
|
||
DEFUPDATE PUSH POP))
|
||
)
|
||
|
||
#+(or NIL LISPM)
|
||
(progn
|
||
(globalize "+INTERNAL-SETF-X")
|
||
(globalize "+INTERNAL-POP-X")
|
||
(globalize "+INTERNAL-SETF-X-1")
|
||
(globalize "+INTERNAL-PUSH-X")
|
||
(globalize "+INTERNAL-CARCDR-SETF")
|
||
(globalize "SETF-SIMPLEP-SCAN")
|
||
(globalize "SETF-STRUCT")
|
||
(globalize "SETF")
|
||
(globalize "DEFUPDATE")
|
||
(globalize "STATIC-AREAP")
|
||
(globalize "WRITEABLEP")
|
||
)
|
||
|
||
|
||
;;; Current contents:
|
||
;;; Functions: +INTERNAL-SETF-X, +INTERNAL-SETF-X-1, +INTERNAL-CARCDR-SETF
|
||
;;; +INTERNAL-PUSH-X, +INTERNAL-POP-X, DEFUPDATE
|
||
;;; and defsetfs for various functions
|
||
|
||
|
||
|
||
#-NIL
|
||
(eval-when (eval compile)
|
||
(subload MACAID)
|
||
;; Following will also load VECTOR and DEFVST at eval-compile times
|
||
(subload EXTMAC)
|
||
(subload EXTEND)
|
||
(subload DEFSETF)
|
||
(subload EVONCE)
|
||
)
|
||
|
||
|
||
;;; ejs: 2018-09-29: commented out since it breaks compilation of this file
|
||
;;; (at least declaring eval-ordered* an lexpr does). However, neither
|
||
;;; eval-ordered* nor setf-struct are lexprs.
|
||
;;;
|
||
;#M (eval-when (eval load compile)
|
||
; (and (status feature COMPLR)
|
||
; (*lexpr EVAL-ORDERED* SETF-STRUCT))
|
||
; )
|
||
|
||
;;Well, when can we take this out? -- JonL, 12/23/80
|
||
#N (progn 'compile
|
||
(defmacro STATIC-AREAP (&rest l) '() )
|
||
(defmacro STATIC-COPY (x) x)
|
||
)
|
||
|
||
#-NIL (progn 'compile
|
||
(defmacro STATIC-AREAP (x)
|
||
#+PDP10 `(PUREP ,x)
|
||
#-PDP10 '() )
|
||
(defmacro STATIC-COPY (x)
|
||
#+PDP10 `(PURCOPY ,x)
|
||
#-PDP10 '() )
|
||
)
|
||
|
||
#+(and MacLISP PDP10) (progn 'compile
|
||
(def-or-autoloadable PUREP PUREP)
|
||
(def-or-autoloadable WRITEABLEP PUREP)
|
||
(def-or-autoloadable LEXPR-FUNCALL LEXPRF)
|
||
(def-or-autoloadable EVAL-ORDERED* EVONCE)
|
||
(def-or-autoloadable GENTEMP MACAID)
|
||
)
|
||
|
||
|
||
|
||
;;;; Comments
|
||
|
||
;; There are problems with doing PUSH and POP regarding multiple evaluations
|
||
;; of the computation yielding the stack. Simply expanding into SETF
|
||
;; results in unobvious order-of-evaluation and multiple evaluation, and
|
||
;; the wrong return result.
|
||
;; To deal with this, we interrupt the SETF expansion midway, after all
|
||
;; the pieces have been picked apart. The setf expanders for the various
|
||
;; functions provide us with a structure containing the computations required,
|
||
;; the value to be stored, and continuation functions to apply to the
|
||
;; computations to get the forms to store and retrieve the value. This lets
|
||
;; us substitute gensyms for computations that we decide should not be repeated
|
||
;; and lambda-bind the gensyms to the computations.
|
||
|
||
;; The components of the setf-struct are as follows
|
||
|
||
;; * SETF-compute A list (who's length we'll call "n")
|
||
;; of forms to be EVAL'ed in the
|
||
;; computation prior to storing the
|
||
;; value.
|
||
;; SETF-i-compute A copy of the initial value of
|
||
;; SETF-compute
|
||
;; SETF-side-effects A flag, non-null if SETF-SIMPLEP-SCAN
|
||
;; encountered any expressions which may
|
||
;; have contained side effects.
|
||
;; Initially ().
|
||
;; * SETF-access A function of n arguments, to be APPLYd
|
||
;; to the applied to the computations
|
||
;; to give a form to access the
|
||
;; specified slot of the structure
|
||
;; given the computations with whatever
|
||
;; gensym substitutions performed.
|
||
;; * SETF-invert A function of n+1 arguments, to be
|
||
;; applied to SETF-allcomps
|
||
;; * SETF-ret-ok A flag, non-null implies form returned
|
||
;; by SETF-invert will be the value of
|
||
;; the SETF-value-expr
|
||
;; SETF-genvals A list of values for which gensym
|
||
;; been substituted for in SETF-compute.
|
||
;; SETF-gensyms A list of gensyms, one-to-one with
|
||
;; values in SETF-genvals
|
||
;; SETF-user-slot A slot available for communication
|
||
;; between SETF-X expanders and their
|
||
;; continuations (INVERT and ACCESS)
|
||
|
||
;; These objects are returned by +INTERNAL-SETF-X-1. They are updated by
|
||
;; SETF-SIMPLEP-SCAN to build the SETF-genvals and SETF-gensyms slots, from
|
||
;; which a lambda form can be wrapped around the accessing and setting.
|
||
;; The user of the structure is responsible for remembering the value to
|
||
;; be stored, and possibly substituting a gensym for it in the lambda form.
|
||
|
||
;; The slots marked above with a "*" are supplied by calling the SETF-X
|
||
;; property on the X part of (SETF X Y). (the case of X being a symbol
|
||
;; is special-cased, and the CAR/CDR cases are handled specially if no
|
||
;; SETF property is found.)
|
||
|
||
|
||
;; (SETF-STRUCT access invert ret-ok compute)
|
||
;; creates one of these SETF structures. The value component is
|
||
|
||
;; Note: The variable EFFS herein is not special. It is, however, equivalent
|
||
;; in function to the compiler's (NCOMPLR and LCP) variable EFFS. If non-(),
|
||
;; the form is being expanded "for effect", i.e. the return value is going to b
|
||
;; ignored, so don't bother taking pains to preserve it. It is supplied as ()
|
||
;; in the interpreter, and currently in the compiler as well.
|
||
|
||
;; +INTERNAL-PUSH-X and +INTERNAL-POP-X are called by the interpreter and
|
||
;; compiler to expand complex PUSH and POPs. The first argument is the
|
||
;; CDR of the PUSH or POP form (viewed as a macro, or the entire argument
|
||
;; to the PUSH or POP FSUBR in the interpreter). The second is the
|
||
;; EFFS argument as above.
|
||
|
||
;; (DEFMACRO PUSH (&REST PUSH-ARGS) `(+INTERNAL-PUSH-X ,PUSH-ARGS () ))
|
||
;; (DEFMACRO POP (&REST POP-ARGS) `(+INTERNAL-POP-X ,POP-ARGS () ))
|
||
|
||
|
||
;;;; +INTERNAL-PUSH-X and +INTERNAL-POP-X
|
||
|
||
(defmacro DEFUPDATE (name conser)
|
||
`(DEFMACRO ,name (&WHOLE FORM)
|
||
(+INTERNAL-PUSH-X (CDR FORM)
|
||
() ;Losing compiler doesn't hack EFFS
|
||
;at macro-expansion time.
|
||
',conser)))
|
||
|
||
;; example: (defupdate PUSH CONS)
|
||
;; (defupdate accumulate PLUS)
|
||
;; (defmacro increment (x) `(accumulate 1 ,x))
|
||
|
||
(defun +INTERNAL-PUSH-X ((val stack) effs &optional (push-cons 'CONS)
|
||
&aux valval valsym temp incrementation)
|
||
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () )))
|
||
(cond ((and (not (|constant-p/|| val))
|
||
(not (null (SETF-gensyms expf-stack))))
|
||
(setq valval (ncons val)
|
||
valsym (ncons (si:gen-local-var val)))))
|
||
(setq incrementation `(,push-cons ,val ,(setf-access-form expf-stack)))
|
||
(cond ((or effs (SETF-ret-ok expf-stack))
|
||
(setq temp (setf-invert-form expf-stack incrementation)))
|
||
('T (si:gen-local-var temp)
|
||
(setq temp
|
||
`((LAMBDA (,temp)
|
||
,(setf-invert-form expf-stack temp)
|
||
,temp)
|
||
,incrementation))))
|
||
(cond ((null (SETF-gensyms expf-stack)) temp)
|
||
('T `((LAMBDA (,@valsym ,.(SETF-gensyms expf-stack))
|
||
,temp)
|
||
,.valval ,.(SETF-genvals expf-stack))))))
|
||
|
||
|
||
;; POP must be careful of side-effect interactions between first and second arg
|
||
|
||
(defun +INTERNAL-POP-X (foo effs &optional (pop-car 'CAR) (pop-cdr 'CDR)
|
||
&aux (stack (car foo)) (into (cdr foo)))
|
||
|
||
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () ))
|
||
(expf-into (and (not (null into)) (+internal-setf-x-1 (car into))))
|
||
stack-access-form temp tsym )
|
||
(if into (setf-simplep-scan expf-into (SETF-side-effects expf-stack) ))
|
||
(cond ((or (not (null (SETF-gensyms expf-stack)))
|
||
(and into (SETF-side-effects expf-into)))
|
||
(si:gen-local-var tsym)
|
||
(setq temp `((CAR ,tsym)))
|
||
(if (and (not effs) ;Maybe save ret value
|
||
(not (SETF-ret-ok expf-into)))
|
||
(setq temp `((SETQ ,tsym ,@temp))))
|
||
(cond (into
|
||
(if (and (SETF-side-effects expf-into)
|
||
(not (SETF-side-effects expf-stack)))
|
||
(setf-simplep-scan expf-stack 'T))
|
||
(setq temp
|
||
(ncons (setf-invert-form expf-into (car temp))))))
|
||
(if (and (not effs)
|
||
(not (SETF-ret-ok expf-into))) ;Maybe need ret value
|
||
(setq temp `(,@temp ,tsym)))
|
||
`((LAMBDA (,.(SETF-gensyms expf-stack)
|
||
,.(and into (SETF-gensyms expf-into)))
|
||
((LAMBDA (,tsym)
|
||
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
|
||
,@temp)
|
||
,(setf-access-form expf-stack)))
|
||
,.(SETF-genvals expf-stack)
|
||
,.(and into (SETF-genvals expf-into))))
|
||
((+internal-dup-p
|
||
(setq stack-access-form (setf-access-form expf-stack)))
|
||
(setq temp `(,pop-car ,stack-access-form))
|
||
(cond ((not (null into)) ;Better code with SETQ inside PROG2
|
||
(setq temp
|
||
(+internal-setf-x `(,(car into) ,temp) effs))))
|
||
`(PROG2 ()
|
||
,temp
|
||
,(setf-invert-form expf-stack `(,pop-cdr ,stack-access-form))))
|
||
('T (si:gen-local-var tsym)
|
||
(setq temp `((LAMBDA (,tsym)
|
||
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
|
||
(,pop-car ,tsym))
|
||
,stack-access-form))
|
||
(if into
|
||
(+internal-setf-x `(,(car into) ,temp) effs)
|
||
temp)))))
|
||
|
||
|
||
|
||
;;;; SETF macro, +INTERNAL-SETF-X, and SETF-SIMPLEP-SCAN
|
||
|
||
|
||
(defmacro SETF (&rest w) (+internal-setf-x w () ))
|
||
|
||
(defun +INTERNAL-SETF-X (w effs)
|
||
(do ((l w (cddr l))
|
||
(form) (val) (expf) (val-gensym) (ret-form))
|
||
((null l)
|
||
(cond ((null (cdr ret-form)) (car ret-form))
|
||
('T `(PROGN ,. (nreverse ret-form)))))
|
||
;One step in expanding "(SETF ... form val ... )"
|
||
(desetq (form val) l)
|
||
(if (null (cdr l))
|
||
(setq val (cerror T () ':WRONG-NUMBER-OF-ARGUMENTS
|
||
"SETF called with an odd number of arguments. ~@
|
||
Extra reference = ~3G~S.~@
|
||
Supply a form to evaluate, store and return."
|
||
'SETF (length w) w form)))
|
||
(setq expf (+INTERNAL-SETF-X-1 form))
|
||
(cond ((or (and (null (cddr l)) ;If at end of SETF
|
||
(not effs) ;If values matter at all
|
||
(not (SETF-ret-ok expf)) ;If it wrong val at end
|
||
(not (+internal-dup-p val))) ;And we can't duplicate
|
||
(not (equal (SETF-compute expf) ;If already simplified
|
||
(SETF-i-compute expf))))
|
||
(if (equal (SETF-compute expf)
|
||
(SETF-i-compute expf))
|
||
(setf-simplep-scan expf () ))
|
||
(si:gen-local-var val-gensym)
|
||
(push `((lambda (,@(SETF-gensyms expf) ,val-gensym)
|
||
,(setf-invert-form expf val-gensym)
|
||
,val-gensym)
|
||
,@(SETF-genvals expf) ,val)
|
||
ret-form))
|
||
('T (setq ret-form (cons (setf-invert-form expf val)
|
||
ret-form))
|
||
(cond ((and (not effs)
|
||
(not (cddr l))
|
||
(not (SETF-ret-ok expf)))
|
||
(setq ret-form (cons val ret-form))))))))
|
||
|
||
|
||
;; Call SETF-SIMPLEP-SCAN on a SETF-STRUCT, and a second arg saying whether
|
||
;; or not side effects have been detected.
|
||
;; NO-OP if SETF-SIMPLEP-SCAN already called on it.
|
||
|
||
(defun SETF-SIMPLEP-SCAN (expf known-side-effects?)
|
||
(if (null (SETF-gensyms expf))
|
||
(do ((rest (SETF-compute expf) (cdr rest))
|
||
(clist) (slist) (sitem)
|
||
(original) (expansion))
|
||
((null rest)
|
||
(SSETF-genvals expf (nreverse clist))
|
||
(SSETF-gensyms expf (nreverse slist)))
|
||
(setq expansion (macroexpand (setq original (car rest))))
|
||
;; Why isn't the following RPLACA conditionalized by
|
||
;; (cond ((not (static-areap original)))
|
||
;; ((writeablep original)
|
||
;; ;; Writeable, but 'static', so someday may be purified.
|
||
;; (setq expansion (static-copy expansion))
|
||
;; 'T))
|
||
(rplaca rest expansion)
|
||
(cond ((or (|constant-p/|| expansion) ;Always safe!
|
||
(and (null known-side-effects?)
|
||
(+internal-dup-p expansion)))
|
||
;; Nothing to be done in these cases
|
||
() )
|
||
((and (null known-side-effects?) (|side-effectsp/|| expansion))
|
||
;;All is in, so reset and carefully do it again!
|
||
(SSETF-compute expf (append (SETF-I-compute expf) () ))
|
||
(SSETF-side-effects expf 'T)
|
||
(return (setf-simplep-scan expf 'T)))
|
||
('T (si:gen-local-var sitem)
|
||
(push expansion clist)
|
||
(push sitem slist)
|
||
(rplaca rest sitem)))))
|
||
expf)
|
||
|
||
|
||
;;;; +INTERNAL-SETF-X-1 and +INTERNAL-CARCDR-SETF
|
||
|
||
|
||
;; +INTERNAL-SETF-X-1 takes an access expression and returns a SETF-STRUCT
|
||
;; which contains the various info documented at the head of this file.
|
||
|
||
;; The way the expansion happens is a loop of the following:
|
||
;; a) If it's a symbol, special case
|
||
;; b) If the CAR is a symbol, and has a SETF-X property, FUNCALL it on the
|
||
;; access and value expressions (unless that property is 'AUTOLOAD',
|
||
;; meaning that autoloading should be tried if possible, or if it is
|
||
;; 'SETF-X' meaning autoloading has been tried and lost).
|
||
;; c) If it's a macro, MACROEXPAND-1 it and return
|
||
|
||
(defun +INTERNAL-SETF-X-1 (expr)
|
||
(prog (temp oper)
|
||
A (cond ((atom expr)
|
||
(cond ((symbolp expr)
|
||
(return (SETF-STRUCT `(LAMBDA (()) ',expr)
|
||
`(lambda (() y) `(setq ,',expr ,y))
|
||
'T
|
||
() )))))
|
||
((not (symbolp (setq oper (car expr)))) () )
|
||
((and (setq temp (get oper 'SETF-X))
|
||
(not (memq temp '(AUTOLOAD SETF-X))))
|
||
(return (funcall temp expr)))
|
||
('T (cond ((and (cond ((null temp)
|
||
;;This excludes carcdrs ??
|
||
(not (fboundp oper)))
|
||
((eq temp 'AUTOLOAD))) ;Help for LDB etc
|
||
(setq temp (get oper 'AUTOLOAD)))
|
||
(funcall autoload `(,oper . ,temp))
|
||
(cond ((setq temp (get oper 'SETF-X))
|
||
(return (funcall temp expr)))
|
||
('T (putprop oper 'SETF-X 'SETF-X))))
|
||
((setq temp (macroexpand-1* expr))
|
||
;allow macro-redefinition, even for carcdr functions
|
||
(return (+INTERNAL-SETF-X-1 (car temp))))
|
||
((setq temp (|carcdrp/|| oper))
|
||
(return (+INTERNAL-carcdr-setf temp expr))))))
|
||
(setq expr (error '|Obscure format - SETF| expr 'WRNG-TYPE-ARG))
|
||
(go A)
|
||
))
|
||
|
||
|
||
(defun +INTERNAL-CARCDR-SETF (carcdrspec expr)
|
||
(let ((rplac (cond ((eq (car carcdrspec) 'A) 'rplaca)
|
||
('T 'rplacd)) )
|
||
(op (cond ((eq (car carcdrspec) 'A) 'CAR)
|
||
('T 'CDR)))
|
||
(carcdr (cadr carcdrspec) )
|
||
((() pair) expr)
|
||
(subform) )
|
||
(setq subform (cond ((or (null carcdr) (eq carcdr 'CR)) pair)
|
||
('T `(,carcdr ,pair))))
|
||
(SETF-STRUCT `(LAMBDA (() X) `(,',op ,x))
|
||
`(LAMBDA (() VALUE PAIR) `(,',rplac ,pair ,value))
|
||
()
|
||
`(,subform))))
|
||
|
||
(defun setf-invert-form (expf val)
|
||
(lexpr-funcall (SETF-invert expf)
|
||
expf
|
||
val
|
||
(SETF-compute expf)))
|
||
|
||
(defun setf-access-form (expf)
|
||
(lexpr-funcall (SETF-access expf)
|
||
expf
|
||
(SETF-compute expf)))
|
||
|
||
|
||
; SETF-STRUCT is a slight variant on the constructor function
|
||
(defun SETF-STRUCT (access invert ret-ok compute &optional function)
|
||
(CONS-A-SETF COMPUTE compute
|
||
I-COMPUTE (APPEND compute ())
|
||
RET-OK ret-ok
|
||
ACCESS access
|
||
INVERT invert
|
||
FUNCTION function))
|
||
|
||
|
||
|
||
;;;; DEFSETFs for various system functions
|
||
|
||
|
||
(defsetf CXR ((() index frob) value) ()
|
||
`(RPLACX ,index ,frob ,value))
|
||
|
||
(defsetf NTH ((() index frob) value) ()
|
||
`(RPLACA (NTHCDR ,index ,frob) ,value))
|
||
|
||
(defsetf NTHCDR ((() index frob) value) ()
|
||
`(RPLACD (NTHCDR (1- ,index) ,frob) ,value))
|
||
|
||
|
||
;; The PROGN stuff isn't optimal, it will generate LAMBDAs unnecessarily.
|
||
;; Hopefully the compiler will eliminate them.
|
||
|
||
|
||
|
||
|
||
(defprop PROGN T SETF-PROGNP)
|
||
|
||
(defun (progn SETF-X-ACCESS) (expf &restl steps)
|
||
(let (( (fun . expf-frobref) (setf-user-slot expf)))
|
||
(if (and (null steps) (get fun 'SETF-PROGNP))
|
||
(setf-access-form expf-frobref)
|
||
`(,fun ,@steps ,(setf-access-form expf-frobref)))))
|
||
|
||
(defun (progn SETF-X-INVERT) (expf val &restl steps)
|
||
(let* (( (fun . expf-frobref) (setf-user-slot expf)))
|
||
(if (and (null steps) (get fun 'SETF-PROGNP))
|
||
(setf-invert-form expf-frobref val)
|
||
`(,fun ,@steps ,(setf-invert-form expf-frobref val)))))
|
||
|
||
(defun (progn SETF-X)
|
||
(expr &aux (fun (car expr)) temp frobref steps expf expf-frobref)
|
||
(setq temp (reverse (cdr expr))
|
||
frobref (car temp)
|
||
steps (nreverse (cdr temp))
|
||
expf (setf-simplep-scan
|
||
(setf-struct #,(get 'PROGN 'SETF-X-ACCESS)
|
||
#,(get 'PROGN 'SETF-X-INVERT)
|
||
()
|
||
steps)
|
||
() )
|
||
expf-frobref (setf-simplep-scan (+internal-setf-x-1 frobref) () ))
|
||
(SSETF-user-slot expf (list* fun expf-frobref))
|
||
(SSETF-genvals expf (append (SETF-genvals expf)
|
||
(SETF-genvals expf-frobref)))
|
||
(SSETF-gensyms expf (append (SETF-gensyms expf)
|
||
(SETF-gensyms expf-frobref)))
|
||
(SSETF-ret-ok expf (SETF-ret-ok expf-frobref))
|
||
expf)
|
||
|
||
|
||
|
||
|
||
(defun (arraycall SETF-X-ACCESS) (expf array &restl indices)
|
||
`(ARRAYCALL ,(SETF-user-slot expf) ,array ,. indices))
|
||
|
||
(defun (arraycall SETF-X-INVERT) (expf val array &restl indices)
|
||
(let ((gensyms (mapcar #'(lambda (() ) (si:gen-local-var () "Index"))
|
||
indices)))
|
||
(eval-ordered* `(A ,@gensyms V)
|
||
`(,array ,@indices ,val)
|
||
``((store (arraycall ,',(SETF-user-slot expf)
|
||
,A
|
||
,,@gensyms)
|
||
,V)))))
|
||
|
||
(defun (arraycall SETF-X) (g)
|
||
(let* (( (() type . frobs) g)
|
||
(struct (setf-struct #,(get 'ARRAYCALL 'SETF-X-ACCESS)
|
||
#,(get 'ARRAYCALL 'SETF-X-INVERT)
|
||
'T
|
||
frobs)))
|
||
(SSETF-user-slot struct type)
|
||
struct))
|
||
|
||
|
||
|
||
(defsetf GET ((() sym tag) value) T
|
||
(eval-ordered* '(X A V)
|
||
`(,sym ,tag ,value)
|
||
'`((PUTPROP ,X ,V ,A))))
|
||
|
||
(defsetf PLIST ((() sym) value) T
|
||
`(SETPLIST ,sym ,value))
|
||
|
||
(defsetf SYMEVAL ((() sym) value) T
|
||
`(SET ,sym ,value))
|
||
|
||
(defsetf ARG ((() argument) value) T
|
||
`(SETARG ,argument ,value))
|
||
|
||
(defsetf ARGS ((() argument) value) ()
|
||
`(ARGS ,argument ,value))
|
||
|
||
(defsetf SFA-GET ((() sfa loc) value) T
|
||
`(SFA-STORE ,sfa ,loc ,value))
|
||
|
||
|
||
(defsetf FIXNUM-IDENTITY ((() x) value) T
|
||
`(FIXNUM-IDENTITY (SETF ,x (FIXNUM-IDENTITY ,value))))
|
||
|
||
(putprop 'FLONUM-IDENTITY (get 'FIXNUM-IDENTITY 'SETF-X) 'SETF-X)
|
||
|
||
|
||
|
||
(defsetf LDB ((() byte word) value) ()
|
||
(si:ldb-dpb-stfx word byte () value '(DPB . T)))
|
||
(defsetf LOAD-BYTE ((() word position size) value) ()
|
||
(si:ldb-dpb-stfx word position size value '(DEPOSIT-BYTE . () )))
|
||
|
||
|
||
(defun SI:LDB-DPB-STFX (word position size value foo)
|
||
(let ((dpber (car foo)) ;like *DPB or DEPOSIT-BYTE or ...
|
||
(ppssp (cdr foo)) ;non-null iff LDB/DPB rather than LOAD-BYTE/...
|
||
(byte position) ;in the LDB case (as opposed to LOAD-BYTE)
|
||
(expf (+internal-setf-x-1 word))
|
||
side-effects valq valb byteq byteb)
|
||
(SETF-simplep-scan expf () )
|
||
(cond ((null ppssp) () )
|
||
((or (SETF-side-effects expf)
|
||
(|side-effectsp/|| value)
|
||
(|side-effectsp/|| byte))
|
||
(cond ((|constant-p/|| value))
|
||
('T (si:gen-local-var valq)
|
||
(setq valq (list valq) valb (list value)
|
||
value (car valq) side-effects 'T)))
|
||
(cond ((|constant-p/|| byte))
|
||
('T (si:gen-local-var byteq)
|
||
(setq byteq (list byteq) byteb (list byte)
|
||
byte (car byteq) side-effects 'T)))))
|
||
(let* ((access (setf-access-form expf))
|
||
(invert (setf-invert-form
|
||
expf
|
||
(if ppssp
|
||
`(,DPBer ,value ,byte ,access)
|
||
`(,DPBer ,access ,position ,size ,value)))))
|
||
(cond ((or side-effects (not (null (SETF-gensyms expf))))
|
||
`((LAMBDA (,.byteq ,@(SETF-gensyms expf) ,.valq)
|
||
,invert)
|
||
,.byteb ,@(SETF-genvals expf) ,.valb))
|
||
('T invert)))))
|
||
|
||
|
||
|
||
|