![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to symord.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl|
Return to symord.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
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.