usr/src/old/lisp/pearl/symord.l

;;;;;;;;;;;;;;;;;;;;;;;;;;;;; symord.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for defining symbols and ordinal types.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 ,  The Regents of the University of California.
; All rights reserved.
; Authors: Joseph Faletti and Michael Deering.

; Define one SYMBOL in a hunk for easy identification.
;   This will not work independently (for some reason).
(dm onesymbol (none)
  '(funl (symname)
         (or (and (not (litatom symname))
                  (not (msg t "SYMBOL: Symbols can only be simple names, not:"
                            symname t)))
             (and (eq symname 'nilsym)
                  (boundp (symatom 'nilsym))
                  (not (msg t "SYMBOL: Cannot redefine nilsym." t)))
             (and (null symname)
                  (not (msg t "SYMBOL: Cannot name a symbol nil." t)))
             (and (symbolnamep symname)
                  ; but okay to do.
                  (and *warn*
                       (msg t "SYMBOL: Warning: Redefining symbol: "
                            symname t)))
             (let ((block (set (symatom symname) (makhunk 3))))
                  (putuniquenum (newnum) block)
                  (puttypetag '*pearlsymbol* block)
                  (putsymbolpname symname block)
                  block))))

; Define a bunch of SYMBOLS.
(df symbol (l)
  (mapcar (onesymbol) l))

; An EXPR which allows the defining of one SYMBOL.
(de symbole (symname)
  (cond ((not (litatom symname))
         (msg t "SYMBOLE: symbols can only be simple names, not: "
              symname t)
         (pearlbreak))
        (  t  (apply* (onesymbol) (ncons symname)) symname)))

(de getsymbol (symname)
  (cond ((symbolnamep symname)
         (eval (symatom symname)))
        (  t  (msg t "GETSYMBOL: " symname " is not the name of a symbol." t)
              (pearlbreak))))

; (ordinal name (x y z)) or  (ordinal name (x 1 y 3 z 8)).
; Define a set of integer constants for readability in input and output.
; Also define o:name, name:max and name:min, and name:x, name:y and name:z.
(df ordinal (l)
  (let ((ordinalname (car l))
        (ordinalelements (cadr l))
        (alist (ncons nil))
        (count 0)
        (min 0)
        max
        name
        value)
       (push ordinalname *ordinalnames*)
       (set (ordatom ordinalname)
            (cond ((not (numberp (cadr ordinalelements)))
                   ; generate numbers.
                   (while ordinalelements
                          (setq count (1+ count))
                          (tconc alist (cons (setq name (pop ordinalelements))
                                             count))
                          (set (concat ordinalname ":" name) count))
                   (or (\=& 0 count)
                       (setq min 1))
                   (setq max count)
                   (car alist))
                  ; use numbers provided by user.
                  ( t (setq min (setq max (cadr ordinalelements)))
                      (while ordinalelements
                             (tconc alist
                                    (cons (setq name (pop ordinalelements))
                                          (setq value (pop ordinalelements))))
                             (set (concat ordinalname ":" name) value)
                             (and (<& value min)
                                  (setq min value))
                             (and (>& value max)
                                  (setq max value)))
                      (car alist))))
       (set (concat ordinalname ":min") min)
       (set (concat ordinalname ":max") max)
       (cons ordinalname (car alist))))


; vi: set lisp: