"$Header: /usr/lib/lisp/RCS/common1.l,v 1.2 83/03/04 09:28:51 jkf Exp $")
;; common1.l -[Fri Mar 4 08:11:26 1983 by jkf]-
;; common lisp functions. These are the most common lisp functions
;; [which don't have to be defined in common0.l in order to support
(declare (macros t)) ;; compile macros in this file
;--- Section 0 - variables
(declare (special Standard-Input Standard-Output Standard-Error
(or (boundp 'lisp-library-directory)
(setq lisp-library-directory '/usr/lib/lisp))
;--- Section 0 - equivalences
(defmacro make-equivalent (a b)
`(progn (putd ',a (getd ',b))
(putprop ',a (get ',b 'fcn-info) 'fcn-info)))
(make-equivalent abs absval)
(make-equivalent add sum)
(make-equivalent bcdcall funcall)
(make-equivalent chrct charcnt)
(make-equivalent diff difference)
(make-equivalent numbp numberp)
(make-equivalent remainder mod)
(make-equivalent terpri terpr)
(make-equivalent typep type)
(make-equivalent symeval eval)
(make-equivalent < lessp)
(make-equivalent <& lessp) ; fixnum version
(make-equivalent = equal)
(make-equivalent =& equal) ; fixnum version
(make-equivalent > greaterp)
(make-equivalent >& greaterp) ; fixnum version
(make-equivalent *dif difference)
(make-equivalent \1+$ add1)
(make-equivalent \1-$ sub1)
(make-equivalent *$ times)
(make-equivalent /$ quotient)
(make-equivalent -$ difference)
;--- Section I - functions and macros
;--- max - arg1 arg2 ... : sequence of numbe
(cond ((greaterp (arg i) max) (setq max (arg i)))))))
; catch is now a macro which translates to (*catch 'tag form)
`(*catch ',(caddr l) ,(cadr l))))
`(*throw ',(caddr l) ,(cadr l))))
; - 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)))
; - 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
(defmacro signp (tst val)
(setq tst (cond ((eq 'l tst) `(minusp signp-arg))
((eq 'le tst) `(not (greaterp signp-arg 0)))
((eq 'e tst) `(zerop signp-arg))
((eq 'n tst) `(not (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))
; 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) (break)))
(signal 8 'sys:fpeint-serv)
;---- Section IV - interrupt handlers
(cond ((null (boundp '$gcprint))
(setq $gcprint nil))) ; dont print gc stats by default
(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.
(lambda (space tottime gctime)
(do ((curtypl (cond ((memq space '(list fixnum ))
(t (cons space '(list fixnum))))
((null curtypl) (print 'ut:)
(print (max 0 (quotient (times 100 (difference tottime gctime))
(setq temp (car curtypl))
(cond ((greaterp (cadr (opval temp)) 0)
(print (cadr (opval temp)))
(declare (special gcafter-panic-mode $gccount$ $gc_midlim $gc_minalloc
$gc_pct $gc_lowlim $gcprint ptimeatlastgc))
(setq gcafter-panic-mode nil)
(setq ptimeatlastgc (ptime))
;--- 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 thisptime diffptime difftottime
(cond ((null s) (return)))
(cond ((null (boundp '$gccount$)) (setq $gccount$ 0)))
(setq $gccount$ (1+ $gccount$))
difftottime (max (difference (car thisptime)
diffgctime (difference (cadr thisptime)
; pct is the percentage of space used
(setq pct (quotient (times 100 (car x))
(max 1 (times (cadr x) (caddr x)))))
(cond (gcafter-panic-mode
(patom "[Storage space totally exausted]")
(error "Space exausted when allocating "
((greaterp pct $gc_midlim)
(max $gc_minalloc (fix (times $gc_pct (cadr x)))))
((greaterp pct $gc_lowlim)
(cond ((and (null gcafter-panic-mode) (greaterp amt-to-allocate
(cond ((atom (errset (allocate (car s) amt-to-allocate)))
(patom "[Now in storage allocation panic mode]")
(setq gcafter-panic-mode t)))))
(cond ($gcprint (prtpagesused (car s) difftottime diffgctime)
(comment (cond ((and (getd 'gcstat)
;----Section V - the functions
; returns t if x is a bignum
(def bigp (lambda (arg) (equal (type arg) 'bignum)))
; ignores the rest of the things in the list
;--- 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 '\% 'vescape) ; escape character
(setsyntax '\\ 'vcharacter) ; normal character
(setsyntax '\` 'vcharacter) ; normal character
(setsyntax '\, 'vcharacter) ; normal character
(sstatus uctolc t) ; one case
;--- cvttomaclisp - converts the readtable to a maclisp character syntax
(setsyntax '\/ 'vescape) ; escape
(setsyntax '\\ 'vcharacter) ; normal char
(setsyntax '\[ 'vcharacter) ; normal char
(setsyntax '\] 'vcharacter) ; normal char
(declare (special readtable))
;--- cvttoucilisp - converts the readtable to a ucilisp character syntax
(sstatus uctolc t) ; upper case to lower case
; change backquote character.
; to ` and ! and !@ from ` , and ,@
(setsyntax '\! 'splicing (get '\, readtable))
(setsyntax '\, 'vcharacter)
; ~ as comment character, not ; and / instead of \ for escape
(setsyntax '\~ 'splicing 'zapline)
(setsyntax '\; 'vcharacter)
(setsyntax '\\ 'vcharacter)))
;--- cvttofranzlisp - converts the readtable to the standard franz readtable
; this just does the obvious conversions, assuming that the user was
; in the maclisp syntax before.
(setsyntax '\/ 'vcharacter)
(setsyntax '\[ 'vleft-bracket)
(setsyntax '\] 'vright-bracket)
;--- 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)
(t (error " wrong number of args to delete "
(cons 'delete (listify nargs)))))
(setq val (arg 1) lst (arg 2))
(cond ((and (atom lst) (not (null lst)))
(error " non-list arg to delete "
(cons 'delete (listify nargs)))))
(cond ((or (atom lst) (zerop nmb))
(t (setq cur (cdr cur))))
; same as delete except eq is used for testing.
(prog (val lst cur ret nmb)
(t (error " wrong number of args to delq "
(cons 'delq (listify nargs)))))
(setq val (arg 1) lst (arg 2))
(cond ((and (atom lst) (not (null lst)))
(error " non-list arg to delq "
(cons 'delq (listify nargs)))))
(cond ((or (atom lst) (zerop nmb))
(t (setq cur (cdr cur))))
;--- 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)))
(declare (special edit_file))
(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.
(res "" (concat res " " (car xx))))
((null xx) (*process res)))))
;--- 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.
(error "expt: Can't compute number to a bignum power" 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))))
;--- ffasl :: fasl in a fortran file
; 2 - entry : entry point name
; 4 - disc : optional discipline
; 5 - lib ; optional library specifier
(defun ffasl (fnam entry fcn &optional (disc 'subroutine) (lib " "))
(cfasl fnam entry fcn disc (concat lib " -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)
(patom "14 - step package; 15 - fixit package") (terpr)
(patom "b - special symbols; c - gc & debugging & top level ")(terpr))
((or (and (numberp fcn) (lessp fcn 16) (greaterp fcn -1))
(ncons (concat "/usr/ucb/ul "
fcn ".r | /usr/ucb/more -f" ))))
(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 (concat lisp-library-directory
(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/ul "
" | /usr/ucb/more -f \"+/("
; (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 ((> n 128) (error "hunk: size is too big" n))
((eq n 0) (return nil)) ; hunk of zero length
(t (setq size (1- (haulong (1- n))))))
(setq size (*makhunk size))
(*rplacx argnum size (arg (1+ argnum))))
; returns the last cons cell of the list, NOT the last element
; load will either load (read-eval) or fasl in the file.
; it is affected by these global flags
; tilde-expansion :: expand filenames preceeded by ~ just like
; csh does (we do the expansion here so each i/o function we call
; doesn't have to do it).
; load-most-recent :: if there is a choice between a .o and a .l file,
(declare (localf load-a-file))
(declare (special gcdisable load-most-recent tilde-expansion))
(or (boundp 'load-most-recent) (setq load-most-recent nil))
(or (boundp 'tilde-expansion) (setq tilde-expansion t))
(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 shortname explf
(cond (tilde-expansion (setq filename (tilde-expand filename))))
; determine the length of the filename, ignoring the possible
; list of directories. set explf to the reversed exploded filename
(setq len (do ((xx (setq explf (nreverse (exploden filename))) (cdr xx))
(cond ((eq #// (car xx)) (return i)))))
(cond ((eq (cadr explf) #/.)
(cond ((eq (car explf) #/o)
; a short name is less or equal 12 characters. If a name is not
; short, then load will not try to append .l or .o
(cond ((< len 13) (setq shortname t)))
(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) "/"))))
(setq faslfile (concat pred filename ".o")))
(setq loadfile (concat pred filename ".l"))))
; both an object and a source file exist.
; load the last modified one (fasl wins in ties)
(let ((faslstat (filestat faslfile))
(loadstat (filestat loadfile)))
(cond ((< (filestat:mtime faslstat)
(filestat:mtime loadstat))
(return (load-a-file loadfile)))
(concat pred filename ".o"))))
(return (fasl-a-file name (car fasl-args)
(concat pred filename ".l"))))
(return (load-a-file name)))
((probef (setq name (concat pred filename)))
(t (return (load-a-file name)))))))
(cond ((probef (setq name (concat pred filename)))
(return (fasl-a-file name (car fasl-args)
(cond ((probef (setq name (concat pred filename)))
(return (load-a-file name)))))))))
;--- tilde-expand :: given a ~filename, expand it
(defun tilde-expand (name)
(cond ((or (symbolp name) (stringp name))
(cond ((eq (getcharn name 1) #/~)
(let ((form (exploden name)))
(do ((xx (cdr form) (cdr xx))
((or (null xx) (eq (car xx) #//))
;; if this is the current user, just get value
;; from environment variable HOME
(equal (setq res (implode (nreverse res)))
(setq val (getenv 'HOME)))
(t (setq val (username-to-dir res))))
(error "tilde-expand: unknown user " res))
(t (concat val (implode xx)))))
(setq res (cons (car xx) res)))))
(t (error "tilde-expand: illegal argument " name))))
; The arguments are just like those to fasl. This fasl's a file
; and if the translink's are set, it does the minimum work necessary to rebind
; the links (so that the new functions just fasl'ed in will be used).
(defun fasl-a-file (name map warnflag)
(let ((translinkarg (status translink)))
(cond ((and translinkarg (setq translinkarg (status translink)))
; if translink was set before and is still set
(cond ((eq translinkarg t)
(sstatus translink nil) ; clear all links
(sstatus translink t)) ; set to make links
(sstatus translink on) ; recompute all links
(declare (special $ldprint)) ; print message before loading
(declare (special prinlevel prinlength))
(defun load-a-file (fname)
(cond ($ldprint (patom "[load ")(patom fname)(patom "]")(terpr)))
(let ((translinkarg (status translink)))
(let ((Piport (infile fname))
; (gcdisable t) ; too dangerous: removed for now
; don't gc when loading, it slows things down
(do ((form (errset (read Piport eof)) (errset (read Piport eof)))
(lastform "<no form read successfully>"))
((eq eof (car form)) (close Piport) t)
(error "load aborted due to read error after form "
(t (setq lastform (car form))
(cond ((and translinkarg (setq translinkarg (status translink)))
; if translink was set before and is still set
(cond ((eq translinkarg t)
(sstatus translink nil) ; clear all links
(sstatus translink t)) ; set to make links
(sstatus translink on) ; recompute all links
(funcall 'sstatus (list 'load-search-path (list '|.| lisp-library-directory)))
;--- 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)))
; convert a list of fixnums to a bignum.
; there is a function bignum-to-list but it is written in C
(lambda (x) (cond (x (scons (car x) (list-to-bignum (cdr x))))
; 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))
(get nam 'macro-autoload))
(cond ((memq disc '(array lambda lexpr nil))
(cons nam (mapcar 'macroexpand (cdr form))))
(setq form (apply nam form))
(mapcar 'macroexpand (cddr 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 (1- n))))))
(cond ((minusp size) (return nil)))
(setq Hunk (*makhunk size))
; If it isn't a number, then try hunk on it
(t (return (apply 'hunk n))))))
;--- 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.
(cond ((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.
(cond ((lessp (arg i) min) (setq min (arg i)))))))
(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 eof) (read por eof)))
(cond ((dtpr x) (print (cadr x)))
; 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 (cond (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
(declare (localf exchange2))
(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)))
;--- *quo : returns integer part of x/y
; x and y must be fixnums.
(putd '*quo (getd 'quotient))
; returns (b . a) that is, it is an exchanged cons
(def xcons (lambda (a b) (cons b a)))
;--- mode lines, must be last lines of the file