| 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)) |