![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to common0.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to common0.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-common0-
2: "$Header: common0.l,v 1.4 83/12/15 11:09:34 jkf Exp $")
3:
4: ;;
5: ;; common0.l -[Mon Nov 21 14:06:20 1983 by jkf]-
6: ;;
7: ;; Functions which are required to execute the low level lisp macros
8: ;; and functions.
9: ;;
10: ;; This is the first file of functions read in when building a lisp.
11: ;; If this lisp is to run interpretedly, then we must not use anything
12: ;; which hasn't be defined in the C lisp kernel, except ';' which is
13: ;; defined as the comment character before reading this file.
14: ;; We cannot use defmacro, the backquote or the # macro.
15: ;;
16: ;; This file should be as short as possible since it must be written in
17: ;; a rather primitive way.
18: ;;
19:
20: ;--- declare : ignore whatever is given, this info is for the compiler
21: ;
22: (def declare (nlambda (x) nil))
23:
24: (declare (macros t))
25:
26: ;--- memq - arg : (probably a symbol)
27: ; - lis : list
28: ; returns part of lis beginning with arg if arg is in lis
29: ;
30: (def memq
31: (lambda ($a$ $l$)
32: (do ((ll $l$ (cdr ll)))
33: ((null ll) nil)
34: (cond ((eq $a$ (car ll)) (return ll))))))
35:
36: ;--- def :: define a function
37: ; This superceeds franz's definition.
38: ; It does more error checking and it does lambda conversion
39: ;
40: (def def
41: (nlambda (l)
42: ((lambda (name argl)
43: (cond ((and (symbolp (setq name (car l)))
44: (dtpr (cadr l))
45: (null (cddr l))
46: (memq (caadr l) '(lambda nlambda lexpr macro glambda)))
47: ; make sure lambda list is nil or a dtpr
48: (setq l (cadr l)) ; l points to (lambda (argl) ...)
49: (cond ((null (setq argl (cadr l)))) ; nil check
50: ((dtpr (cadr l)) ; dtpr
51: (cond ((and (eq (car l) 'lambda)
52: (or (memq '&aux argl)
53: (memq '&optional argl)
54: (memq '&rest argl)
55: (memq '&body argl)))
56: ; must lambda convert
57: (setq l (lambdacvt (cdr l))))))
58: (t (error "def: bad lambda list of form in " l)))
59: (putd name l)
60: name)
61: (t (error "def: bad form " l))))
62: nil nil)))
63:
64:
65: ;--- defun
66: ; maclisp style function defintion
67: ;
68: (def defun
69: (macro (l)
70: (prog (name type arglist body specind specnam)
71: (setq name (cadr l) l (cddr l))
72: (cond ((dtpr name)
73: (cond ((memq (cadr name) '(macro expr fexpr lexpr))
74: (setq l (cons (cadr name) l)
75: name (car name)))
76: (t (setq specnam (car name)
77: specind (cadr name)
78: name (concat (gensym) "::" specnam))))))
79: (cond ((null (car l)) (setq type 'lambda))
80: ((eq 'fexpr (car l)) (setq type 'nlambda l (cdr l)))
81: ((eq 'expr (car l)) (setq type 'lambda l (cdr l)))
82: ((eq 'macro (car l)) (setq type 'macro l (cdr l)))
83: ((atom (car l))
84: (setq type 'lexpr
85: l (nconc (list (list (car l)))
86: (cdr l))))
87: (t (setq type 'lambda)))
88: (setq body (list 'def name (cons type l)))
89: (cond (specnam
90: (return (list 'progn ''compile
91: body
92: (list 'putprop
93: (list 'quote specnam)
94: (list 'getd
95: (list 'quote name))
96: (list 'quote specind)))))
97: (t (return body))))))
98:
99:
100: ;--- error : print error message and cause an error
101: ; call is usually (error "string" value)
102: ;
103: (def error
104: ;; form: (error arg1 ...)
105: ;; concat all args together, with spaces between them
106: ;; and cause an error to be signaled
107: (lexpr (n)
108: (do ((i n (1- i))
109: (mesg ""))
110: ((eq i 0) (err-with-message mesg))
111: (setq mesg (concat
112: (cond ((atom (arg i)) (arg i))
113: ((lessp (maknum (arg i)) (maknum nil))
114: ; this tests for the <UNBOUND> value
115: '<UNBOUND>)
116: (t (implode (exploden (arg i)))))
117: " " mesg)))))
118:
119: (def err
120: ;; (err value [junk])
121: ;; This is here for maclisp compatibility. junk should be nil,
122: ;; but we don't verify.
123: ;; The value is both to be printed and to be returned from the
124: ;; errset. 'err-with-message' should be used for new code
125: (lexpr (n)
126: (cond ((eq n 0)
127: (err-with-message "call to err"))
128: ((or (eq n 1) (eq n 2))
129: (err-with-message (arg 1) (arg 1)))
130: (t (error "wrong number of args to err:" n)))))
131:
132:
133: ;--- append : append two or more lists
134: ; the result will be a copy of all but the last list
135: ;
136: (declare (localf append2args))
137:
138: (def append
139: (lexpr (nargs)
140: (cond ((eq nargs 2) (append2args (arg 1) (arg 2)))
141: ((zerop nargs) nil)
142: (t (do ((i (1- nargs) (1- i))
143: (res (arg nargs)))
144: ((zerop i) res)
145: (setq res (append2args (arg i) res)))))))
146:
147: ;--- append2args : append just two args
148: ; a version of append which only works on 2 arguments
149: ;
150: (def append2args
151: (lambda (x y)
152: (prog (l l*)
153: (cond ((null x) (return y))
154: ((atom x) (error "Non-list to append:" x)))
155: (setq l* (setq l (cons (car x) nil)))
156: loop (cond ((atom x) (error "Non-list to append:" x))
157: ((setq x (cdr x))
158: (setq l* (cdr (rplacd l* (cons (car x) nil))))
159: (go loop)))
160: (rplacd l* y)
161: (return l))))
162:
163: ;--- append1 : add object to end of list
164: ; adds element y to then end of a copy of list x
165: ;
166: (def append1 (lambda (x y) (append x (list y))))
167:
168: ;--- assoc - x : lispval
169: ; - l : list
170: ; l is a list of lists. The list is examined and the first
171: ; sublist whose car equals x is returned.
172: ;
173: (def assoc
174: (lambda (val alist)
175: (do ((al alist (cdr al)))
176: ((null al) nil)
177: (cond ((null (car al)))
178: ((not (dtpr (car al)))
179: (error "bad arg to assoc" al))
180: ((equal val (caar al)) (return (car al)))))))
181:
182: ;--- rassq : like assq but look at the cdr instead of the car
183: ;
184: (def rassq
185: (lambda (form list)
186: (cond ((null list) nil)
187: ((not (dtpr list))
188: (error "rassq: illegal second argument: " list))
189: (t (do ((ll list (cdr ll)))
190: ((null ll) nil)
191: (cond ((eq form (cdar ll)) (return (car ll)))))))))
192: ;--- concatl - l : list of atoms
193: ; returns the list of atoms concatentated
194: ;
195: (def concatl
196: (lambda (x) (apply 'concat x)))
197:
198: ;--- length - l : list
199: ; returns the number of elements in the list.
200: ;
201: (def length
202: (lambda ($l$)
203: (cond ((and $l$ (not (dtpr $l$)))
204: (error "length: non list argument: " $l$))
205: (t (cond ((null $l$) 0)
206: (t (do ((ll (cdr $l$) (cdr ll))
207: (i 1 (1+ i)))
208: ((null ll) i))))))))
209:
210: ;--- memq - arg : (probably a symbol)
211: ; - lis : list
212: ; returns part of lis beginning with arg if arg is in lis
213: ;
214: (def memq
215: (lambda ($a$ $l$)
216: (do ((ll $l$ (cdr ll)))
217: ((null ll) nil)
218: (cond ((eq $a$ (car ll)) (return ll))))))
219:
220: ;--- nconc - x1 x2 ...: lists
221: ; The cdr of the last cons cell of xi is set to xi+1. This is the
222: ; structure modification version of append
223: ;
224:
225: (def nconc
226: (lexpr (nargs)
227: (cond ((eq nargs '2)
228: (cond ((null (arg 1)) (arg 2))
229: (t (do ((tmp (arg 1) (cdr tmp)))
230: ((null (cdr tmp))
231: (rplacd tmp (arg 2))
232: (arg 1))))))
233: ((zerop nargs) nil)
234: (t (do ((i 1 nxt)
235: (nxt 2 (1+ nxt))
236: (res (cons nil (arg 1))))
237: ((eq i nargs) (cdr res))
238: (cond ((arg i) (rplacd (last (arg i)) (arg nxt)))
239: (t (rplacd (last res) (arg nxt)))))))))
240:
241:
242:
243: (declare (localf nreverse1)) ; quick fcn shared by nreverse and nreconc
244:
245: ;--- nreconc :: nreverse and nconc
246: ; (nreconc list elemt) is equiv to (nconc (nreverse list) element)
247: ;
248: (defun nreconc (list element)
249: (cond ((null list) element)
250: (t (nreverse1 list element))))
251:
252: ;--- nreverse - l : list
253: ; reverse the list in place
254: ;
255:
256: (defun nreverse (x)
257: (cond ((null x) x)
258: (t (nreverse1 x nil))))
259:
260:
261: ;--- nreverse1
262: ; common local function to nreconc and nreverse. [This can just be
263: ; nreconc when I get local global functions allow in the compiler -jkf]
264: ;
265: (defun nreverse1 (x ele)
266: (prog (nxt)
267: loop
268: (setq nxt (cdr x))
269: (rplacd x ele)
270: (setq ele x)
271: (cond (nxt (setq x nxt) (go loop)))
272: (return x)))
273:
274: ;--- liszt-declare :: this is defined in the compiler
275: ; we give it a null definition in the interpreter
276: ;
277: (def liszt-declare (nlambda (x) nil))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.