Return to structini.l CVS log

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

Annotation of 43BSD/ucb/lisp/lisplib/structini.l, revision 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.