;;; -*- Mode:Lisp; Package:SI; Lowercase:True; Base:8 -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
"$Header: /usr/lib/lisp/RCS/struct.l,v 1.2 83/08/06 08:41:10 jkf Exp $")
;The master copy of this file is in MC:ALAN;NSTRUCT >
;The current Lisp machine copy is in AI:LISPM2;STRUCT >
;The current Multics copy is in >udd>Mathlab>Bawden>defstruct.lisp
;***** READ THIS PLEASE! *****
;If you are thinking of munging anything in this file you might want
;to consider finding me (ALAN) and asking me to mung it for you.
;There is more than one copy of this file in the world (it runs in PDP10
;and Multics MacLisp and on LispMachines) and whatever amazing
;features you are considering adding might be usefull to those people
;as well. If you still cannot contain yourself long enough to find
;me, AT LEAST send me a piece of mail describing what you did and why.
;Thanks for reading this flame.
; :%P-LDB type (this is hard to do, punt for now.)
; displacement is a problem (no displace)
; nth, nthcdr don't exist there
; ldb, dpb don't exist, so byte fields don't work without Mathlab macros
; callable accessors don't work
; dpb is needed at the user's compile time if he is using byte fields.
#+Franz (environment-maclisp)
(cond ((status feature ITS)
(load '|alan;lspenv init|))
((status feature Multics)
(load '|>udd>Mathlab>Bawden>lspenv.lisp|))))
(cond ((status nofeature noldmsg)
(princ '#.(and (status feature PDP10)
(maknam (nconc (exploden ";Loading DEFSTRUCT ")
(exploden (caddr (truename infile))))))
(declare (genprefix defstruct-internal-)
(eval-when (eval compile)
(setsyntax #/: (ascii #\space) nil))
;; (eval-when (eval compile)
;; (setsyntax #/: 'vseparator)) ; make :'s go away
;;So we may run the thing interpreted we need the simple
;;defstruct that lives here:
(cond ((status feature ITS)
(load '|alan;struct initial|))
((status feature Multics)
(load '|>udd>Mathlab>Bawden>initial_defstruct|))
;;To compile the thing this probably is an old fasl: (!)
(cond ((status feature ITS)
(load '|alan;struct boot|))
((status feature Multics)
(load '|>udd>Mathlab>Bawden>boot_defstruct|))
((status feature Franz) ; This is only needed for bootstrapping
(cond ((and (null (getd 'defstruct))
(concat lisp-library-directory "//struct.o"))))
;;; You might think you could use progn for this, but you can't!
(defun defstruct-dont-displace (x y)
;;; Eval this before attempting incremental compilation
(eval-when (eval compile)
(defmacro append-symbols args
(do ((l (reverse args) (cdr l))
(not (eq (car x) 'quote)))
`(nconc (exploden ,x) ,a))
(let ((l (exploden (cadr x))))
((= 1 (length l)) `(cons ,(car l) ,a))
(t `(append ',l ,a)))))))
(defmacro append-symbols args
`(make_atom (catenate . ,args)))
(defmacro append-symbols args
`(intern (string-append . ,args)))
(defmacro append-symbols (&rest args)
(defmacro defstruct-putprop (sym val ind)
`(push `(defprop ,,sym ,,val ,,ind) returns))
(defmacro defstruct-put-macro (sym fcn)
#M `(defstruct-putprop ,sym ,fcn 'macro)
(setq fcn (if (and (not (atom fcn))
(setq fcn (if (and (not (atom fcn))
`'(macro (macroarg) (,(cadr fcn) macroarg))
`(cons 'macro ,fcn))) ;; probably incorrect
#Q `(push `(fdefine ',,sym ',,fcn t) returns)
#+Franz `(push `(def ,,sym ,,fcn) returns)
(defmacro make-empty () `'%%defstruct-empty%%)
(defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%))
;;;Here we must deal with the fact that error reporting works
;;;differently everywhere!
;;;first arg is ALWAYS a symbol or a quoted symbol:
(defmacro defstruct-error (message &rest args)
(let* ((chars (nconc (exploden (if (atom message)
'(#/.))) ;"Bad frob" => "Bad frob."
(let ((c (car chars))) ;"Bad frob." => "-- bad frob."
(rplaca chars (+ c #o40)))
(append '(#/- #/- #\space) chars))))))
,@(cond ((null args) `())
((null (cdr args)) `(,(car args)))
;;;first arg is ALWAYS a string:
(defmacro defstruct-error (message &rest args)
`(error ,(catenate "defstruct: "
,@(cond ((null args) `())
((null (cdr args)) `(,(car args)))
;;;first arg is ALWAYS a string:
(defmacro defstruct-error (message &rest args)
);End of eval-when (eval compile)
;;;If you mung the the ordering af any of the slots in this structure,
;;;be sure to change the version slot and the definition of the function
;;;get-defstruct-description. Munging the defstruct-slot-description
;;;structure should also cause you to change the version "number" in this manner.
(defstruct (defstruct-description
(:default-pointer description)
(:conc-name defstruct-description-)
(displace 'defstruct-dont-displace)
;;end of "expand-time" slots
(eval-when '(eval compile load))
(callable-accessors #M nil #Q t)
(defun get-defstruct-description (name)
(let ((description (get name 'defstruct-description)))
(cond ((null description)
"A structure with this name has not been defined" name))
((not (eq (defstruct-description-version) 'one))
(defstruct-error "The description of this structure is out of date,
it should be recompiled using the current version of defstruct"
;;;See note above defstruct-description structure before munging this one.
(defstruct (defstruct-slot-description
(:default-pointer slot-description)
(:conc-name defstruct-slot-description-)
;;;Perhaps this structure wants a version slot too?
(defstruct (defstruct-type-description
(:default-pointer type-description)
(:conc-name defstruct-type-description-)
;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>)
;; <options> is of the form (<option> <option> (<option> <val>) ...)
;; <slots> is of the form (<slot> (<slot> <initial-value>) ...)
;; :TYPE defaults to HUNK
;; :CONSTRUCTOR defaults to "MAKE-<name>"
;; :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>")
;; :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-")
;; :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE")
;; :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE")
;; :ALTERANT defaults to "ALTER-<name>"
;; :BUT-FIRST must have a <val> given
;; :INCLUDE must have a <val> given
;; :PROPERTY (:property foo bar) gives the structure a foo property of bar.
;; :INITIAL-OFFSET can cause defstruct to skip over that many slots.
;; :NAMED takes no value. Tries to make the structure a named type.
;; :CALLABLE-ACCESSORS defaults to T on the LispMachine, NIL elsewhere.
;; <type> any type name can be used without a <val> instead of saying (TYPE <type>)
;; <other> any symbol with a non-nil :defstruct-option property. You say
;; (<other> <val>) and the effect is that of (:property <other> <val>)
;; DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description.
;; DEFSTRUCT-NAME each constructor, alterant and size macro has one, it is a name.
;; DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below).
;; DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>)
;; :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as an
;; option giving the structure a FOO property of the value (which must be given).
(defmacro defstruct (options &body items)
(let* ((description (defstruct-parse-options options))
(type-description (get (defstruct-description-type)
'defstruct-type-description))
(name (defstruct-description-name))
(new-slots (defstruct-parse-items items description))
(or (null (defstruct-type-description-defstruct-expander))
(setq returns (append (funcall (defstruct-type-description-defstruct-expander)
#Q (push `(record-source-file-name ',name) returns)
(defstruct-putprop name description 'defstruct-description)
(let ((alterant (defstruct-description-alterant))
(size-macro (defstruct-description-size-macro))
(size-symbol (defstruct-description-size-symbol)))
(defstruct-put-macro alterant 'defstruct-expand-alter-macro)
(defstruct-putprop alterant name 'defstruct-name)))
(defstruct-put-macro size-macro 'defstruct-expand-size-macro)
(defstruct-putprop size-macro name 'defstruct-name)))
(push `(#M defvar #Q defconst #F setq ,size-symbol
,(+ (defstruct-description-size)
(defstruct-type-description-overhead)))
(do cs (defstruct-description-constructors) (cdr cs) (null cs)
(defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro)
(defstruct-putprop (caar cs) name 'defstruct-name))
`(eval-when ,(defstruct-description-eval-when)
,.(defstruct-define-ref-macros new-slots description)
(defun defstruct-parse-options (options)
(let ((name (if (atom options) options (car options)))
(constructors (make-empty))
(description (make-defstruct-description)))
(setf (defstruct-description-name) name)
(options (if (atom options) nil (cdr options))
(if (atom (setq op (car options)))
(setq op (prog1 (car op) (setq vals (cdr op)))))
(setq val (if (null vals) (make-empty) (car vals)))
"The type option to defstruct must have a value given"
(setf (defstruct-description-default-pointer)
(if (emptyp val) name val)))
"The but-first option to defstruct must have a value given"
(setf (defstruct-description-but-first) val))
(setf (defstruct-description-conc-name)
(setf (defstruct-description-callable-accessors)
(if (emptyp val) t val)))
(setf (defstruct-description-displace)
((null val) 'defstruct-dont-displace)
(setq val (append-symbols 'make- name)))
(setq val (cons val (cdr vals)))
(if (emptyp constructors)
(setq constructors (list val))
(push val constructors)))))
(setf (defstruct-description-size-macro)
(append-symbols name '-size)
(setf (defstruct-description-size-symbol)
(append-symbols name '-size)
"The include option to defstruct requires a value"
(setf (defstruct-description-include) vals))
(push (cons (car vals) (if (null (cdr vals)) t (cadr vals)))
(defstruct-description-property-alist)))
"The named option to defstruct doesn't take a value" name))
"The eval-when option to defstruct requires a value"
(setf (defstruct-description-eval-when) val))
"The initial-offset option to defstruct requires a fixnum"
(setf (defstruct-description-initial-offset) val))
(cond ((get op 'defstruct-type-description)
"defstruct type used as an option with a value"
((get op ':defstruct-option)
(push (cons op (if (emptyp val) t val))
(defstruct-description-property-alist)))
#Q (multiple-value-bind (new foundp)
(intern-soft op si:pkg-user-package)
(progn (setq op new) (go AGAIN))))
"defstruct doesn't understand this option"
(cond ((emptyp constructors)
(list (cons (append-symbols 'make- name)
(setf (defstruct-description-constructors) constructors)
(append-symbols 'alter- name))))
(setf (defstruct-description-alterant) alterant)
(or (get type 'defstruct-type-description)
(intern-soft type si:pkg-user-package)
(get type 'defstruct-type-description))))
"Unknown type in defstruct"
(or (defstruct-type-description-named-type)
"There is no way to make this defstruct type named"
(let ((d (get-defstruct-description included)))
(setq type (defstruct-description-type d))
(or (eq type (defstruct-description-type d))
"defstruct types must agree for include option"
included 'included-by name)))
(not (eq type (defstruct-type-description-named-type
(or (get type 'defstruct-type-description)
"Unknown type in defstruct"
type 'in name 'including included)))))
"Included defstruct's type isn't a named type"
included 'included-by name))))
(let ((type-description (or (get type 'defstruct-type-description)
"Undefined defstruct type"
(setf (defstruct-description-type) type)
(setf (defstruct-description-named-p)
(eq (defstruct-type-description-named-type) type)))
(defun defstruct-parse-items (items description)
(let ((name (defstruct-description-name))
(offset (defstruct-description-initial-offset))
(include (defstruct-description-include))
(conc-name (defstruct-description-conc-name)))
(let ((d (get (car include) 'defstruct-description)))
(setq offset (+ offset (defstruct-description-size d)))
(subst nil nil (defstruct-description-slot-alist d)))
(do ((l (cdr include) (cdr l))
(cond ((atom (setq it (car l)))
(let ((slot-description (cdr (assq it o-slot-alist))))
(and (null slot-description)
"Unknown slot in included defstruct"
it 'in include 'included-by name))
(setf (defstruct-slot-description-init-code) val)))))
#+PDP10 (chars (exploden conc-name)))
(setq slot-alist (nreverse slot-alist))
(setf (defstruct-description-size) i)
(setf (defstruct-description-slot-alist)
(nconc o-slot-alist slot-alist))
(push (defstruct-parse-one-field
(car l) i nil nil conc-name #+PDP10 chars)
(push (defstruct-parse-one-field
(caar l) i nil (cdar l) conc-name #+PDP10 chars)
(do ll (car l) (cdr ll) (null ll)
(push (defstruct-parse-one-field
(cddar ll) conc-name #+PDP10 chars)
(defun defstruct-parse-one-field (it number ppss rest conc-name #+PDP10 chars)
(let ((mname (if conc-name #+PDP10 (implode (append chars (exploden it)))
#+Multics (make_atom (catenate conc-name it))
#+Franz (concat conc-name it)
#+LispM (intern (string-append conc-name it))
(cons it (make-defstruct-slot-description
init-code (if (null rest) (make-empty) (car rest))
(defun defstruct-define-ref-macros (new-slots description)
(let ((name (defstruct-description-name))
(if (not (defstruct-description-callable-accessors))
(do ((l new-slots (cdr l))
(setq mname (defstruct-slot-description-ref-macro-name (cdar l)))
(defstruct-put-macro mname 'defstruct-expand-ref-macro)
(defstruct-putprop mname (cons name (caar l)) 'defstruct-slot))
(get (defstruct-description-type)
'defstruct-type-description)))
(let ((code (defstruct-type-description-ref-expander))
(n (defstruct-type-description-ref-no-args))
(but-first (defstruct-description-but-first))
(default-pointer (defstruct-description-default-pointer)))
(do ((args nil (cons (gensym) args))
;;Last arg (if it exists) is name of structure,
;; for documentation purposes.
(setq args (cons name args)))
(let ((body (cons (if but-first
`(,but-first ,(car args))
(setq args `((,(car args) ,default-pointer)
&optional . ,(cdr args))))
(setq args (reverse args))
(setq body (reverse body))
(do ((l new-slots (cdr l))
(setq mname (defstruct-slot-description-ref-macro-name
#M ;;This must come BEFORE the defun. THINK!
(defstruct-put-macro mname 'defstruct-expand-ref-macro)
(let ((ref (lexpr-funcall
(defstruct-slot-description-number (cdar l))
(ppss (defstruct-slot-description-ppss (cdar l))))
(push `(#+(or Franz Maclisp)
defun #Q defsubst ,mname ,args
,(if (null ppss) ref `(ldb ,ppss ,ref)))
(defun defstruct-expand-size-macro (x)
(let ((description (get-defstruct-description (get (car x) 'defstruct-name))))
(let ((type-description (get (defstruct-description-type)
'defstruct-type-description)))
(funcall (defstruct-description-displace)
(+ (defstruct-description-size)
(defstruct-type-description-overhead))))))
(defun defstruct-expand-ref-macro (x)
(let* ((pair (get (car x) 'defstruct-slot))
(description (get-defstruct-description (car pair)))
(get (defstruct-description-type) 'defstruct-type-description))
(code (defstruct-type-description-ref-expander))
(n (defstruct-type-description-ref-no-args))
(default (defstruct-description-default-pointer))
(but-first (defstruct-description-but-first)))
(rplaca args `(,but-first ,(car args)))))
((and (= n (1+ nargs)) default)
(setq args (cons (if but-first
"Wrong number of args to an accessor macro" x)))
(cdr (or (assq (cdr pair)
(defstruct-description-slot-alist))
"This slot no longer exists in this structure"
(cdr pair) 'in (car pair)))))
(defstruct-slot-description-number)
(ppss (defstruct-slot-description-ppss)))
(funcall (defstruct-description-displace)
(defun defstruct-parse-setq-style-slots (l slots others x)
"Bad argument list to constructor or alterant macro" x))
(defstruct-make-init-dsc kludge (car l) (cadr l) slots others x)))
(defun defstruct-make-init-dsc (kludge name code slots others x)
(let ((p (assq name slots)))
(push (cons name code) (cdr kludge))
"Unknown slot to constructor or alterant macro" x))
(let* ((slot-description (cdr p))
(number (defstruct-slot-description-number))
(ppss (defstruct-slot-description-ppss))
(dsc (assoc number (car kludge))))
(setq dsc (list* number nil (make-empty) 0 0 nil))
(push dsc (car kludge))))
(setf (car (cddr dsc)) code)
((and (numberp ppss) (numberp code))
(setf (ldb ppss (cadr (cddr dsc))) -1)
(setf (ldb ppss (caddr (cddr dsc))) code))
(push (cons ppss code) (cdddr (cddr dsc)))))
(push name (cadr dsc)))))))))
(defun defstruct-code-from-dsc (dsc)
(let ((code (car (cddr dsc)))
(bits (caddr (cddr dsc))))
(setq code (if (numberp code)
(boole 7 bits (boole 2 mask code))
(1+ (logior mask (1- mask)))))
(let ((ss (haulong (boole 2 mask (1- mask)))))
`(boole 7 ,bits (boole 2 ,mask ,code)))))))
(do l (cdddr (cddr dsc)) (cdr l) (null l)
(setq code `(dpb ,(cdar l) ,(caar l) ,code)))
(defun defstruct-expand-cons-macro (x)
(let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
(type-description (get (defstruct-description-type)
'defstruct-type-description))
(slot-alist (defstruct-description-slot-alist))
(cons-keywords (defstruct-type-description-cons-keywords))
(cdr (or (assq (car x) (defstruct-description-constructors))
"This constructor is no longer defined for this structure"
(car x) 'in (defstruct-description-name)))))
(if (null constructor-description)
(setq kludge (defstruct-parse-setq-style-slots (cdr x)
(setq kludge (cons nil nil))
(setq l (car constructor-description))
((eq (car l) '&optional) (go O))
((eq (car l) '&rest) (go S))
((eq (car l) '&aux) (go A))
((null args) (go barf-tfa)))
(defstruct-make-init-dsc kludge
O (and (null args) (go OD))
(cond ((null l) (go barf-tma))
((eq (car l) '&optional) (go barf))
((eq (car l) '&rest) (go S))
((eq (car l) '&aux) (go barf-tma)))
(defstruct-make-init-dsc kludge
(if (atom (car l)) (car l) (caar l))
(cond ((null l) (return nil))
((eq (car l) '&optional) (go barf))
((eq (car l) '&rest) (go S))
((eq (car l) '&aux) (go A)))
(defstruct-make-init-dsc kludge
S (and (atom (cdr l)) (go barf))
(defstruct-make-init-dsc kludge
(and (null l) (return nil))
(or (eq (car l) '&aux) (go barf))
(cond ((null l) (return nil))
(push (make-empty) aux-init))
(push (cadar l) aux-init)))
"Bad format for defstruct constructor arglist"
`(,(car x) . ,(car constructor-description)))
barf-tfa (defstruct-error "Too few arguments to constructor macro" x)
barf-tma (defstruct-error "Too many arguments to constructor macro" x)))
(do l slot-alist (cdr l) (null l)
(slot-description (cdar l))
(code (do ((aux aux (cdr aux))
(aux-init aux-init (cdr aux-init)))
((null aux) (defstruct-slot-description-init-code))
(and (eq name (car aux)) (return (car aux-init)))))
(ppss (defstruct-slot-description-ppss)))
(or (and (emptyp code) (null ppss))
(let* ((number (defstruct-slot-description-number))
(dsc (assoc number (car kludge))))
(setq dsc (list* number nil (make-empty) 0 0 nil))
(push dsc (car kludge))))
(and (emptyp (car (cddr dsc)))
(setf (car (cddr dsc)) code)))
((and (numberp ppss) (numberp code))
(setf (ldb ppss (cadr (cddr dsc))) -1)
(setf (ldb ppss (caddr (cddr dsc))) code))
(push (cons ppss code) (cdddr (cddr dsc)))))))))
(selectq (defstruct-type-description-cons-flavor)
(do ((l nil (cons nil l))
(i (defstruct-description-size) (1- i)))
((= i 0) (setq inits l)))
(do l (car kludge) (cdr l) (null l)
(setf (nth (caar l) inits)
(defstruct-code-from-dsc (car l)))))
(setq inits (car kludge))
(do l inits (cdr l) (null l)
(rplacd (car l) (defstruct-code-from-dsc (car l)))))
"Unknown flavor to constructor macro expander"
(defstruct-description-type))))
(funcall (defstruct-description-displace)
x (funcall (defstruct-type-description-cons-expander)
inits description (cdr kludge)))))
(defun defstruct-expand-alter-macro (x)
(let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
(type-description (get (defstruct-description-type)
'defstruct-type-description))
(ref-code (defstruct-type-description-ref-expander)))
(or (= 1 (defstruct-type-description-ref-no-args))
"Alterant macros cannot handle this defstruct type"
(defstruct-description-type)))
(do ((l (car (defstruct-parse-setq-style-slots
(defstruct-description-slot-alist)
(but-first (defstruct-description-but-first))
(funcall (defstruct-description-displace)
`(((lambda ,vars . ,body) . ,vals))))
(let ((ref (funcall ref-code (caar l) description var)))
(and (emptyp (car (cddr (car l))))
(setf (car (cddr (car l))) ref))
(let ((code (defstruct-code-from-dsc (car l))))
(push `(setf ,ref ,code) body)
(push `(setf ,ref ,sym) body)
(defmacro defstruct-define-type (type . options)
(do ((options options (cdr options))
(type-description (make-defstruct-type-description))
(defstruct-expander nil))
(defstruct-error "No cons option in defstruct-define-type" type))
(defstruct-error "No ref option in defstruct-define-type" type))
,@(and defstruct-expander (list defstruct-expander))
(defprop ,type ,type-description defstruct-type-description)))
(cond ((atom (setq op (car options)))
"Bad cons option in defstruct-define-type"
(let ((n (length (car args)))
(name (append-symbols type '-defstruct-cons)))
"Bad cons option in defstruct-define-type"
(setf (defstruct-type-description-cons-flavor)
#+LispM (intern (string (cadr args)) si:pkg-user-package))
(setf (defstruct-type-description-cons-expander) name)
(setq cons-expander `(defun ,name ,(car args)
"Bad ref option in defstruct-define-type"
(let ((n (length (car args)))
(name (append-symbols type '-defstruct-ref)))
"Bad ref option in defstruct-define-type"
(setf (defstruct-type-description-ref-no-args) (- n 2))
(setf (defstruct-type-description-ref-expander) name)
(setq ref-expander `(defun ,name ,(car args)
(setf (defstruct-type-description-overhead)
"Bad option to defstruct-define-type"
(setf (defstruct-type-description-named-type)
(setf (defstruct-type-description-cons-keywords) args))
"Bad defstruct option in defstruct-define-type"
(let ((name (append-symbols type '-defstruct-expand)))
(setf (defstruct-type-description-defstruct-expander) name)
(setq defstruct-expander `(defun ,name . ,args))))
#Q (multiple-value-bind (new foundp)
(intern-soft op si:pkg-user-package)
(progn (setq op new) (go AGAIN))))
"Unknown option to defstruct-define-type"
(car options) 'in type)))))
(defprop :make-array t :defstruct-option)
(defstruct-define-type :array
#Q (:keywords :make-array)
(arg description etc) :alist
#M etc ;ignored in MacLisp
#F etc ;ignored in MacLisp
#Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
description etc nil nil nil 1)
#M (maclisp-array-for-defstruct arg description 't)
#F (maclisp-array-for-defstruct arg description 't))
#M `(arraycall t ,arg ,n)
#F `(arraycall t ,arg ,n)
(defstruct-define-type :named-array
(arg description etc) :alist
(lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i)))
description etc nil t nil 1))
(:ref (n description arg)
(defstruct-define-type :fixnum-array
#Q (:keywords :make-array)
(arg description etc) :alist
#M etc ;ignored in MacLisp
#F etc ;ignored in MacLisp
#Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
description etc 'art-32b nil nil 1)
#M (maclisp-array-for-defstruct arg description 'fixnum)
#F (maclisp-array-for-defstruct arg description 'fixnum))
#M `(arraycall fixnum ,arg ,n)
#F `(arraycall fixnum ,arg ,n)
(defstruct-define-type :flonum-array
#Q (:keywords :make-array)
(arg description etc) :alist
#M etc ;ignored in MacLisp
#F etc ;ignored in MacLisp
#Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
description etc 'art-float nil nil 1)
#M (maclisp-array-for-defstruct arg description 'flonum)
#F (maclisp-array-for-defstruct arg description 'flonum))
#M `(arraycall flonum ,arg ,n)
#F `(arraycall flonum ,arg ,n)
(defstruct-define-type :un-gc-array
(arg description etc) :alist
(maclisp-array-for-defstruct arg description 'nil))
`(arraycall nil ,arg ,n)))
(defstruct-define-type :array-leader
(:named :named-array-leader)
(arg description etc) :alist
(lispm-array-for-defstruct arg #'(lambda (v a i)
`(store-array-leader ,v ,a ,i))
description etc nil nil t 1))
`(array-leader ,arg ,n)))
(defstruct-define-type :named-array-leader
(arg description etc) :alist
(lispm-array-for-defstruct
`(store-array-leader ,v ,a ,(if (zerop i)
description etc nil t t 1))
`(array-leader ,arg ,(1+ n)))))
(defprop :times t :defstruct-option)
(defstruct-define-type :grouped-array
(:keywords :make-array :times)
(arg description etc) :alist
(lispm-array-for-defstruct
#'(lambda (v a i) `(aset ,v ,a ,i))
description etc nil nil nil
(or (cdr (or (assq ':times etc)
(assq ':times (defstruct-description-property-alist))))
(n description index arg)
`(aref ,arg ,(+ n index)))
(t `(aref ,arg (+ ,n ,index))))))
(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times)
(defstruct-grok-make-array-args
(cdr (assq ':make-array (defstruct-description-property-alist)))
(defstruct-grok-make-array-args
(cdr (assq ':make-array etc))
(and type (putprop p type ':type))
(and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol))
(1+ (defstruct-description-size))
(defstruct-description-size))))
(if leader-p ':leader-length ':dimensions))
(let ((type (get p ':type)))
(not (eq (car type) 'quote))
((art-32b art-16b art-8b art-4b art-2b art-1b art-string) (setq no-op '0))
((art-float) (setq no-op '0.0))
(t (setq no-op (make-empty))))))
(let ((dims (remprop p ':dimensions)))
(do l (cdr p) (cddr l) (null l)
`(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p))))
(set-ups nil (if (equal (cdar l) no-op)
(cons (funcall cons-init (cdar l) var (caar l))
(defun defstruct-grok-make-array-args (args p)
(let ((nargs (length args)))
(if (and (not (> nargs 7))
(or (memq (car l) '(:area :type :displaced-to :leader-list
:leader-length :displaced-index-offset
:named-structure-symbol :dimensions
(keylist '(:area :type :dimensions :displaced-to :old-leader-length-or-list
:displaced-index-offset :named-structure-symbol)
(and (boundp 'compiler:compiler-warnings-context)
(boundp 'compiler:last-error-function)
(not (null compiler:compiler-warnings-context))
(compiler:barf args '|-- old style :MAKE-ARRAY constructor keyword argument|
(putprop p (car l) (car keylist)))
(not (memq (car l) '(:area :type :displaced-to :leader-list
:leader-length :displaced-index-offset
:named-structure-symbol :dimensions
"defstruct can't grok these make-array arguments"
(if (eq (car l) ':length)
(defun maclisp-array-for-defstruct (arg description type)
(do ((creator `(array nil ,type ,(defstruct-description-size)))
(set-ups nil (if (equal (cdar l) no-op)
(cons `(store (arraycall ,type ,var ,(caar l))
(defprop :sfa-function t :defstruct-option)
(defprop :sfa-name t :defstruct-option)
(defstruct-define-type :sfa
(:keywords :sfa-function :sfa-name)
(arg description etc) :alist
(do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc)
(assq ':sfa-function (defstruct-description-property-alist))))
`',(defstruct-description-name))
,(defstruct-description-size)
,(or (cdr (or (assq ':sfa-name etc)
(assq ':sfa-name (defstruct-description-property-alist))))
`',(defstruct-description-name))))
(set-ups nil (if (null (cdar l))
(cons `(sfa-store ,var ,(caar l)
(defstruct-define-type :hunk
(arg description etc) :list
#+PDP-10 `(hunk . ,(nconc (cdr arg) (ncons (car arg))))
(defstruct-error "No slots in hunk type defstruct")))
(defstruct-define-type :named-hunk
(arg description etc) :list
#+PDP-10 `(hunk ',(defstruct-description-name)
. ,(nconc (cdr arg) (ncons (car arg))))
#+Franz `(hunk ',(defstruct-description-name)
`(hunk ',(defstruct-description-name) nil)))
(cond #+PDP-10 ((= n 0) `(cxr 0 ,arg))
(t `(cxr ,(1+ n) ,arg)))))
(defstruct-define-type :vector
(arg description etc) :list
(defstruct-define-type :named-vector
(arg description etc) :list
`(let ((nv (vector ,@arg)))
(vsetprop nv ',(defstruct-description-name))
(defstruct-define-type :list
(arg description etc) :list
#+Multics `(,(let ((i (\ n 4)))
,(do ((a arg `(cddddr ,a))
#-Multics `(nth ,n ,arg)))
(defstruct-define-type :named-list
(arg description etc) :list
`(list ',(defstruct-description-name) . ,arg))
#+Multics `(,(let ((i (\ (1+ n) 4)))
,(do ((a arg `(cddddr ,a))
(i (// (1+ n) 4) (1- i)))
#-Multics `(nth ,(1+ n) ,arg)))
(defstruct-define-type :list*
(arg description etc) :list
(let ((size (1- (defstruct-description-size))))
#+Multics (do ((a arg `(cddddr ,a))
(if (< n size) `(car ,a) a))))
(:defstruct (description)
(and (defstruct-description-include)
"Structure of type list* cannot include another"
(defstruct-description-name)))
(defstruct-define-type :tree
(arg description etc) :list
(if (null arg) (defstruct-error
"defstruct cannot make an empty tree"
(defstruct-description-name)))
(make-tree-for-defstruct arg (defstruct-description-size)))
(do ((size (defstruct-description-size))
(cond ((= size 1) (return a))
((< n (setq tem (// size 2)))
(:defstruct (description)
(and (defstruct-description-include)
"Structure of type tree cannot include another"
(defstruct-description-name)))
(defun make-tree-for-defstruct (arg size)
(cond ((= size 1) (car arg))
((= size 2) `(cons ,(car arg) ,(cadr arg)))
(t (do ((a (cdr arg) (cdr a))
(n (1- (// size 2)) (1- n)))
`(cons ,(make-tree-for-defstruct arg m)
,(make-tree-for-defstruct a (- size m))))))))
(defstruct-define-type :fixnum
(arg description etc) :list
"Structure of type fixnum must have exactly 1 slot to be constructable"
(defstruct-description-name)))
(defprop :external-ptr t :defstruct-option)
(defstruct-define-type :external
(:keywords :external-ptr)
(:cons (arg description etc) :alist
(let ((ptr (cdr (or (assq ':external-ptr etc)
(defstruct-description-property-alist))
"No pointer given for external array"
(defstruct-description-name))))))
(do ((creator `(array nil external ,ptr ,(defstruct-description-size)))
(inits nil (cons `(store (arraycall fixnum ,var ,(caar alist))
`((lambda (,var) ,.inits ,var)
(:ref (n description arg)
`(arraycall fixnum ,arg ,n)))
(defvar *defstruct-examine&deposit-arg*)
(defun defstruct-examine (*defstruct-examine&deposit-arg*
(eval (list (defstruct-slot-description-ref-macro-name
(defstruct-examine&deposit-find-slot-description
'*defstruct-examine&deposit-arg*)))
(defvar *defstruct-examine&deposit-val*)
(defun defstruct-deposit (*defstruct-examine&deposit-val*
*defstruct-examine&deposit-arg*
(list (defstruct-slot-description-ref-macro-name
(defstruct-examine&deposit-find-slot-description
'*defstruct-examine&deposit-arg*)
'*defstruct-examine&deposit-val*)))
(defun defstruct-get-locative (*defstruct-examine&deposit-arg*
(let ((slot-description (defstruct-examine&deposit-find-slot-description
(or (null (defstruct-slot-description-ppss))
"You cannot get a locative to a byte field"
(list (defstruct-slot-description-ref-macro-name)
'*defstruct-examine&deposit-arg*)))))
(defun defstruct-examine&deposit-find-slot-description (name slot-name)
(let ((description (get-defstruct-description name)))
(cdr (or (assq slot-name (defstruct-description-slot-alist))
"No such slot in this structure"
(or (get (defstruct-description-type) 'defstruct-type-description)
"Undefined defstruct type"
(defstruct-description-type)))))
(or (= (defstruct-type-description-ref-no-args) 1)
"defstruct-examine and defstruct-deposit cannot handle structures of this type"
(defstruct-description-type)))
#.(and (status feature PDP10)
(caddr (truename infile)))
(sstatus feature defstruct)