Return to symord.l CVS log

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

Annotation of 42BSD/ucb/lisp/pearl/symord.l, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; symord.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ; Functions for defining symbols and ordinal types.
        !             3: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             4: ; Copyright (c) 1983 ,  The Regents of the University of California.
        !             5: ; All rights reserved.  
        !             6: ; Authors: Joseph Faletti and Michael Deering.
        !             7: 
        !             8: ; Define one SYMBOL in a hunk for easy identification.
        !             9: ;   This will not work independently (for some reason).
        !            10: (dm onesymbol (none)
        !            11:   '(funl (symname)
        !            12:         (or (and (not (litatom symname))
        !            13:                  (not (msg t "SYMBOL: Symbols can only be simple names, not:"
        !            14:                            symname t)))
        !            15:             (and (eq symname 'nilsym)
        !            16:                  (boundp (symatom 'nilsym))
        !            17:                  (not (msg t "SYMBOL: Cannot redefine nilsym." t)))
        !            18:             (and (null symname)
        !            19:                  (not (msg t "SYMBOL: Cannot name a symbol nil." t)))
        !            20:             (and (symbolnamep symname)
        !            21:                  ; but okay to do.
        !            22:                  (and *warn*
        !            23:                       (msg t "SYMBOL: Warning: Redefining symbol: "
        !            24:                            symname t)))
        !            25:             (let ((block (set (symatom symname) (makhunk 3))))
        !            26:                  (putuniquenum (newnum) block)
        !            27:                  (puttypetag '*pearlsymbol* block)
        !            28:                  (putsymbolpname symname block)
        !            29:                  block))))
        !            30:  
        !            31: ; Define a bunch of SYMBOLS.
        !            32: (df symbol (l)
        !            33:   (mapcar (onesymbol) l))
        !            34: 
        !            35: ; An EXPR which allows the defining of one SYMBOL.
        !            36: (de symbole (symname)
        !            37:   (cond ((not (litatom symname))
        !            38:         (msg t "SYMBOLE: symbols can only be simple names, not: "
        !            39:              symname t)
        !            40:         (pearlbreak))
        !            41:        (  t  (apply* (onesymbol) (ncons symname)) symname)))
        !            42:  
        !            43: (de getsymbol (symname)
        !            44:   (cond ((symbolnamep symname)
        !            45:         (eval (symatom symname)))
        !            46:        (  t  (msg t "GETSYMBOL: " symname " is not the name of a symbol." t)
        !            47:              (pearlbreak))))
        !            48:  
        !            49: ; (ordinal name (x y z)) or  (ordinal name (x 1 y 3 z 8)).
        !            50: ; Define a set of integer constants for readability in input and output.
        !            51: ; Also define o:name, name:max and name:min, and name:x, name:y and name:z.
        !            52: (df ordinal (l)
        !            53:   (let ((ordinalname (car l))
        !            54:        (ordinalelements (cadr l))
        !            55:        (alist (ncons nil))
        !            56:        (count 0)
        !            57:        (min 0)
        !            58:        max
        !            59:        name
        !            60:        value)
        !            61:        (push ordinalname *ordinalnames*)
        !            62:        (set (ordatom ordinalname)
        !            63:            (cond ((not (numberp (cadr ordinalelements)))
        !            64:                   ; generate numbers.
        !            65:                   (while ordinalelements
        !            66:                          (setq count (1+ count))
        !            67:                          (tconc alist (cons (setq name (pop ordinalelements))
        !            68:                                             count))
        !            69:                          (set (concat ordinalname ":" name) count))
        !            70:                   (or (\=& 0 count)
        !            71:                       (setq min 1))
        !            72:                   (setq max count)
        !            73:                   (car alist))
        !            74:                  ; use numbers provided by user.
        !            75:                  ( t (setq min (setq max (cadr ordinalelements)))
        !            76:                      (while ordinalelements
        !            77:                             (tconc alist
        !            78:                                    (cons (setq name (pop ordinalelements))
        !            79:                                          (setq value (pop ordinalelements))))
        !            80:                             (set (concat ordinalname ":" name) value)
        !            81:                             (and (<& value min)
        !            82:                                  (setq min value))
        !            83:                             (and (>& value max)
        !            84:                                  (setq max value)))
        !            85:                      (car alist))))
        !            86:        (set (concat ordinalname ":min") min)
        !            87:        (set (concat ordinalname ":max") max)
        !            88:        (cons ordinalname (car alist))))
        !            89:  
        !            90: 
        !            91: ; vi: set lisp:

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