mirror of
https://github.com/PDP-10/its.git
synced 2026-03-01 09:40:56 +00:00
98 lines
3.1 KiB
Common Lisp
Executable File
98 lines
3.1 KiB
Common Lisp
Executable File
;;; EVONCE -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
|
||
;;; **************************************************************
|
||
;;; ***** MACLISP ******* Macro for Defining SETF Structures *****
|
||
;;; **************************************************************
|
||
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
|
||
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
|
||
;;; **************************************************************
|
||
|
||
|
||
(eval-when (eval compile)
|
||
(cond ((and (status feature MACLISP) (status nofeature FOR-NIL))
|
||
(sstatus feature FM)
|
||
(sstatus feature FOR-MACLISP)))
|
||
)
|
||
|
||
#-FM (globalize "EVAL-ORDERED" "EVAL-ORDERED*")
|
||
|
||
|
||
(herald EVONCE /14)
|
||
|
||
#-For-NIL (eval-when (eval compile)
|
||
(macro lispdir (x)
|
||
(setq x (cadr x))
|
||
#+Pdp10 `(QUOTE ((LISP) ,x))
|
||
#+Lispm (string-append "lisp;" (get-pname x) "qfasl")
|
||
#+Multics (catenate ">exl>lisp_dir>object" (get_pname x))
|
||
#+For-NIL (string-append "lisp:" (get-pname x) "vasl")
|
||
)
|
||
(macro subload (x)
|
||
(setq x (cadr x))
|
||
`(OR (GET ',x 'VERSION) (LOAD #%(LISPDIR ,x))))
|
||
(subload DEFSETF)
|
||
)
|
||
|
||
|
||
|
||
(defmacro EVAL-ORDERED (bvl forms &rest body)
|
||
(eval-ordered* bvl forms body))
|
||
|
||
; (not (null (SETF-gensyms expf))) is not really the right
|
||
; predicate. Consider where one side-effectible and rest all constant.
|
||
; the right thing to do is to use SETF-SIDE-EFFECT-SCAN rather than SIMPLEP
|
||
; since we aren't worried about multiple evaluation, just ordering.
|
||
; Don't forget to write SETF-SIDE-EFFECT-SCAN first!
|
||
|
||
(defun eval-ordered* (bvl forms body)
|
||
(let ((expf (SETF-struct () () () forms)))
|
||
(SETF-simplep-scan expf ())
|
||
(progv bvl (SETF-compute expf)
|
||
(cond ((not (null (SETF-gensyms expf)))
|
||
`((lambda ,(SETF-gensyms expf)
|
||
,@(eval body))
|
||
,@(setf-genvals expf)))
|
||
('T `(progn ,@(eval body)))))))
|
||
|
||
|
||
|
||
|
||
;; The following is not yet complete...make it invisible
|
||
|
||
#+EVAL-ONCE-TEST
|
||
|
||
(defmacro eval-once (bvl . body)
|
||
(do ((ibvl bvl (cdr ibvl))
|
||
(expfsym (gensym) (gensym))
|
||
(expf-bvl) (nbvl))
|
||
((null ibvl)
|
||
`(let ,expf-bvl
|
||
(let ,nbvl ,@body)))
|
||
(desetq (bindform expf-form) (car ibvl))
|
||
(push `(,expfsym (+internal-setf-x-1 ',expf-form)) expf-bvl)
|
||
(cond ((not (and (get (cons () bindform) 'genvals)
|
||
(get (cons () bindform) 'gensyms)))
|
||
(error '|GENVALS and GENSYMS are required information -- EVAL-ONCE|
|
||
bindform)))
|
||
(do ((form bindform (cddr form)))
|
||
((null form))
|
||
(cond ((setq temp
|
||
(cdr (assq (car form)
|
||
'((COMPUTE . SETF-compute)
|
||
(I-COMPUTE . SETF-i-compute)
|
||
(SIDE-EFFECTS . SETF-side-effects)
|
||
(RET-OK . SETF-ret-ok)
|
||
(ACCESS-FUN . SETF-access)
|
||
(ACCESS . SETF-access-expanded)
|
||
(INVERT-FUN . SETF-invert)
|
||
(GENVALS . SETF-genvals)
|
||
(GENSYMS . SETF-gensyms)))))
|
||
(push `(,(cadr form) (,temp ,expfsym)) nbvl))
|
||
(T (error '|Unknown info name -- EVAL-ONCE| (car form)
|
||
'wrng-type-arg))))))
|
||
|
||
#+EVAL-ONCE-TEST
|
||
(defmacro SETF-access-expanded (expf)
|
||
`(apply (setf-access ,expf) (setf-compute ,expf)))
|
||
|
||
|