1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2; 3; File: PU:STRUCT.INITIAL 4; Description: File included in NSTRUCT 5; Author: 6; Created: 7; Modified: 28-Aug-84 09:01:01 (Brian Beach) 8; Status: Experimental (Do Not Distribute) 9; Mode: Lisp 10; Package: Utilities 11; Compile to: none 12; 13; (c) Copyright 1983, Hewlett-Packard Company, see the file 14; HP_disclaimer at the root of the PSL file tree 15; 16; This file is included in PU:NSTRUCT.LSP 17; 18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19; 20; Revisions: 21; 22; 19 Jan 1984 1450-PST (Brian Beach) 23; Added standard header. 24; 25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 27(defmacro defstruct ((name . opts) . slots) 28 (let ((dp (cadr (assq 'default-pointer opts))) 29 (conc-name (cadr (assq 'conc-name opts))) 30 (cons-name (implode (append '(m a k e -) (explodec name))))) 31; #Q (fset-carefully cons-name '(macro . initial_defstruct-cons)) 32; #M (putprop cons-name 'initial_defstruct-cons 'macro) 33; PSL change 34 (putd cons-name 'macro (cdr (getd 'initial_defstruct-cons))) 35; PSL change 1+ ==> add1 36 (do ((i 0 (add1 i)) 37 (l slots (cdr l)) 38 (foo nil (cons (list slot init) foo)) 39 (chars (explodec conc-name)) 40 (slot) (acsor) (init)) 41 ((null l) 42 (putprop cons-name foo 'initial_defstruct-inits) 43 `',name) 44 (cond ((atom (car l)) 45 (setq slot (car l)) 46 (setq init nil)) 47 (t (setq slot (caar l)) 48 (setq init (cadar l)))) 49 (setq acsor (implode (append chars (explodec slot)))) 50 (putprop acsor dp 'initial_defstruct-dp) 51; #Q (fset-carefully acsor '(macro . initial_defstruct-ref)) 52; #M (putprop acsor 'initial_defstruct-ref 'macro) 53; PSL change 54 (putd acsor 'macro (cdr (getd 'initial_defstruct-ref))) 55 (putprop acsor i 'initial_defstruct-i)))) 56 57(defun initial_defstruct-ref (form) 58 (let ((i (get (car form) 'initial_defstruct-i)) 59 (p (if (null (cdr form)) 60 (get (car form) 'initial_defstruct-dp) 61 (cadr form)))) 62; PSL change incompatible NTH 63 #-Multics `(nth ,p ,(add1 i)) 64; #-Multics `(nth ,i ,p) 65 #+Multics `(car ,(do ((i i (1- i)) 66 (x p `(cdr ,x))) 67 ((zerop i) x))) 68 )) 69 70(defun initial_defstruct-cons (form) 71 (do ((inits (get (car form) 'initial_defstruct-inits) 72 (cdr inits)) 73 (gen (gensym)) 74 (x nil (cons (or (get form (caar inits)) 75 (cadar inits)) 76 x))) 77 ((null inits) 78 `(list . ,x)))) 79