![[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] / 42BSD / ucb / lisp / lisplib|
Return to common0.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-common0-
2: "$Header: common0.l,v 1.3 83/09/07 08:12:49 jkf Exp $")
3:
4: ;;
5: ;; common0.l -[Sun Sep 4 13:44:22 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)))
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: (t (implode (exploden (arg i)))))
114: " " mesg)))))
115:
116: (def err
117: ;; (err value [junk])
118: ;; This is here for maclisp compatibility. junk should be nil,
119: ;; but we don't verify.
120: ;; The value is both to be printed and to be returned from the
121: ;; errset. 'err-with-message' should be used for new code
122: (lexpr (n)
123: (cond ((eq n 0)
124: (err-with-message "call to err"))
125: ((or (eq n 1) (eq n 2))
126: (err-with-message (arg 1) (arg 1)))
127: (t (error "wrong number of args to err:" n)))))
128:
129:
130: ;--- append : append two or more lists
131: ; the result will be a copy of all but the last list
132: ;
133: (declare (localf append2args))
134:
135: (def append
136: (lexpr (nargs)
137: (cond ((eq nargs 2) (append2args (arg 1) (arg 2)))
138: ((zerop nargs) nil)
139: (t (do ((i (1- nargs) (1- i))
140: (res (arg nargs)))
141: ((zerop i) res)
142: (setq res (append2args (arg i) res)))))))
143:
144: ;--- append2args : append just two args
145: ; a version of append which only works on 2 arguments
146: ;
147: (def append2args
148: (lambda (x y)
149: (prog (l l*)
150: (cond ((null x) (return y))
151: ((atom x) (error "Non-list to append:" x)))
152: (setq l* (setq l (cons (car x) nil)))
153: loop (cond ((atom x) (error "Non-list to append:" x))
154: ((setq x (cdr x))
155: (setq l* (cdr (rplacd l* (cons (car x) nil))))
156: (go loop)))
157: (rplacd l* y)
158: (return l))))
159:
160: ;--- append1 : add object to end of list
161: ; adds element y to then end of a copy of list x
162: ;
163: (def append1 (lambda (x y) (append x (list y))))
164:
165: ;--- assoc - x : lispval
166: ; - l : list
167: ; l is a list of lists. The list is examined and the first
168: ; sublist whose car equals x is returned.
169: ;
170: (def assoc
171: (lambda (val alist)
172: (do ((al alist (cdr al)))
173: ((null al) nil)
174: (cond ((null (car al)))
175: ((not (dtpr (car al)))
176: (error "bad arg to assoc" al))
177: ((equal val (caar al)) (return (car al)))))))
178:
179: ;--- rassq : like assq but look at the cdr instead of the car
180: ;
181: (def rassq
182: (lambda (form list)
183: (cond ((null list) nil)
184: ((not (dtpr list))
185: (error "rassq: illegal second argument: " list))
186: (t (do ((ll list (cdr ll)))
187: ((null ll) nil)
188: (cond ((eq form (cdar ll)) (return (car ll)))))))))
189: ;--- concatl - l : list of atoms
190: ; returns the list of atoms concatentated
191: ;
192: (def concatl
193: (lambda (x) (apply 'concat x)))
194:
195: ;--- length - l : list
196: ; returns the number of elements in the list.
197: ;
198: (def length
199: (lambda ($l$)
200: (cond ((and $l$ (not (dtpr $l$)))
201: (error "length: non list argument: " $l$))
202: (t (cond ((null $l$) 0)
203: (t (do ((ll (cdr $l$) (cdr ll))
204: (i 1 (1+ i)))
205: ((null ll) i))))))))
206:
207: ;--- memq - arg : (probably a symbol)
208: ; - lis : list
209: ; returns part of lis beginning with arg if arg is in lis
210: ;
211: (def memq
212: (lambda ($a$ $l$)
213: (do ((ll $l$ (cdr ll)))
214: ((null ll) nil)
215: (cond ((eq $a$ (car ll)) (return ll))))))
216:
217: ;--- nconc - x1 x2 ...: lists
218: ; The cdr of the last cons cell of xi is set to xi+1. This is the
219: ; structure modification version of append
220: ;
221:
222: (def nconc
223: (lexpr (nargs)
224: (cond ((eq nargs '2)
225: (cond ((null (arg 1)) (arg 2))
226: (t (do ((tmp (arg 1) (cdr tmp)))
227: ((null (cdr tmp))
228: (rplacd tmp (arg 2))
229: (arg 1))))))
230: ((zerop nargs) nil)
231: (t (do ((i 1 nxt)
232: (nxt 2 (1+ nxt))
233: (res (cons nil (arg 1))))
234: ((eq i nargs) (cdr res))
235: (cond ((arg i) (rplacd (last (arg i)) (arg nxt)))
236: (t (rplacd (last res) (arg nxt)))))))))
237:
238:
239:
240: (declare (localf nreverse1)) ; quick fcn shared by nreverse and nreconc
241:
242: ;--- nreconc :: nreverse and nconc
243: ; (nreconc list elemt) is equiv to (nconc (nreverse list) element)
244: ;
245: (defun nreconc (list element)
246: (cond ((null list) element)
247: (t (nreverse1 list element))))
248:
249: ;--- nreverse - l : list
250: ; reverse the list in place
251: ;
252:
253: (defun nreverse (x)
254: (cond ((null x) x)
255: (t (nreverse1 x nil))))
256:
257:
258: ;--- nreverse1
259: ; common local function to nreconc and nreverse. [This can just be
260: ; nreconc when I get local global functions allow in the compiler -jkf]
261: ;
262: (defun nreverse1 (x ele)
263: (prog (nxt)
264: loop
265: (setq nxt (cdr x))
266: (rplacd x ele)
267: (setq ele x)
268: (cond (nxt (setq x nxt) (go loop)))
269: (return x)))
270:
271: ;--- liszt-declare :: this is defined in the compiler
272: ; we give it a null definition in the interpreter
273: ;
274: (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.