"$Header: common0.l,v 1.4 83/12/15 11:09:34 jkf Exp $")
;; common0.l -[Mon Nov 21 14:06:20 1983 by jkf]-
;; Functions which are required to execute the low level lisp macros
;; This is the first file of functions read in when building a lisp.
;; If this lisp is to run interpretedly, then we must not use anything
;; which hasn't be defined in the C lisp kernel, except ';' which is
;; defined as the comment character before reading this file.
;; We cannot use defmacro, the backquote or the # macro.
;; This file should be as short as possible since it must be written in
;; a rather primitive way.
;--- declare : ignore whatever is given, this info is for the compiler
(def declare (nlambda (x) nil))
;--- memq - arg : (probably a symbol)
; returns part of lis beginning with arg if arg is in lis
(cond ((eq $a$ (car ll)) (return ll))))))
;--- def :: define a function
; This superceeds franz's definition.
; It does more error checking and it does lambda conversion
(cond ((and (symbolp (setq name (car l)))
(memq (caadr l) '(lambda nlambda lexpr macro glambda)))
; make sure lambda list is nil or a dtpr
(setq l (cadr l)) ; l points to (lambda (argl) ...)
(cond ((null (setq argl (cadr l)))) ; nil check
(cond ((and (eq (car l) 'lambda)
(setq l (lambdacvt (cdr l))))))
(t (error "def: bad lambda list of form in " l)))
(t (error "def: bad form " l))))
; maclisp style function defintion
(prog (name type arglist body specind specnam)
(setq name (cadr l) l (cddr l))
(cond ((memq (cadr name) '(macro expr fexpr lexpr))
(setq l (cons (cadr name) l)
(t (setq specnam (car name)
name (concat (gensym) "::" specnam))))))
(cond ((null (car l)) (setq type 'lambda))
((eq 'fexpr (car l)) (setq type 'nlambda l (cdr l)))
((eq 'expr (car l)) (setq type 'lambda l (cdr l)))
((eq 'macro (car l)) (setq type 'macro l (cdr l)))
l (nconc (list (list (car l)))
(setq body (list 'def name (cons type l)))
(return (list 'progn ''compile
(list 'quote specind)))))
;--- error : print error message and cause an error
; call is usually (error "string" value)
;; form: (error arg1 ...)
;; concat all args together, with spaces between them
;; and cause an error to be signaled
((eq i 0) (err-with-message mesg))
(cond ((atom (arg i)) (arg i))
((lessp (maknum (arg i)) (maknum nil))
; this tests for the <UNBOUND> value
(t (implode (exploden (arg i)))))
;; This is here for maclisp compatibility. junk should be nil,
;; The value is both to be printed and to be returned from the
;; errset. 'err-with-message' should be used for new code
(err-with-message "call to err"))
(err-with-message (arg 1) (arg 1)))
(t (error "wrong number of args to err:" n)))))
;--- append : append two or more lists
; the result will be a copy of all but the last list
(declare (localf append2args))
(cond ((eq nargs 2) (append2args (arg 1) (arg 2)))
(t (do ((i (1- nargs) (1- i))
(setq res (append2args (arg i) res)))))))
;--- append2args : append just two args
; a version of append which only works on 2 arguments
(cond ((null x) (return y))
((atom x) (error "Non-list to append:" x)))
(setq l* (setq l (cons (car x) nil)))
loop (cond ((atom x) (error "Non-list to append:" x))
(setq l* (cdr (rplacd l* (cons (car x) nil))))
;--- append1 : add object to end of list
; adds element y to then end of a copy of list x
(def append1 (lambda (x y) (append x (list y))))
; l is a list of lists. The list is examined and the first
; sublist whose car equals x is returned.
(do ((al alist (cdr al)))
(error "bad arg to assoc" al))
((equal val (caar al)) (return (car al)))))))
;--- rassq : like assq but look at the cdr instead of the car
(error "rassq: illegal second argument: " list))
(t (do ((ll list (cdr ll)))
(cond ((eq form (cdar ll)) (return (car ll)))))))))
;--- concatl - l : list of atoms
; returns the list of atoms concatentated
(lambda (x) (apply 'concat x)))
; returns the number of elements in the list.
(cond ((and $l$ (not (dtpr $l$)))
(error "length: non list argument: " $l$))
(t (do ((ll (cdr $l$) (cdr ll))
;--- memq - arg : (probably a symbol)
; returns part of lis beginning with arg if arg is in lis
(cond ((eq $a$ (car ll)) (return ll))))))
;--- nconc - x1 x2 ...: lists
; The cdr of the last cons cell of xi is set to xi+1. This is the
; structure modification version of append
(cond ((null (arg 1)) (arg 2))
(t (do ((tmp (arg 1) (cdr tmp)))
(res (cons nil (arg 1))))
(cond ((arg i) (rplacd (last (arg i)) (arg nxt)))
(t (rplacd (last res) (arg nxt)))))))))
(declare (localf nreverse1)) ; quick fcn shared by nreverse and nreconc
;--- nreconc :: nreverse and nconc
; (nreconc list elemt) is equiv to (nconc (nreverse list) element)
(defun nreconc (list element)
(cond ((null list) element)
(t (nreverse1 list element))))
; reverse the list in place
; common local function to nreconc and nreverse. [This can just be
; nreconc when I get local global functions allow in the compiler -jkf]
(cond (nxt (setq x nxt) (go loop)))
;--- liszt-declare :: this is defined in the compiler
; we give it a null definition in the interpreter
(def liszt-declare (nlambda (x) nil))