;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 121.28 ;;; Reason: ;;; Fix Common Lisp ``named'' vector DEFSTRUCTs. ;;; LISPM-ARRAY-FOR-DEFSTRUCT needs to be put out to pasture... ;;; Written 11-Feb-87 16:11:38 by RpK (Robert P. Krajewski) at site LMI Cambridge ;;; while running on Cthulhu from band 3 ;;; with Experimental System 121.27, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental Site Data Editor 5.0, Experimental K Bridge Support 1.0, microcode 1733, SDU Boot Tape 3.12, SDU ROM 102, the old ones. ; From modified file DJ: L.SYS2; STRUCT.LISP#334 at 11-Feb-87 16:11:39 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " #+LISPM (DEFUN SIMPLER-VECTOR-CONS-FOR-DEFSTRUCT (ARG DESCRIPTION EXTRA-CODE) (LET* ((OVERHEAD (DEFSTRUCT-TYPE-DESCRIPTION-OVERHEAD (GET (DEFSTRUCT-DESCRIPTION-TYPE) 'DEFSTRUCT-TYPE-DESCRIPTION))) (SIZE (+ (DEFSTRUCT-DESCRIPTION-SIZE) OVERHEAD)) (SET-UPS '()) (VECTOR (GENSYM))) (DOLIST (ELT ARG) (LET ((INITVALUE (cdr ELT))) (UNLESS (EQ INITVALUE NIL) (PUSH `(ASET ,(CDR ELT) ,VECTOR ,(+ OVERHEAD (CAR ELT))) SET-UPS)))) (LET ((MAKE-ARRAY `(MAKE-ARRAY ,SIZE))) (IF (OR EXTRA-CODE SET-UPS) `((LAMBDA (,VECTOR) ,@(NREVERSE SET-UPS) ,(AND EXTRA-CODE (FUNCALL EXTRA-CODE VECTOR)) ,VECTOR) ,MAKE-ARRAY) MAKE-ARRAY)))) #+LISPM (DEFSTRUCT-DEFINE-TYPE :PHONY-NAMED-VECTOR (:CONS-KEYWORDS :MAKE-ARRAY :SUBTYPE) (:OVERHEAD 1) (:DEFSTRUCT-KEYWORDS :MAKE-ARRAY :SUBTYPE) (:DEFSTRUCT (DESCRIPTION) (DEFSTRUCT-HACK-ARRAY-SUPERTYPE DESCRIPTION)) (:CONS (ARG DESCRIPTION ETC) :ALIST ETC (SIMPLER-VECTOR-CONS-FOR-DEFSTRUCT ARG DESCRIPTION #'(LAMBDA (V) `(SETF (AREF ,V 0) ',(DEFSTRUCT-DESCRIPTION-NAME))))) (:REF (N DESCRIPTION ARG) `(,(SELECT-AREF-FORM DESCRIPTION) ,ARG ,(+ N 1))) (:PREDICATE (DESCRIPTION NAME) `(DEFSUBST ,NAME (X) (AND (VECTORP X) (NOT (ZEROP (ARRAY-LENGTH X) 0)) (EQ (AREF X 0) ',(DEFSTRUCT-DESCRIPTION-NAME)))))) )) ; From modified file DJ: L.SYS2; STRUCT.LISP#334 at 11-Feb-87 16:14:35 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " #+LISPM (DEFUN IMPLICIT-ARRAY-ELEMENT-VALUE (ARRAY-TYPE MAKE-ARRAY-ARGUMENTS) (IF (OR (GET MAKE-ARRAY-ARGUMENTS :INITIAL-ELEMENT) (GET MAKE-ARRAY-ARGUMENTS :INITIAL-VALUE)) (DEFSTRUCT-MAKE-EMPTY) (CASE ARRAY-TYPE ((NIL ART-Q ART-Q-LIST) NIL) ((ART-32B ART-16B ART-8B ART-4B ART-2B ART-1B ART-HALF-FIX ART-STRING ART-FAT-STRING) 0) ((ART-FLOAT ART-FPS-FLOAT) 0.0) (ART-COMPLEX 0+0i) ((ART-COMPLEX-FLOAT ART-COMPLEX-FPS-FLOAT) 0.0+0.0i) (T (DEFSTRUCT-MAKE-EMPTY))))) ;;; this is starting too get too hairy to want to evaluate every time we cons up a structure. ;;; more knowledge should be built into the constructors themselves, for simple cases #+LispM (defun lispm-array-for-defstruct (arg cons-init description etc type &OPTIONAL (NAMED-P NIL) (LEADER-P NIL) (TIMES 1) (TYPE-IN-LEADER NIL) &AUX (P (CONS NIL NIL)) NO-OP ARRAY-TYPE) ;; arg is slot arg ;; cons-init is code to initialize the structure per-slot ;; description is a structure description ;; etc is cons-keyword args/values ;; type is the array-type to make ;; named-p is t if to make a named structure ;; leader-p is t if the data is to be stored in the leader (as in :{named-}array-leader) ;; times if the #times for :grouped-array ;; type-in-leader is t if the structure-type is to be put in array-leader 1 rather than ;; in aref 0 (defstruct-grok-make-array-args (cdr (assq ':make-array (defstruct-description-property-alist))) p) (defstruct-grok-make-array-args (cdr (assq ':make-array etc)) p) (COND (TYPE (PUTPROP P TYPE ':TYPE)) ((SETQ TYPE (CDR (ASSQ ':SUBTYPE ETC))) (PUTPROP P `',(SETQ TYPE (OR (IGNORE-ERRORS (ARRAY-CANONICALIZE-TYPE TYPE)) TYPE)) ':TYPE)) ((SETQ TYPE (DEFSTRUCT-DESCRIPTION-SUBTYPE)) (PUTPROP P `',(SETQ TYPE (OR (IGNORE-ERRORS (ARRAY-CANONICALIZE-TYPE TYPE)) TYPE)) ':TYPE))) (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol)) (LET* ((S (OR (GET P (IF LEADER-P ':LEADER-LENGTH ':DIMENSIONS)) 0)) (SIZE (let ((size (if named-p (1+ (defstruct-description-size)) (defstruct-description-size)))) (if (numberp times) (MAX S (* size times)) `(MAX ,S (* ,size ,times)))))) (putprop p SIZE (if leader-p ':leader-length ':dimensions))) (AND TYPE-IN-LEADER (OR (NOT (GET P ':LEADER-LENGTH)) (< (GET P ':LEADER-LENGTH) 2)) (PUTPROP P 2 ':LEADER-LENGTH)) (SETQ ARRAY-TYPE (OR (LET ((TYPE (GET P ':TYPE))) (IF (EQ (CAR-SAFE TYPE) 'QUOTE) (SETQ TYPE (CADR TYPE))) (OR (IGNORE-ERRORS (ARRAY-CANONICALIZE-TYPE TYPE)) TYPE)) 'ART-Q)) (UNLESS LEADER-P (SETQ NO-OP (IMPLICIT-ARRAY-ELEMENT-VALUE ARRAY-TYPE P))) ;; make sure that we can store the named-structure-symbol safely (OR (NOT NAMED-P) (MEMQ ARRAY-TYPE '(ART-Q ART-Q-LIST ART-SPECIAL-PDL ART-REG-PDL ART-STACK-GROUP-HEAD)) (GET P ':LEADER-LENGTH) (SETQ ARRAY-TYPE 'ART-Q) (PUTPROP P 'ART-Q ':TYPE)) (do ((creator (let ((dims (remprop p ':dimensions))) (do ((l (cdr p) (cddr l))) ((null l)) (rplaca l `',(car l))) `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p)))) (var (gensym)) (set-ups nil (if (equal (cdar l) no-op) set-ups (PUSH (funcall cons-init (cdar l) var (caar l)) SET-UPS))) (l arg (cdr l))) ((null l) ;; If we want the structure type stored but not a named-structure, ;; generate code to store it explicitly. (IF (AND TYPE-IN-LEADER (NOT NAMED-P)) (PUSH `(SETF (ARRAY-LEADER ,VAR 1) ',(DEFSTRUCT-DESCRIPTION-NAME)) SET-UPS)) (if set-ups `((lambda (,var) ,@(nreverse set-ups) ,var) ,creator) creator)))) ))