(setq SCCS-auxfns0 "@(#)auxfns0.l 1.10 11/7/80")
(setsyntax '\; 'splicing 'zapline)
; LWE 1/10/80 I put this here because it is a pain in the ass.
; reverse the list in place
(def nreverse (lambda (x)
(cond (nxt (setq x nxt) (go loop)))
;---------------- auxfns0 ---------------
; this file contains the definitions of the most common functions.
; It should only be loaded in Opus 30 Franz Lisp.
; These functions should be loaded into every lisp.
;------------------------------------------------
(cond ((null (getd 'back=quotify))
(cond ((atom (errset (fasl '/usr/lib/lisp/backquote)))
; I. Functions required to be defined right away
; declare append concatl max
; catch throw defmacro (defmacrosrch,defmcroopption)
; defun desetq let (de-compose)
; let* listify sassoc unwind-protect
; III. Interrupt functions
; IV. garbage collection functions
; comment copy copysymbol cvttomaclisp
; defprop delete delq evenp
; ex (exvi) exec exl explode
; explodec exploden expt ffasl
; flatsize floatp getchar getcharn
; length macroexpand makhunk member
; nconc nreverse oddp plusp
; sort (sorthelp,exchange2) sortcar (sortcarhelp)
; sublis (sublishelp) subst vi
; array [macro] arracfun *array
; arraycall [macro] (ev-arraycall)
; store [macro] (storeintern) arracfcnsimp
; numbp princ remainder terpri
;--- Section I - functions which must be declared immediately
;--- declare - ignore whatever is given, this is for the compiler
(def declare (nlambda (x) nil))
(declare (localf append2args))
(cond ((null x) (return y))
((atom x) (err (list '"Non-list to append:" x))))
(setq l* (setq l (cons (car x) nil)))
loop (cond ((atom x) (err (list '"Non-list to append:" x)))
(setq l* (cdr (rplacd l* (cons (car x) nil))))
(cond ((eq nargs 2) (append2args (arg 1) (arg 2)))
(t (do ((i (1- nargs) (1- i))
(setq res (append2args (arg i) res)))))))
;--- concatl - l : list of atoms
; returns the list of atoms concatentated
(lambda (x) (apply 'concat x)))
;--- max - arg1 arg2 ... : sequence of numbe
;LWE 1/11/81 Mod after DNC.
(cond ((zerop nargs)(err '"max - no args")))
(cond ((greaterp (arg i) max) (setq max (arg i)))))))
;--- memq - arg : (probably a symbol)
; returns part of lis beginning with arg if arg is in lis
(def memq ; LWE 1/11/81 Added DNC error test.
(cond ((atom ll)(err '"memq - not a proper list"))
((eq $a$ (car ll)) (return ll))))))
; catch is now a macro which translates to (*catch 'tag form)
`(*catch ',(caddr l) ,(cadr l))))
`(*throw ',(caddr l) ,(cadr l))))
; defmacro for franz, written 20sep79 by jkf
(declare (special defmacrooptlist protect-list protect-evform))
;--- defmacro - name - name of macro being defined
; - pattrn - formal arguments plus other fun stuff
; - body - body of the macro
; This is an intellegent macro creator. The pattern may contain
; symbols which are formal paramters, lists which show how the
; actual paramters will appear in the args, and these key words
; &rest name - the rest of the args (or nil if there are no other args)
; &optional name - bind the next arg to name if it exists, otherwise
; &optional (name init) - bind the next arg to name if it exists, otherwise
; bind it to init evaluted. (the evaluation is done left
; to right for optional forms)
; &optional (name init given) - bind the next arg to name and given to t
; if the arg exists, else bind name to the value of
; the list returned from defmcrosrc has the form ((cxxr name) ...)
; where cxxr is the loc of the macro arg and name is it formal name
; defmcrooptlist has the form ((initv cxxr name) ...)
; which is use for &optional args with an initial value.
; here cxxr looks like cdd..dr which will test of the arg exists.
; the variable defmacro-for-compiling determines if the defmacro forms
; will be compiled. If it is t, then we return (progn 'compile (def xx..))
; to insure that it is compiled
(cond ((null (boundp 'defmacro-for-compiling)) ; insure it has a value
(setq defmacro-for-compiling nil)))
(tmp tmp2 defmacrooptlist body protect-evform protect-list)
(setq tmp (defmcrosrch (caddr args) '(d r) nil)
((lambda ,(mapcar 'cdr tmp)
`(cond ((setq ,(caddr arg)
,@(cond ((setq tmp2 (cadddr arg))
(eval `((lambda ,(mapcar 'cdr tmp)
`((lambda ,',(mapcar 'cdr tmp)
`(,(car arg) defmacroarg))))
(cond (defmacro-for-compiling `(progn 'compile ,body))
nil nil nil nil nil nil)))
((atom pat) (cons (cons (concatl `(c ,@form)) pat)
(append (defmcrosrch (cadr pat) form nil)
(defmcrosrch (cddr pat) form sofar)))
((eq (car pat) '&optional)
(defmcrooption (cdr pat) form sofar))
((eq (car pat) '&protect)
(setq protect-list (cond ((atom (cadr pat))
protect-evform (cons 'or (mapcar '(lambda (x)
(defmcrosrch (cddr pat) form sofar))
(cond ((atom frm) `((nil) . ,frm))
(t `((,(cadr frm)) . ,(car frm)))))
(t (append (defmcrosrch (car pat) (cons 'a form) nil)
(defmcrosrch (cdr pat) (cons 'd form) sofar))))))
(defmcrosrch (cadr pat) form sofar))
(t (cond ((atom (car pat))
,(setq tmp2 (caddar pat)))
`( (,(concatl `(ca ,@form)) . ,tmp)
,@(cond (tmp2 `((nil . ,tmp2))))
;--- defun - standard maclisp function definition form.
(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)))
((atom (car l)) (setq type 'lexpr
l `((,(car l)) ,@(cdr l))))
(cond ((and (eq 'lambda type) (or (memq '&aux (car l))
(memq '&optional (car l))
; converts a lambda expression with &optional, &rest and &aux forms in
; the argument list into a lexpr which will do the desired function.
; the argument list is examined and the following lists are made:
; vbs - list of variables to be lambda bound
; opl - list of optional forms
; vals - list of values to be assigned to the vbs
(prog (arg vbs vals opl rest opflg restflg narg narg2 narg3 auxflg
(do ((ll (car exp) (cdr ll))
(cond ((eq '&rest (car ll))
(setq restflg t opflg nil count (1- count)))
((eq '&optional (car ll))
(setq opflg t count (1- count)))
(cond ((atom (setq arg (car ll)))
(setq opl (cons (cons (ncons arg) count) opl)
(setq vbs (cons (car arg)
opl (cons (cons arg count) opl)))
(t (setq vbs (cons (car arg) vbs)
opl (cons (cons arg count) opl)))))
(setq vbs (cons (car ll) vbs)
rest (cons (car ll) count)))
(cond ((atom (setq arg (car ll)))
(setq avbs (cons (ncons arg) avbs)))
(t (setq avbs (cons arg avbs)))))
(t (setq vbs (cons (car ll) vbs)
vals (cons `(arg ,count) vals)))))
`(cond ((greaterp ,(cdr arg)
(t (setq ,(caar arg) (arg ,(cdr arg)))
,@(cond (rest (setq narg2 (gensym)
`((do ((,narg2 ,narg (1- ,narg2))
(,narg3 nil (cons (arg ,narg2)
((lessp ,narg2 ,(cdr rest))
(setq ,(car rest) ,narg3))))))
,@(cond (auxflg `((let* ,(nreverse avbs)
; - pattern - pattern containing vrbl names
; - expr - expression to be evaluated
(defmacro desetq (&rest forms &aux newgen destrs)
(do ((xx forms (cddr xx))
((null xx) (cond ((null (cdr res)) (car res))
(t (cons 'progn (nreverse res)))))
(setq patt (car xx) expr (cadr xx))
(cons (cond ((atom patt) `(setq ,patt ,expr)) ;trivial case
destrs (de-compose patt '(r)))
; let for franz (with destructuring)
; - binds - binding forms
; - . body - forms to execute
; the binding forms may have these forms
; a local variable a, initially nil
; (a x) local variable a, x is evaled and a gets its value initially
; ((a . (b . c)) x) three local variables, a,b and c which are given
; values corresponding to the location in the value
; of x. Any structure is allowed here.
(defmacro let (binds &rest body &aux vrbls vals destrs newgen)
(setq vrbls (cons form vrbls)
(setq vrbls (cons (car form) vrbls)
vals (cons (cadr form) vals)))
destrs `((,newgen ,@(de-compose (car form) '(r)))
vrbls (cons newgen vrbls)
vals (cons (cadr form) vals)))))
(do ((ll (cdr frm) (cdr ll)))
(setq vrbls (cons (cdar ll) vrbls)
(setq vals (nreverse vals)
destrs (nreverse destrs))
`(setq ,(cdr vrb) (,(car vrb)
; form - pattern to de-compose
; sofar - the sequence of cxxr's needed to get to this part
; de-compose returns a list of this form
; ((cxxr . a) (cyyr . b) ... )
; which tells how to get to the value for a and b ..etc..
((atom form) (ncons (cons (apply 'concat (cons 'c sofar))
(t (nconc (de-compose (car form) (cons 'a sofar))
(de-compose (cdr form) (cons 'd sofar)))))))
; - binds - binding forms (like let)
; - body - forms to eval (like let)
; this is the same as let, except forms are done in a left to right manner
; in fact, all we do is generate nested lets
(defmacro let* (binds &rest body)
(do ((ll (reverse binds) (cdr ll)))
(setq body `((let (,(car ll)) ,@body)))))
;--- listify : n - integer
; returns a list of the first n args to the enclosing lexpr if
; n is positive, else returns the last -n args to the lexpr if n is
(do ((i (arg nil) (1- i))
(result nil (cons (arg i) result)))
((< i (+ (arg nil) n 1)) result) ))
(result nil (cons (arg i) result)))
; - fcn : function or lambda expression
; If (assoc x y) is non nil, then we apply the function fcn to nil.
; This must be written as a macro if we expect to handle the case of
; a lambda expression as fcn in the compiler.
(defmacro sassoc (x y fcn)
(cond ((or (atom fcn) (not (eq 'quote (car fcn))))
; - fcn : function or lambda expression
; like sassoc above except it uses assq instead of assoc.
(defmacro sassq (x y fcn)
(cond ((or (atom fcn) (not (eq 'quote (car fcn))))
;--- signp - test - unevaluated atom
; - value - evaluated value
; test can be l, le, e, n, ge or g with the obvious meaning
; we return t if value compares to 0 by test
`(signphelpfcn ',(cadr l) ,(caddr l))))
(defmacro signp (tst val)
(setq tst (cond ((eq 'l tst) `(minusp signp-arg))
((eq 'le tst) `(not (greaterp signp-arg 0)))
((eq 'e tst) `(any-zerop signp-arg))
((eq 'n tst) `(not (any-zerop signp-arg)))
((eq 'ge tst) `(not (minusp signp-arg)))
((eq 'g tst) `(greaterp signp-arg 0))
(t (error |bad arg to signp | tst))))
(cond ((atom val) `(and (numberp ,val) ,(subst val 'signp-arg tst)))
(t `((lambda (signp-arg) (and (numberp signp-arg) ,tst))
; not needed for new code anymore
(cond ((eq 'l tst) (minusp val))
((eq 'le tst) (or (zerop val) (minusp val)))
((eq 'e tst) (zerop val))
((eq 'n tst) (not (zerop val)))
((eq 'ge tst) (not (minusp val)))
((eq 'g tst) (greaterp val 0)))))
; The form of a call to unwind-protect is
; and it works as follows:
; pform is evaluated, if nothing unusual happens, form1 form2 etc are
; then evaluated and unwind-protect returns the value of pform.
; if while evaluating pform, a throw or error caught by an errset which
; would cause control to pass through the unwind-protect, then
; form1 form2 etc are evaluated and then the error or throw continues.
; Thus, no matter what happens, form1, form2 etc will be evaluated.
(defmacro unwind-protect (protected &rest conseq &aux (localv (gensym 'G)))
(setq ,localv (*catch 'ER%unwind-protect ,protected))
(cond ((and (dtpr ,localv) (eq 'ER%unwind-protect (car ,localv)))
(I-throw-err (cdr ,localv)))
;----Section III -- Interrupt handlers
(lambda (x$) (error "Floating Exception ")))
(lambda (dummy) (patom '"Interrupt:
\a ") (drain poport) (break)))
;---- Section IV - interrupt handlers
(cond ((null (boundp '$gcprint))
(setq $gcprint t))) ; dont print gc stats by default
; Changed LWE 1/11/81 for newlisp.
(cond ((null (boundp '$gccount$))
;--- prtpagesused - [arg] : type of page allocated last time.
; prints a summary of pages used for certain selected types
; of pages. If arg is given we put a star beside that type
; of page. This is normally called after a gc.
(do ((curtypl (cond ((memq (car arg) '(list fixnum nil))
; LWE 1/11/81 DNC claims nil is needed in case
(t (cons (car arg) '(list fixnum))))
((null curtypl) (patom '"]") (terpr poport))
(setq temp (car curtypl))
(cond ((greaterp (cadr (opval temp)) 0)
(cond ((eq (car arg) temp)
(print (cadr (opval temp)))
(declare (special gcafter-panic-mode))
(setq gcafter-panic-mode nil)
;--- gcafter - [s] : type of item which ran out forcing garbage collection.
; This is called after each gc.
; the form of an opval element is (number_of_items_in_use
; number_of_pages_allocated
; number_of_items_per_page)
(prog (x pct amt-to-allocate)
(cond ((null s) (return)))
(cond ((null (boundp '$gccount$)) (setq $gccount$ 0)))
(setq $gccount$ (1+ $gccount$))
; pct is the percentage of space used
(setq pct (quotient (car x)
(max .00001 (times 1.0 (cadr x) (caddr x)))))
(cond (gcafter-panic-mode
(cond ((greaterp pct .95)
(patom "[Storage space totally exausted]")
(error "Space exausted when allocating "
(max 15 (fix (times .10 (cadr x)))))
((and (greaterp pct .30) (lessp (cadr x) 100))
(cond ((null gcafter-panic-mode)
(cond ((atom (errset (allocate (car s) amt-to-allocate)))
(patom "[Now in storage allocation panic mode]")
(setq gcafter-panic-mode t)))))
(cond ($gcprint (apply 'prtpagesused s)
(comment (cond ((and (getd 'gcstat)
;----Section V - the functions
; [ must appear at the beginning to allow backquote to work ]
; puts y at the end 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)))
((or (not (dtpr (car al))) (atom al))
; LWE 1/11/81 Added extra type checking.
(error "bad arg to assoc" al))
((equal val (caar al)) (return (car al)))))))
; returns t if x is a bignum
(def bigp (lambda (arg) (equal (type arg) 'bignum)))
; ignores the rest of the things in the list
;--- concatl - l : list of atoms
; returns the list of atoms concatentated
; [ must appear at top to allow defmacro to work ]
;--- copy - l : list (will work if atom but will have no effect)
; makes a copy of the list.
; FIX THIS UP TO REMOVE RECURSION ON TAIL
(t (cons (copy (car l)) (copy (cdr l)))))))
;--- copysymbol - sym : symbol to copy
; generates an uninterned symbol with the same name as sym. If flag is t
; then the value, function binding and property list of sym are placed
; in the uninterned symbol.
(cond (flag (cond ((boundp sym) (set newsym (eval sym))))
(setplist newsym (plist sym))))
;--- cvttointlisp -- convert reader syntax to conform to interlisp
(setsyntax '\% 143.) ; escape character
(setsyntax '\\ 2.) ; normal character
(setsyntax '\` 2.) ; normal character
(setsyntax '\, 2.) ; normal character
(sstatus uctolc t) ; one case
;--- cvttomaclisp - converts the readtable to a maclisp character syntax
(setsyntax '\| 138.) ; double quoting char
(setsyntax '\/ 143.) ; escape
(setsyntax '\\ 2) ; normal char
; not needed in new lisp (setsyntax '\" 2) ; normal char
(setsyntax '\[ 2) ; normal char
(setsyntax '\] 2) ; normal char
;--- cvttoucilisp - converts the readtable to a ucilisp character syntax
; LWE 1/11/80 The mere thought of this makes me cringe. I am having
; trouble finding out who is zapping my setting of ;, so this has to go.
; (sstatus uctolc t) ; upper case to lower case
; ; change backquote character.
; ; to ` and ! and !@ from ` , and ,@
; (cond ((eq (status syntax \,) 205)
; (setsyntax '\! 'splicing (get '\, 'macro))))
; ; ~ as comment character, not ; and / instead of \ for escape
; (setsyntax '\~ 'splicing 'zapline)
;--- defprop - like putprop except args are not evaled
(putprop (car argl) (cadr argl) (caddr argl) )))
; - n - Optional arg, number of occurances to delete
; removes up to n occurances of val from the top level of lst.
; if n is not given, all occurances will be removed.
(prog (val lst cur ret nmb)
(cond ((< nargs 2) (error " too few args to delete " nargs))
(cond ((not (greaterp nmb 0)) (return (arg 2))))))
(setq val (arg 1) lst (arg 2))
(cond ((and (atom lst) (not (null lst)))
(error " non list arg to delete " lst)))
(cond ((null lst) (return (cdr ret)))
(cond ((and nmb (zerop (setq nmb (1- nmb))))
(t (setq cur (cdr cur))))
; same as delete except eq is used for testing.
(prog (val lst cur ret nmb)
(cond ((< nargs 2) (error " too few args to delete " nargs))
(cond ((not (greaterp nmb 0)) (return (arg 2))))))
(setq val (arg 1) lst (arg 2))
(cond ((and (atom lst) (not (null lst)))
(error " non list arg to delete " lst)))
(cond ((null lst) (return (cdr ret)))
(cond ((and nmb (zerop (setq nmb (1- nmb))))
(t (setq cur (cdr cur))))
;--- delete - val - s-expression
; - list - list to delete fromm
; -[n] optional count , if not specified, it is infinity
; delete removes every thing in the top level of list which equals val
; the list structure is modified
; (cond ((or (null list) (zerop n)) list)
; ((atom list) (error "Bad arg to delete " list))
; ((equal val (car list))
; (delete val (cdr list) (1- n)))
; (t (rplacd list (delete val (cdr list) n)))))
; (cond ((equal nargs 3) (arg 3))
;--- delq - val - s-expression
; - list - list to delete fromm
; -[n] optional count , if not specified, it is infinity
; delq removes every thing in the top level of list which eq's val
; the list structure is modified
; (cond ((or (atom list) (zerop n)) list)
; (delq val (cdr list) (1- n)))
; (t (rplacd list (delq val (cdr list) n)))))
; (cond ((equal nargs 3) (arg 3))
;--- evenp : num - return
(cond ((not (zerop (boole 4 1 n))) t))))
;--- ex [name] : unevaluated name of file to edit.
; the ex editor is forked to edit the given file, if no
; name is given the previous name is used
(def ex (nlambda (x) (exvi 'ex x nil)))
(prog (handy handyport bigname)
(cond ((null x) (setq x (list edit_file)))
(t (setq edit_file (car x))))
(setq bigname (concat (car x) '".l"))
(cond ((setq handyport (car (errset (infile bigname) nil)))
(t (setq handy (car x))))
(setq handy (concat cmd '" " handy))
(setq handy (list 'process handy))
(cond (doload (load edit_file))))))
;--- exec - arg1 [arg2 [arg3 ...] ] unevaluated atoms
; A string of all the args concatenated together seperated by
; blanks is forked as a process.
(return (eval (list (quote process) $handy))))
(concat (concat $handy (car $list))
;--- exl - [name] : unevaluated name of file to edit and load.
; If name is not given the last file edited will be used.
; After the file is edited it will be `load'ed into lisp.
(def exl (nlambda (x) (exvi 'ex x t)))
;----- explode functions -------
; These functions, explode , explodec and exploden, implement the
; maclisp explode functions completely.
; They have a similar structure and are written with efficiency, not
; beauty in mind (and as a result they are quite ugly)
; The basic idea in all of them is to keep a pointer to the last
; thing added to the list, and rplacd the last cons cell of it each time.
;--- explode - arg : lispval
; explode returns a list of characters which print would use to
; print out arg. Slashification is included.
(cond ((atom arg) (aexplode arg))
(t (do ((ll (cdr arg) (cdr ll))
(sofar (setq arg (cons '"(" (explode (car arg)))))
((cond ((null ll) (rplacd (last sofar) (ncons '")" ))
((atom ll) (rplacd (last sofar)
`(" " "." " " ,@(explode ll)
sofar (cons '" " (explode (car ll))))
;--- explodec - arg : lispval
; returns the list of character which would be use to print arg assuming that
; patom were used to print all atoms.
; that is, no slashification would be used.
(cond ((atom arg) (aexplodec arg))
(t (do ((ll (cdr arg) (cdr ll))
(sofar (setq arg (cons '"(" (explodec (car arg)))))
((cond ((null ll) (rplacd (last sofar) (ncons '")" ))
((atom ll) (rplacd (last sofar)
`(" " "." " " ,@(explodec ll)
sofar (cons '" " (explodec (car ll))))
;--- exploden - arg : lispval
; returns a list just like explodec, except we return fixnums instead
(cond ((atom arg) (aexploden arg))
(t (do ((ll (cdr arg) (cdr ll))
(sofar (setq arg (cons 40. (exploden (car arg)))))
((cond ((null ll) (rplacd (last sofar) (ncons 41.))
((atom ll) (rplacd (last sofar)
`(32. 46. 32. ,@(exploden ll)
sofar (cons 32. (exploden (car ll))))
((zerop x) x) ; Maclisp does this
((lessp y 0) (quotient 1.0 (expt x (times -1 y))))
(exp (times y (log x)))) ; bomb out for (-3)^4 or (-3)^4.0 or 0^y.
(cond ((equal y 0) (return res))
((oddp y)(setq res (times res x) y (1- y)))
(t (setq x (times x x) y (/ y 2))))
loop (cond ((equal y 0) (return res))
(t (setq res (times x res)
;--- ffasl :: fasl in a fortran file
; 2 - entry : entry point name
; 4 - disc : optional discipline
(defun ffasl (fnam entry fcn &optional (disc 'subroutine))
(cfasl fnam entry fcn disc "-lI77 -lF77 -lm"))
; filepos function (maclisp compatibility)
(fseek (arg 1) (arg 2) 0))))
; returns t if l is a fixnum or bignum
(defun fixp (x) (or (equal (type x) 'fixnum)
(equal (type x) 'bignum)))
;--- flatsize - l : lispval
; the second arg should be:
; - n : limit for what we care about
; but we dont care about this at present, since we have
; to explode the whole thing anyway.
; returns the number of characters which print would
(length (explode (arg 1))))
;--- floatp - l : lispval
; returns t if l is a flonum
(defun floatp (x) (equal 'flonum (type x)))
;--- getchar,getcharn - x : atom
; returns the n'th character of x's pname (the first corresponds to n=1)
; if n is negative then it counts from the end of the pname
; if n is out of bounds, nil is returned
(concat (substring x n 1))))
(do ((ll (cond ((atom atm) (plist atm))
(cond ((memq (car ll) lis) (return ll))))))
; retrive selected portions of the Franz Lisp manual.
; There are four types of help offered:
; (help) prints a description of the other three options
; (help tc) prints a table of contents.
; (help n) {where n is a number or b or c} prints the whole chapter.
; (help fcn) prints info on function fcn
; An index to the functions is kept in the documentation directory.
; The index has entries like (append ch2.r).
; When asked to print info on a function, it locates the chapter
; using the index then asks more to locate the definition.
(declare (localf locatefunction))
(patom "type (help fnc) for info on function fnc")(terpr)
(patom "type (help n) to see chapter n")(terpr)
(patom "type (help tc) for a table of contents")(terpr))
(t (do ((ll lis (cdr ll))
(cond ((not (atom (setq fcn (car ll))))
(patom "Bad option to help ")(print fcn)(terpr))
((and (stringp fcn) (setq fcn (concat fcn)) nil))
(patom "Table of contents")(terpr)
(patom "1 - intro; 2 - data structure; 3 - arithmetic; 4 - special")(terpr)
(patom "5 - i/o; 6 - system; 7 - reader; 8 - functions; 9 - arrays")(terpr)
(patom "10 - exceptions; 11 - trace package; 12 - Liszt;")(terpr)
; LWE 1/19/81 Some new stuff!...
(patom "13 - toplevel and files; 14 - stepper; 15 - debugger;")(terpri)
(patom "16 - editor; 17 - alto as terminal; 18 - ipc facility;")(terpri)
(patom "b - special symbols; c - gc & debugging & top level ")(terpr))
((or (and (numberp fcn) (lessp fcn 19) (greaterp fcn -1))
(concat '|/usr/ucb/more /usr/lisp/manual/ch|
(t (patom "Unknown function: ")(print fcn)(terpr)))))))
(declare (special readtable))
(defun locatefunction (fc)
(cond ((null (get 'append 'helplocation))
(patom "[Reading help index]")(drain)
(setq inf (infile "/usr/lisp/manual/helpindex"))
(do ((readtable (makereadtable t))
(x (read inf) (read inf)))
((null x) (close inf) (terpr))
(putprop (car x) (cadr x) 'helplocation))
(t (putprop (concat (car x) " " (cadr x))
(cond ((setq x (get fc 'helplocation))
(apply 'process (ncons (concat '|/usr/ucb/more "+/(| fc
'|" /usr/lisp/manual/| x)))
; (hunk 'g_arg1 [...'g_argn])
; This function makes a hunk. The hunk is preinitialized to the
; arguments present. The size of the hunk is determined by the
; number of arguments present.
(cond ((greaterp n 128) (error "hunk: size is too big" n))
(t (setq size (1- (haulong n)))))
(cond ((minusp size) (return nil))) ;Hunk of zero length
(setq size (*makhunk size))
(*rplacx (1- argnum) size (arg argnum))
(setq argnum (1+ argnum)))
; returns the last cons cell of the list, NOT the last element
; ((null (cdr ll)) ll))))
; LWE 1/11/80 Added DNC's better version.
(cond ((null a)(return nil))
((atom (setq ll a))(err '"atomic arg to last")))
lp (cond ((atom (cdr ll))(return ll))
(t (setq ll (cdr ll))(go lp]
; LWE 1/10/80 load is a pain in the ass.
; (declare (localf load-a-file)) nuked, in case this was nuking piport
(declare (special name piport))
(defun load (filename &rest fasl-args)
(cond ((not (or (symbolp filename) (stringp filename)))
(error "load: illegal filename " filename)))
(let ( load-only fasl-only no-ext len search-path name pred)
(setq len (flatc filename))
(cond ((eq (getchar filename (1- len)) '|.|)
(cond ((eq (getchar filename len) '|o|)
(cond ((and (> len 0) (eq (getchar filename 1) '/))
(setq search-path '(||)))
(t (setq search-path (status load-search-path))))
(do ((xx search-path (cdr xx)))
((null xx) (error "load: file not found " filename))
(setq pred (cond ((memq (car xx) '(|| |.|)) '||)
(t (concat (car xx) "/"))))
(cond ((probef (setq name (concat pred
(return (fasl name (car fasl-args)
((probef (setq name (concat pred filename ".l")))
(return (load-a-file name)))
((probef (setq name (concat pred filename)))
(return (load-a-file name)))))
(cond ((probef (setq name (concat pred filename)))
(return (fasl name (car fasl-args)
(cond ((probef (setq name (concat pred filename)))
(return (load-a-file name)))))))))
(defun load-a-file (name) ; Fixed, because we LIKE our piport.
(setq piport (infile name))
(do ((form (read piport eof) (read piport eof)))
((eq eof form) (close piport) t)
(sstatus load-search-path (|.| /usr/lib/lisp))
;--- include - read in the file name given, the name not evaluated
(def include (nlambda (l) (load (car l))))
;--- includef - read in the file name given and eval the first arg
(def includef (lambda (l) (load l)))
; returns the number of elements in the list.
; (t (do ((ll (cdr $l$) (cdr ll))
; LWE 1/11/81 DNC's imported hack to catch atoms like Maclisp.
(cond ((atom ll)(err '"non-list to length"]
; expands out all macros it can
top (cond ((atom form) (return form))
(let ((nam (car form)) def disc)
(setq disc (cond ((bcdp def) (getdisc def))
(cond ((memq disc '(nlambda lambda lexpr nil))
(cons nam (mapcar 'macroexpand (cdr form))))
(setq form (apply nam form))
(t (return (cons (macroexpand (car form))
(mapcar 'macroexpand (cdr form)))))))))
; This function is similar to hunk, except that:
; n can be a fixnum, which specifies the length of the hunk.
; The hunk is preinitialized to nil's
; n can be a list which is used to preinitialize the hunk.
; If n is a number then build a nil hunk of the right size
(cond ((greaterp n 128) (error "makhunk: size is too big" n))
(t (setq size (1- (haulong n)))))
(cond ((minusp size) (return nil)))
(setq Hunk (*makhunk size))
; If it isn't a number, then try hunk on it
;--- member - VAL : lispval
; returns that portion of LIS beginning with the first occurance
; of VAL if VAL is found at the top level of list LIS.
; uses equal for comparisons.
; LWE 1/11/81 Added DNC's error checking.
(cond ((atom ll)(err '"member - not a proper list"))
((equal $a$ (car ll)) (return ll))))))
;--- memq - arg : (probably a symbol)
; returns part of lis beginning with arg if arg is in lis
; [ defintion moved to top of file to allow backquote macro to work ]
;--- min - arg1 ... numbers
; returns minimum of n numbers.
; LWE 1/11/81 Added DNC's error check.
(cond ((zerop nargs)(err '"min - no args")))
(cond ((lessp (arg i) min) (setq min (arg i)))))))
;--- 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)))))))))
(cond ((not (zerop (boole 1 1 n))) t))))
; returns t iff x is greater than zero
;--- princ : l - any s-expression
; prints using patom for atoms (unslashified)
(cond ((eq n 2) (setq port (arg 2))))
(cond ((dtpr (setq val (arg 1)))
(cond ((and (eq 'quote (car val))
((null xx) (patom ")" port))
(cond ((null (setq xx (cdr xx))))
(t (patom " " port)))))))
;--- prog1 : return the first value computed in a list of forms
; returns the list reversed using cons to create new list cells.
(t (do ((cur (cons (car x) nil)
;--- shell - invoke a new c shell
(cond ((lessp (flatc shellname) 1) (setq shellname 'csh)))
(apply 'process (ncons shellname)))
;--- sload : fn - file name (must include the .l)
; loads in the file printing each result as it is seen
(cond ((setq por (infile fn)))
(t (patom '"bad file name")(terpr)(return nil)))
(do ((x (read por) (read por)))
; these is the old sort functions
(cond ((null a) (return nil)) ;no elements
(do i 1 (1+ i) (greaterp i n)(sorthelp a fun))
(cond ((funcall fun (cadr ii) (car ii))
; it recursively splits the list to sort until the list is small. At that
; point it uses a bubble sort. Finally the sorted lists are merged.
(declare (special sort-function))
;--- sort :: sort a lisp list
; args: lst - list of items
; fcn - function to compare two items.
; returns: the list with such that for each pair of adjacent elements,
; either the elements are equal, or fcn applied to the two
; args returns a non nil value.
(setq sort-function fcn) ; store function name in global cell
; (setq sort-compares 0) ; count number of comparisons
(sortmerge lst (length lst)))
;--- sortmerge :: utility routine to sort
; args: lst - list of items to sort
; nitems - a rough idea of how many items are in the list
; result - sorted list (see the result of sort above)
(defun sortmerge (lst nitems)
(cond ((greaterp nitems 7)
(setq tmp (splitlist lst (setq tmp2 (quotient nitems 2))))
(return (mergelists (sortmerge (car tmp) tmp2)
(sortmerge (cdr tmp) tmp2))))
((eq fin (cdr ll)) (setq fin ll))
;(setq sort-compares (1+ sort-compares))
(cond ((not (funcall sort-function (car ll) (cadr ll)))
(rplaca ll (prog1 (cadr ll)
;--- splitlist :: utility routine to split a list
; args : lst - list to split
; spliton - number of items to put in the first list
; returns: a cons cell whose car is the first part of the list
; and whose cdr is the second part.
(defun splitlist (lst spliton)
(do ((i spliton (sub1 i))
((or (null (cdr l)) (zerop i))
(return (cons lst second))))
;--- mergelists ::utility routine to merge two lists based on predicate function
; sort-function (global) - compares items of the lists
; returns: a sorted list containing the elements of the two lists.
(defun mergelists (ls1 ls2)
(setq current (setq result (cons nil nil)))
((funcall sort-function (car ls1) (car ls2))
;(setq sort-compares (1+ sort-compares))
(t ;(setq sort-compares (1+ sort-compares))
;--- end bubble merge sort
(cond ((null a) (return nil)) ;no elements
(do i 1 (1+ i) (greaterp i n)(sortcarhelp a fun))
(defun sortcarhelp (a fun)
((funcall fun (caadr a) (caar a))
(sortcarhelp (cdr a) fun))
(t (sortcarhelp (cdr a) fun))))
;--- sublis: alst - assoc list ((a . val) (b . val2) ...)
; for each atom in exp which corresponds to a key in alst, the associated
; value from alst is substituted. The substitution is done by adding
; list cells, no struture mangling is done. Only the minimum number
; of list cells will be created.
(cond ((setq tmp (assoc exp alst))
((setq tmp (sublishelp alst exp))
;--- sublishelp : alst - assoc list
; this function helps sublis work. it is different from sublis in that
; it return nil if no change need be made to exp, or returns a list of
; one element which is the changed exp.
(cond ((setq carp (assoc exp alst))
(t (setq carp (sublishelp alst (car exp))
cdrp (sublishelp alst (cdr exp)))
(cond ((not (or carp cdrp)) nil) ; no change
((and carp (not cdrp)) ; car change
(list (cons (car carp) (cdr exp))))
((and (not carp) cdrp) ; cdr change
(list (cons (car exp) (car cdrp))))
(list (cons (car carp) (car cdrp))))))))))
; substitutes in patrn all occurrences equal to old with new and returns the
; MUST be put in the manual
(declare (special new old))
(cond ((symbolp old) (substeq pat))
;use this function for substituting for symbols
(t (cons (substeq (car pat))(substeq (cdr pat)))))))
(cond ((equal old pat) new)
(t (cons (substequal (car pat))
; in interlisp, the next line would be
; for maclisp compatibility, we do this.
(substequal (cdr pat)))))))
(declare (unspecial new old))
;--- vi: arg is unevaluated name of function to run vi on
(def vi (nlambda (x) (exvi 'vi x nil)))
;--- vil : arg is unevaluated, edits file and then loads it
(def vil (nlambda (x) (exvi 'vi x t)))
; returns (b . a) that is, it is an exchanged cons
(def xcons (lambda (a b) (cons b a)))
;--- Section VI - ARRAY functions .
`(*array ',(cadr $lis$) ',(caddr $lis$) ,@(cdddr $lis$))))
;--OLD array stuff. new stuff to follow
; (lambda (actlst ardisc)
; (setq actlst (mapcar 'eval actlst)
; (cond ((null (equal (length actlst)
; (break '"Wrong number of indexes to array ref"))
; (t (setq ind (arrcomputeind (cdr actlst)
; val (arrayref ardisc ind))
; (cond ((or (eq (car diml) t)
; (eq (car diml) 'unmarked_array))
; (t (setq val (cpy1 val))))
; (prog (name type rtype dims size tname)
; rtype (cond ((null type) (setq type 'unmarked_array)
; (res nil (cons (arg i) res)))
; ((greaterp i nargs) (nreverse res)))
; size (apply 'times dims))
; (setq tname (marray (segment rtype size)
; (cond (name (set name tname)
; '(fillarray tname (cond ((eq type 'fixnum) '(0))
; ((eq type 'flonum) '(0.0))
;(defmacro arraycall (type name &rest indexs)
; `(ev-arraycall ',type ,name (list ,@ indexs)))
; (lambda (type ardisc indexs)
; ; form (arraycall type name sub1 sub2 ... subn)
; (cond ((or (not (equal (car (getaux ardisc)) type))
; (and (eq (car (getaux ardisc)) 'unmarked_array)
; (patom '" Type given arraycall:")
; (patom '" doesn't match array type:")
; (patom (car (getaux ardisc)))
; (apply (getaccess ardisc)
; (list indexs ardisc))))
;; function to compute the raw array index
; (lambda (indl diml res)
; (cond ((null diml) res)
; (t (arrcomputeind (cdr indl)
;; we make store a macro to insure that all parts are evaluated at the
;; right time even if it is compiled.
;; (store (foo 34 i) (plus r f))
;; (storeintern foo (plus r f) (list 34 i))
;; and storeintern is a lambda, so when foo is evaluated it will pass the
;; array descriptor to storeintern, so storeintern can look at the
;; aux part to determine the type of array.
;(defmacro store ( (arrname . indexes) value)
; (setq arrname `(getd ,(car indexes))
; indexes (cdr indexes)))
; ((eq 'arraycall arrname)
; (setq arrname (cadr indexes)
; indexes (cddr indexes)))
; (cond ((or (and (dtpr fnd) (eq 'macro (car fnd)))
; (and (bcdp fnd) (eq 'macro (getdisc fnd))))
; (setq fnd (apply arrname (cons arrname indexes)))
; (setq arrname (car fnd)
; (t (setq arrname `(getd ',arrname))))
; (return `(storeintern ,arrname ,value (list ,@indexes)))))
;;-- storeintern - internal store function
;; - arrnam : array descriptor
;; - actlst : list of actual variable values
; (lambda (arrnam vl actlst)
; (cond ((or (eq t (car (getaux arrnam)))
; (eq 'unmarked_array (car (getaux arrnam))))
; (setq loc (arracfcnsimp actlst arrnam))
; (t (replace (arracfcnsimp actlst arrnam) vl)))
; (lambda (indexes adisc)
; (setq dims (cdr (getaux adisc)))
; (cond ((null (equal (length indexes)
; (break '"wrong number of indexes to array"))
; (t (setq dims (arrcomputeind (cdr indexes)
; (return (arrayref adisc dims)))))
;; new array package (jkf 9/24/80)
; features of the new package:
; Most array will be notype arrays. This is because they are the most
; efficient in Franz. What used to be fixnum and flonums arrays are
; now fixnum-block and flonum-block arrays.
; The array access functions are more specialized and much faster now.
; The array access functions have different semantics. Now they are
; responsible for both accessing and storing in an array.
; When an access function is asked to access a value, it will be given
; the subscripts already evaluated and the array object. These will
; be stacked, so the array access function should be a lexpr to read them.
; When an access function is asked to store a value that value will be
; the first argument, the subscripts will follow and finally there will
; It is up to the access function to determine if it is being asked to
; store or retrieve a value, and this determination will probably
; be made by looking at the number of arguments.
(declare (special gcdisable))
(prog (name type rtype dims size tname numdims)
(cond ((lessp (setq numdims (- nargs 2)) 1)
(error "no bounds to array declaration ")))
rtype (cond ((memq type '(t nil fixnum flonum))
(t (error "array: bad type: " type)))
dims (do ((i nargs (1- i))
(res nil (cons (arg i) res)))
size (apply 'times dims))
(cond ((null type) (setq type 'unmarked_array)))
; we disable gc during the next calculation since
; the data returned from small-segment is unprotected
; and a gc would cause its data to be put on the
(marray (small-segment rtype size)
; if type is fixnum or flonum
; we must intialize to 0 or 0.0
(cond ((or (and (eq 'fixnum type)
(set (arrayref tname (setq i (1- i))) rtype))))
(cond (name (putd name tname)))
(defmacro arraycall (type array &rest indexes)
`(funcall ,array ,@indexes))
; this is used by the old array scheme. Keep this around until
; everything is recompiled
(defun ev-arraycall (type array indexes)
;;;---- array access functions.
; we first define a macro to evaluate a value cell. In compiled code cdr
; is the fastest way to do this, in interpreted code the type checker
; would not let us use cdr so we have to use eval.
(defmacro value-eval (x) `(cdr ,x))) ; one level of indirection
(defun value-eval (x) (eval x)))
(cond ((eq n 2) (value-eval (arrayref (arg 2) (arg 1))))
((eq n 3) (set (arrayref (arg 3) (arg 2)) (arg 1)))
(t (error " wrong number of subscripts to array: " (arg n)))))
(let ((aux (getaux (arg n))))
(value-eval (arrayref (arg n) (+ (* (arg 1) (caddr aux)) (arg 2)))))
(set (arrayref (arg n) (+ (* (arg 2) (caddr aux)) (arg 3)))
(t (error " wrong number of subscripts to array: " (arg n))))))
;-- n dimensional array access function.
(let ((aux (getaux (arg n)))
(setq subs (length (cdr aux)))
(setq firstsub 2 store t))
(t (error "wrong number of subscripts to array: " (arg n))))
(setq index (arg firstsub))
(do ((bounds (cddr aux) (cdr bounds))
(setq index (+ (* index (car bounds)) (arg (setq i (1+ i))))))
(setq subs (arrayref (arg n) index)) ; get cell requested
(cond ((memq (car aux) '(fixnum-block flonum-block))
(cond (store (replace subs (arg 1)))
(t (cond (store (set subs (arg 1)))
(t (value-eval subs)))))))
(defmacro store ( (arrname . indexes) value)
(setq arrname (car indexes)
(setq arrname (cadr indexes)
(cond ((or (and (dtpr fnd) (eq 'macro (car fnd)))
(and (bcdp fnd) (eq 'macro (getdisc fnd))))
(setq fnd (apply arrname (cons arrname indexes)))
(return (cond (defered `(funcall ,arrname ,value . ,indexes))
(t `(,arrname ,value . ,indexes))))))
;-- storeintern - there may be residual calls to storeintern from
; old code, we handle it here. this routine can be eliminated when
(defun storeintern (arrnam value indexes)
(apply arrnam (cons value indexes)))
;--- small segment storage allocators.
; this function allocates segments of storage and attempt to use the whole
; block instead of throwing away what isnt used
(declare (special gcdisable))
(defun small-segment (type n)
(prog (lastseg retv elementsize itemsperpage-1 gcdisable tmp)
(setq gcdisable t) ; its not a good idea to gc while we are
; handling pointers to things segment returns.
(desetq (elementsize . itemsperpage-1) (get 'segment-sizes type))
(cond ((null elementsize) (error "small-segment: bad type " type)))
(setq lastseg (get 'segment-types type))
(cond ((and lastseg (not (lessp (car lastseg) n))))
(t ; must allocate a block of storage, want to the least number of
; pages which includes n elements
; there are elementsize elements per page, and
; itemsperpage-1 is the number of elements on a page minus 1
itemsperpage-1)) ; 4 is x & ~y
(setq lastseg (cons retv (maknum (segment type retv))))))
(setq retv (cdr lastseg))
(rplaca lastseg (- (car lastseg) n))
(rplacd lastseg (+ (cdr lastseg) (* elementsize n)))
(cond ((greaterp (car lastseg) 0)
(putprop 'segment-types lastseg type)
(cond ((null (setq tmp (get 'segment-arrays type)))
(setq tmp (marray nil nil nil nil nil))
(putdata tmp (fake (cdr lastseg)))
(putlength tmp (car lastseg))
(putdelta tmp elementsize))
(t ; remove all counters since we no longer have any space
; left and we can't have a zero length array
(remprop 'segment-types type)
(remprop 'segment-arrays type)))
; data base for small-segment
(putprop 'segment-sizes '( 4 . 127) 'value)
(putprop 'segment-sizes '( 4 . 127) 'fixnum)
(putprop 'segment-sizes '( 8 . 63) 'flonum)
(def arraydims (lambda (arg) (cond ((symbolp arg) (getaux (getd arg)))
((arrayp arg) (getaux arg))
(t (break '"non array arg to arraydims")))))
; fill array from list or array
(cond ((symbolp arr) (setq arr (getd arr))))
(return (fillarrayarray arr lis)))
((arrayp lis) (return (fillarrayarray arr lis))))
(setq maxv (1- (getlength arr))
typept (cond ((memq (car (getaux arr))
'(t fixnum flonum unmarked_array))
(cond (typept (set (arrayref arr i) (car ls)))
(t (replace (arrayref arr i) (car ls))))
(cond ((cdr ls) (setq ls (cdr ls))))))))
(setq maxv (1- (min (getlength arrto)
(replace (arrayref arrto i) (arrayref arrfrom i))))))
(cond ((and (symbolp arr) (arrayp (setq arr (getd arr)))))
((arrayp arr)) ;; LWE fix 1/24/81 for Marty Herman
(t (error "Non array to listarray " arr)))
(setq size (cond ((eq n 2) (arg 2))
(t (apply '* (cdr (arraydims arr))))))
(setq typ (car (getaux arr)))
(cond ((memq typ '(t fixnum flonum unmarked_array))
(do ((i (1- size) (1- i)))
(setq newv (arrayref arr i))
(setq ret (cons (cond (typ (eval newv))
;---Section VII - equivalances-------------------
(putd 'abs (getd 'absval))
(putd 'chrct (getd 'charcnt))
(putd 'diff (getd 'difference))
(putd 'numbp (getd 'numberp))
(putd 'remainder (getd 'mod))
(putd 'terpri (getd 'terpr))
(putd 'typep (getd 'type))
(putd 'symeval (getd 'eval))
(putd '> (getd 'greaterp))
(putd '- (getd 'difference))
(putd '\/ (getd 'quotient))
(putd '*dif (getd 'difference))
(putd '\1+$ (getd 'add1))
(putd '\1-$ (getd 'sub1))
(putd '/$ (getd 'quotient))
(putd '-$ (getd 'difference))
projects / unix-history / blob