Return to structini.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/structini.l, revision 1.1.1.1

1.1       root        1: ;;;-*-lisp-*-
                      2: (setq rcs-strictini-
                      3:    "$Header: /usr/lib/lisp/structini.l,v 1.1 83/01/29 18:40:11 jkf Exp $")
                      4: 
                      5: #+franz
                      6: (declare (macros t))
                      7: 
                      8: (defmacro defstruct ((name . opts) . slots)
                      9:   (let ((dp (cadr (assq ':default-pointer opts)))
                     10:        (conc-name (cadr (assq ':conc-name opts)))
                     11:        (cons-name (implode (append '(m a k e -) (explodec name)))))
                     12:     #Q (fset-carefully cons-name '(macro . initial_defstruct-cons))
                     13:     #M (putprop cons-name 'initial_defstruct-cons 'macro)
                     14:     #F (putd cons-name '(macro (x) (initial_defstruct-cons x)))
                     15:     (do ((i 0 (1+ i))
                     16:         (l slots (cdr l))
                     17:         (foo nil (cons (list slot init) foo))
                     18:         (chars (explodec conc-name))
                     19:         (slot) (acsor) (init))
                     20:        ((null l)
                     21:         (putprop cons-name foo 'initial_defstruct-inits)
                     22:         `',name)
                     23:       (cond ((atom (car l))
                     24:             (setq slot (car l))
                     25:             (setq init nil))
                     26:            (t (setq slot (caar l))
                     27:               (setq init (cadar l))))
                     28:       (setq acsor (implode (append chars (explodec slot))))
                     29:       (putprop acsor dp 'initial_defstruct-dp)
                     30:       #Q (fset-carefully acsor '(macro . initial_defstruct-ref))
                     31:       #M (putprop acsor 'initial_defstruct-ref 'macro)
                     32:       #F (putd acsor '(macro (x) (initial_defstruct-ref x)))
                     33:       (putprop acsor i 'initial_defstruct-i))))
                     34: 
                     35: (defun initial_defstruct-ref (form)
                     36:   (let ((i (get (car form) 'initial_defstruct-i))
                     37:        (p (if (null (cdr form))
                     38:               (get (car form) 'initial_defstruct-dp)
                     39:               (cadr form))))
                     40:     #-Multics `(nth ,i ,p)
                     41:     #+Multics `(car ,(do ((i i (1- i))
                     42:                          (x p `(cdr ,x)))
                     43:                         ((zerop i) x)))
                     44:     ))
                     45: 
                     46: (defun initial_defstruct-cons (form)
                     47:   (do ((inits (get (car form) 'initial_defstruct-inits)
                     48:              (cdr inits))
                     49:        (gen (gensym))
                     50:        (x nil (cons (or (get form (caar inits))
                     51:                        (cadar inits))
                     52:                    x)))
                     53:       ((null inits)
                     54:        `(list . ,x))))
                     55: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.