mirror of
https://github.com/PDP-10/its.git
synced 2026-01-21 02:08:50 +00:00
157 lines
4.7 KiB
Common Lisp
Executable File
157 lines
4.7 KiB
Common Lisp
Executable File
;;;-*-Lisp-*-
|
||
|
||
(declare (load '((alan) lspenv init)))
|
||
|
||
;A winning macro to store things anywhere:
|
||
(defmacro setf (expr val)
|
||
(prog (head y)
|
||
(go A)
|
||
expand (setq expr (funcall (cadr y) expr))
|
||
A (cond ((atom expr)
|
||
(or (symbolp expr) (go barf))
|
||
(return `(setq ,expr ,val))))
|
||
(setq head (car expr))
|
||
(or (symbolp head) (go barf))
|
||
(and (setq y (getl head '(setf setf-subr))) (go call))
|
||
(setq y (getl head '(macro subr lsubr expr fsubr fexpr array)))
|
||
(and (eq (car y) 'macro) (go expand))
|
||
(and (or (not (null y))
|
||
(null (setq y (get head 'autoload))))
|
||
(go barf))
|
||
(load y)
|
||
(and (setq y (getl head '(setf setf-subr))) (go call))
|
||
(setq y (getl head '(macro subr lsubr expr fsubr fexpr array)))
|
||
(and (eq (car y) 'macro) (go expand))
|
||
barf (error '|-- SETF can't handle this.| expr)
|
||
call (return (if (eq (car y) 'setf)
|
||
(funcall (cadr y) expr val)
|
||
(subrcall t (cadr y) expr val)))))
|
||
|
||
(defmacro defsetf (name pat var &body body)
|
||
(let ((sym (gensym)))
|
||
`(eval-when (eval compile load)
|
||
(defun (,name setf setf-subr) (,sym ,var)
|
||
(bind-arguments (,pat (cdr ,sym)
|
||
(error '|-- SETF can't handle this.| ,sym))
|
||
,@body)))))
|
||
|
||
(defun car-cdr/ setf (x v)
|
||
(or (= 2 (length x))
|
||
(error '|-- SETF can't handle this.| x))
|
||
(let ((p (get (car x) 'car-cdr/ setf)))
|
||
`(,(car p) (,(cdr p) ,(cadr x)) ,v)))
|
||
|
||
(setq car-cdr/ setf (get 'car-cdr/ setf 'subr))
|
||
|
||
(mapc '(lambda (x) (putprop x car-cdr/ setf 'setf-subr))
|
||
'(caar cdar cadr cddr caaar cdaar cadar cddar caadr
|
||
cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar
|
||
cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr
|
||
cdaddr cadddr cddddr))
|
||
|
||
(putprop 'caar '(rplaca . car) 'car-cdr/ setf)
|
||
(putprop 'cdar '(rplacd . car) 'car-cdr/ setf)
|
||
(putprop 'cadr '(rplaca . cdr) 'car-cdr/ setf)
|
||
(putprop 'cddr '(rplacd . cdr) 'car-cdr/ setf)
|
||
(putprop 'caaar '(rplaca . caar) 'car-cdr/ setf)
|
||
(putprop 'cdaar '(rplacd . caar) 'car-cdr/ setf)
|
||
(putprop 'cadar '(rplaca . cdar) 'car-cdr/ setf)
|
||
(putprop 'cddar '(rplacd . cdar) 'car-cdr/ setf)
|
||
(putprop 'caadr '(rplaca . cadr) 'car-cdr/ setf)
|
||
(putprop 'cdadr '(rplacd . cadr) 'car-cdr/ setf)
|
||
(putprop 'caddr '(rplaca . cddr) 'car-cdr/ setf)
|
||
(putprop 'cdddr '(rplacd . cddr) 'car-cdr/ setf)
|
||
(putprop 'caaaar '(rplaca . caaar) 'car-cdr/ setf)
|
||
(putprop 'cdaaar '(rplacd . caaar) 'car-cdr/ setf)
|
||
(putprop 'cadaar '(rplaca . cdaar) 'car-cdr/ setf)
|
||
(putprop 'cddaar '(rplacd . cdaar) 'car-cdr/ setf)
|
||
(putprop 'caadar '(rplaca . cadar) 'car-cdr/ setf)
|
||
(putprop 'cdadar '(rplacd . cadar) 'car-cdr/ setf)
|
||
(putprop 'caddar '(rplaca . cddar) 'car-cdr/ setf)
|
||
(putprop 'cdddar '(rplacd . cddar) 'car-cdr/ setf)
|
||
(putprop 'caaadr '(rplaca . caadr) 'car-cdr/ setf)
|
||
(putprop 'cdaadr '(rplacd . caadr) 'car-cdr/ setf)
|
||
(putprop 'cadadr '(rplaca . cdadr) 'car-cdr/ setf)
|
||
(putprop 'cddadr '(rplacd . cdadr) 'car-cdr/ setf)
|
||
(putprop 'caaddr '(rplaca . caddr) 'car-cdr/ setf)
|
||
(putprop 'cdaddr '(rplacd . caddr) 'car-cdr/ setf)
|
||
(putprop 'cadddr '(rplaca . cdddr) 'car-cdr/ setf)
|
||
(putprop 'cddddr '(rplacd . cdddr) 'car-cdr/ setf)
|
||
|
||
(defsetf car (x) v `(rplaca ,x ,v))
|
||
|
||
(defsetf cdr (x) v `(rplacd ,x ,v))
|
||
|
||
(defsetf cxr (n x) v `(rplacx ,n ,x ,v))
|
||
|
||
(defsetf nth (n x) v `(rplaca (nthcdr ,n ,x) ,v))
|
||
|
||
(defsetf nthcdr (n x) v `(rplacd (nthcdr (1- ,n) ,x) ,v))
|
||
|
||
(defsetf arraycall tail v `(store (arraycall . ,tail) ,v))
|
||
|
||
(defsetf get (sym ind) v `(putprop ,sym ,v ,ind))
|
||
|
||
(defsetf plist (x) v `(setplist ,x ,v))
|
||
|
||
(defsetf symeval (x) v `(set ,x ,v))
|
||
|
||
(defsetf arg (x) v `(setarg ,x ,v))
|
||
|
||
(defsetf args (x) v `(args ,x ,v))
|
||
|
||
(defsetf sfa-get (sfa n) v `(sfa-store ,sfa ,n ,v))
|
||
|
||
(defsetf ldb (ppss x) v `(setf ,x (dpb ,v ,ppss ,x)))
|
||
|
||
(defsetf byte-size (byte-spec) ss
|
||
`(setf ,byte-spec (dpb ,ss #o0006 ,byte-spec)))
|
||
|
||
(defsetf byte-position (byte-spec) ss
|
||
`(setf ,byte-spec (dpb ,ss #o0606 ,byte-spec)))
|
||
|
||
(defsetf fixnum-identity (x) v
|
||
`(setf ,x (fixnum-identity ,v)))
|
||
|
||
(defsetf flonum-identity (x) v
|
||
`(setf ,x (flonum-identity ,v)))
|
||
|
||
(defsetf examine (x) v
|
||
`(deposit ,x ,v))
|
||
|
||
(defsetf defstruct-examine (x name slot) v
|
||
`(defstruct-deposit ,v ,x ,name ,slot))
|
||
|
||
(defsetf examine-job (x) v
|
||
`(deposit-job ,x ,v))
|
||
|
||
(defsetf xcar (x) v `(xrplaca ,x ,v))
|
||
|
||
(defsetf xcdr (x) v `(xrplacd ,x ,v))
|
||
|
||
(defsetf xcxr (n x) v `(xrplacx ,n ,x ,v))
|
||
|
||
;;;Pretty random:
|
||
(defsetf progn (first &rest rest) v
|
||
(if (null rest)
|
||
`(setf ,first ,v)
|
||
`(progn ,first
|
||
(setf (progn ,@rest) ,v))))
|
||
|
||
;;;Completely random:
|
||
(defsetf if (if then else) v
|
||
`(if ,if
|
||
(setf ,then ,v)
|
||
(setf ,else ,v)))
|
||
|
||
(defsetf prog1 (first &rest rest) v
|
||
`(progn (setf ,first ,v)
|
||
,@rest))
|
||
|
||
(defsetf prog2 (first second &rest rest) v
|
||
`(progn ,first
|
||
(setf ,second ,v)
|
||
,@rest))
|
||
|
||
(sstatus feature alan/;setf)
|