Return to auxfns0.l CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / lisp / lib

Annotation of 3BSD/cmd/lisp/lib/auxfns0.l, revision 1.1

1.1     ! root        1: 
        !             2: (setsyntax '\; 'splicing 'zapline)
        !             3: 
        !             4: ;---------------- auxfns0 ---------------
        !             5: ; this file contains the definitions of the most common functions.
        !             6: ; It should only be loaded in Opus 30 Franz Lisp.
        !             7: ; These functions should be loaded into every lisp.
        !             8: ;
        !             9: ;------------------------------------------------
        !            10: ; preliminaries:
        !            11: 
        !            12: (eval-when (eval load)
        !            13:   (cond ((null (getd 'back=quotify)) (load 'backquote))))
        !            14: 
        !            15: (eval-when (compile)
        !            16:   (setq macros t))
        !            17: 
        !            18: 
        !            19: ;--- declare - ignore whatever is given, this is for the compiler
        !            20: ;
        !            21: (def declare (nlambda (x) nil))
        !            22: 
        !            23: ;-----------------------------------------------
        !            24: ; functions contained herein:
        !            25: 
        !            26: ; ----------------------------------
        !            27: ;      macros
        !            28: 
        !            29: ;--- catch form [tag]  
        !            30: ;  catch is now a macro which translates to (*catch 'tag form)
        !            31: ;
        !            32: (def catch
        !            33:   (macro (l)
        !            34:         `(*catch ',(caddr l) ,(cadr l))))
        !            35: ;--- throw form [tag]
        !            36: ;  throw isnow a macro
        !            37: ;
        !            38: (def throw
        !            39:   (macro (l)
        !            40:         `(*throw ',(caddr l) ,(cadr l))))
        !            41: 
        !            42: 
        !            43: ; defmacro for franz, written 20sep79 by jkf
        !            44: 
        !            45: (declare (special defmacrooptlist))
        !            46: 
        !            47: ;--- defmacro - name - name of macro being defined
        !            48: ;            - pattrn - formal arguments plus other fun stuff
        !            49: ;            - body   - body of the macro
        !            50: ; This is an intellegent macro creator.  The pattern may contain
        !            51: ; symbols which are formal paramters, lists which show how the
        !            52: ; actual paramters will appear in the args, and these key words
        !            53: ;  &rest name  - the rest of the args (or nil if there are no other args)
        !            54: ;               is bound to name
        !            55: ;  &optional name - bind the next arg to name if it exists, otherwise
        !            56: ;                  bind it to nil
        !            57: ;  &optional (name init) - bind the next arg to name if it exists, otherwise
        !            58: ;                  bind it to init evaluted. (the evaluation is done left
        !            59: ;                  to right for optional forms)
        !            60: ;  &optional (name init given) - bind the next arg to name and given to t
        !            61: ;                  if the arg exists, else bind name to the value of
        !            62: ;                  init and given to nil.
        !            63: ;
        !            64: ; Method of operation:
        !            65: ;  the list returned from defmcrosrc has the form ((cxxr name) ...)
        !            66: ;      where cxxr is the loc of the macro arg and name is it formal name
        !            67: ;  defmcrooptlist has the form ((initv cxxr name) ...)
        !            68: ; which is use for &optional args with an initial value.
        !            69: ;  here cxxr looks like cdd..dr which will test of the arg exists.
        !            70: ;
        !            71: ; the variable defmacro-for-compiling determines if the defmacro forms
        !            72: ; will be compiled. If it is t, then we return (progn 'compile (def xx..))
        !            73: ; to insure that it is compiled
        !            74: ;
        !            75: (cond ((null (boundp 'defmacro-for-compiling))   ; insure it has a value
        !            76:        (setq defmacro-for-compiling nil)))
        !            77: 
        !            78: (def defmacro
        !            79:   (macro (args)
        !            80:     ((lambda (tmp tmp2 defmacrooptlist body)
        !            81:        (setq tmp (defmcrosrch (caddr args) '(d r) nil)
        !            82:             body
        !            83:             `(def ,(cadr args)
        !            84:                   (macro (defmacroarg)
        !            85:                     ((lambda ,(mapcar 'cdr tmp)
        !            86:                              ,@(mapcar 
        !            87:                                   '(lambda (arg)
        !            88:                                      `(cond ((setq ,(caddr arg)
        !            89:                                                    (,(cadr arg) 
        !            90:                                                      defmacroarg))
        !            91:                                              ,@(cond ((setq tmp2 (cadddr arg))
        !            92:                                                       `((setq ,tmp2 t))))
        !            93:                                              (setq ,(caddr arg)
        !            94:                                                    (car ,(caddr arg))))
        !            95:                                             (t (setq ,(caddr arg)
        !            96:                                                      ,(car arg)))))
        !            97:                                        defmacrooptlist)
        !            98:                              ,@(cdddr args))
        !            99:                      ,@(mapcar '(lambda (arg) 
        !           100:                                         (cond ((car arg)
        !           101:                                                `(,(car arg) defmacroarg))))
        !           102:                               tmp)))))
        !           103:             (cond (defmacro-for-compiling `(progn 'compile ,body))
        !           104:                   (t body)))
        !           105:      nil nil nil nil)))
        !           106: 
        !           107: (def defmcrosrch
        !           108:   (lambda (pat form sofar)
        !           109:          (cond ((null pat) sofar)
        !           110:                ((atom pat) (cons (cons (concatl `(c ,@form)) pat)
        !           111:                                  sofar))
        !           112:                ((eq (car pat) '&rest)
        !           113:                 (defmcrosrch (cadr pat) form sofar))
        !           114:                ((eq (car pat) '&optional)
        !           115:                 (defmcrooption (cdr pat) form sofar))
        !           116:                (t (append (defmcrosrch (car pat) (cons 'a form) nil)
        !           117:                           (defmcrosrch (cdr pat) (cons 'd form) sofar))))))
        !           118: 
        !           119: (def defmcrooption
        !           120:   (lambda (pat form sofar)
        !           121:     ((lambda (tmp tmp2)
        !           122:          (cond ((null pat) sofar)
        !           123:                ((eq (car pat) '&rest)
        !           124:                 (defmcrosrch (cadr pat) form sofar))
        !           125:                (t (cond ((atom (car pat))
        !           126:                          (setq tmp (car pat)))
        !           127:                         (t (setq tmp (caar pat))
        !           128:                            (setq defmacrooptlist 
        !           129:                                  `((,(cadar pat) 
        !           130:                                        ,(concatl `(c ,@form))
        !           131:                                        ,tmp
        !           132:                                        ,(setq tmp2 (caddar pat)))
        !           133:                                    . ,defmacrooptlist))))
        !           134:                   (defmcrooption 
        !           135:                        (cdr pat) 
        !           136:                        (cons 'd form) 
        !           137:                        `( (,(concatl `(ca ,@form)) . ,tmp)
        !           138:                           ,@(cond (tmp2 `((nil . ,tmp2))))
        !           139:                          . ,sofar)))))
        !           140:      nil nil)))
        !           141: 
        !           142: ;-----------------
        !           143: ; functions which must be defined first
        !           144: 
        !           145: (def FPEINT 
        !           146:       (lambda (x$) (patom '"Floating Exception:  ") (drain poport) (break)))
        !           147: 
        !           148: (def INT 
        !           149:       (lambda (dummy) (patom '"Interrupt:  ") (drain poport) (break)))
        !           150: 
        !           151: 
        !           152: (signal 8 'FPEINT)
        !           153: (signal 2 'INT)
        !           154: 
        !           155: 
        !           156: (cond ((null (boundp '$gcprint$))
        !           157:        (setq $gcprint$ nil)))          ; dont print gc stats by default
        !           158: 
        !           159: (cond ((null (boundp '$gccount$))
        !           160:        (setq $gccount$ 0)))
        !           161: 
        !           162: ;--- prtpagesused - [arg] : type of page allocated last time.
        !           163: ;      prints a summary of pages used for certain selected types
        !           164: ;      of pages.  If arg is given we put a star beside that type
        !           165: ;      of page.  This is normally called after a gc.
        !           166: ;
        !           167: (def prtpagesused
        !           168:   (nlambda (arg)
        !           169:          (patom '"[")
        !           170:          (do ((curtypl '(list fixnum symbol string ) (cdr curtypl))
        !           171:               (temp))
        !           172:              ((null curtypl) (patom '"]") (terpr poport))
        !           173:              (setq temp (car curtypl))
        !           174:              (cond ((greaterp (cadr (opval temp)) 0)
        !           175:                     (cond ((eq (car arg) temp)
        !           176:                            (patom '*)))
        !           177:                     (patom temp)
        !           178:                     (patom '":")
        !           179:                     (print (cadr (opval temp)))
        !           180:                     (patom '"{")
        !           181:                     (print (fix (quotient 
        !           182:                                  (times 100.0
        !           183:                                         (car (opval temp)))
        !           184:                                  (times (cadr (opval temp))
        !           185:                                         (caddr (opval temp))))))
        !           186:                     (patom '"%}")
        !           187:                     (patom '"; "))))))
        !           188: 
        !           189: ;--- gcafter - [s] : type of item which ran out forcing garbage collection.
        !           190: ;      This is called after each gc.
        !           191: ;
        !           192: (def gcafter 
        !           193:   (nlambda (s)
        !           194:           (prog (x)
        !           195:                 (cond ((null s) (return)))
        !           196:                 (cond ((null (boundp '$gccount$)) (setq $gccount$ 0)))
        !           197:                 (setq $gccount$ (add1 $gccount$))
        !           198:                 (setq x (opval (car s)))
        !           199:                 (cond ((greaterp 
        !           200:                         (quotient (car x)
        !           201:                                   (times 1.0 (cadr x) (caddr x)))
        !           202:                         .65)
        !           203:                        (allocate (car s) 20))
        !           204:                       (t (allocate (car s) 10)))
        !           205:                 (cond ($gcprint$ (apply 'prtpagesused s))))))
        !           206: 
        !           207: ;--------------------------------
        !           208: ; functions in alphabetical order
        !           209: 
        !           210: ;--- append - x : list
        !           211: ;          - y : list 
        !           212: ;
        !           213: (def append2args 
        !           214:   (lambda (x y)
        !           215:          (prog (l l*)
        !           216:                (cond ((null x) (return y))
        !           217:                      ((atom x) (err (list '"Non-list to append:" x))))
        !           218:                (setq l* (setq l (cons (car x) nil)))
        !           219:        loop    (cond ((atom x) (err (list '"Non-list to append:" x)))
        !           220:                      ((setq x (cdr x))
        !           221:                       (setq l* (cdr (rplacd l* (cons (car x) nil))))
        !           222:                       (go loop)))
        !           223:                (rplacd l* y)
        !           224:                (return l))))
        !           225: 
        !           226: (def append
        !           227:   (lexpr (nargs)
        !           228:         (cond ((zerop nargs) nil)
        !           229:               (t (do ((i (sub1 nargs) (sub1 i))
        !           230:                       (res (arg nargs)))
        !           231:                      ((zerop i) res)
        !           232:                      (setq res (append2args (arg i) res)))))))
        !           233: 
        !           234: 
        !           235: 
        !           236: ;--- append1 - x : list
        !           237: ;           - y : lispval
        !           238: ;      puts y at the end of list x
        !           239: ;
        !           240: (def append1 (lambda (x y) (append x (list y))))
        !           241: 
        !           242: 
        !           243: ;--- assoc - x : lispval
        !           244: ;         - l : list
        !           245: ;      l is a list of lists. The list is examined and the first
        !           246: ;      sublist whose car equals x is returned.
        !           247: ;
        !           248: (def assoc
        !           249:   (lambda (val alist)
        !           250:          (do ((al alist (cdr al)))
        !           251:              ((null al) nil)
        !           252:              (cond ((equal val (caar al)) (return (car al)))))))
        !           253: 
        !           254: ; sassoc and sassq, silly relatives from lisp 1.5 of assoc
        !           255: ;
        !           256: 
        !           257: (defun sassoc(x y z)
        !           258:   (or (assoc x y)
        !           259:       (apply z nil)))
        !           260: (defun sassq(x y z)
        !           261:   (or (assq x y)
        !           262:       (apply z nil)))
        !           263: 
        !           264: ;--- bigp - x : lispval
        !           265: ;      returns t if x is a bignum
        !           266: ;
        !           267: (def bigp (lambda (arg) (equal (type arg) 'bignum)))
        !           268: 
        !           269: ;--- comment - any
        !           270: ;      ignores the rest of the things in the list
        !           271: (def comment
        !           272:   (nlambda (x) 'comment))
        !           273: 
        !           274: ;--- concatl - l : list of atoms
        !           275: ;      returns the list of atoms concatentated
        !           276: ;
        !           277: (def concatl
        !           278:  (lambda (x) (apply 'concat x)))
        !           279: 
        !           280: 
        !           281: 
        !           282: ;--- copy - l : list (will work if atom but will have no effect)
        !           283: ;      makes a copy of the list.
        !           284: ;
        !           285: (def copy 
        !           286:   (lambda (l)
        !           287:          (cond ((atom l) l)
        !           288:                (t (cons (copy (car l)) (copy (cdr l)))))))
        !           289: 
        !           290: 
        !           291: ;--- cvttomaclisp - converts the readtable to a maclisp character syntax
        !           292: ;
        !           293: (def cvttomaclisp
        !           294:   (lambda nil
        !           295:          (setsyntax '\| 138.)          ; double quoting char
        !           296:          (setsyntax '\/ 143.)          ; escape
        !           297:          (setsyntax '\\ 2)             ; normal char
        !           298:          (setsyntax '\" 2)             ; normal char
        !           299:          (setsyntax '\[ 2)             ; normal char
        !           300:          (setsyntax '\] 2)             ; normal char
        !           301:          (sstatus uctolc t)))
        !           302: 
        !           303: 
        !           304: ;--- defun - standard maclisp function definition form.
        !           305: ;
        !           306: (def defun 
        !           307:        (macro (l)
        !           308:             (prog (name type arglist body)
        !           309:                   (setq name (cadr l) l (cddr l))
        !           310:                   (cond ((null (car l)) (setq type 'lambda))
        !           311:                         ((eq 'fexpr (car l)) (setq type 'nlambda l (cdr l)))
        !           312:                         ((eq 'expr (car l))  (setq type 'lambda l (cdr l)))
        !           313:                         ((eq 'macro (car l)) (setq type 'macro l (cdr l)))
        !           314:                         ((atom (car l)) (setq type 'lexpr 
        !           315:                                               l `((,(car l)) ,@(cdr l))))
        !           316:                         (t (setq type 'lambda)))
        !           317:                   (return `(def ,name 
        !           318:                                 (,type ,@l))))))
        !           319: 
        !           320: 
        !           321: ;--- defprop - like putprop except args are not evaled
        !           322: ;
        !           323: (def defprop 
        !           324:     (nlambda (argl)
        !           325:        (putprop (car argl) (cadr argl) (caddr argl) )))
        !           326: 
        !           327: ;--- delete - val - s-expression
        !           328: ;          - list - list to delete fromm
        !           329: ;          -[n] optional count , if not specified, it is infinity
        !           330: ; delete removes every thing in the top level of list which equals val
        !           331: ; the list structure is modified
        !           332: ;
        !           333: (def delete
        !           334:   (lexpr (nargs)
        !           335:         ((lambda (val list n)
        !           336:                  (cond ((or (atom list) (zerop n)) list)
        !           337:                        ((equal val (car list)) 
        !           338:                         (delete val (cdr list) (sub1 n)))
        !           339:                        (t (rplacd list (delete val (cdr list) n)))))
        !           340:          (arg 1) 
        !           341:          (arg 2) 
        !           342:          (cond ((equal nargs 3) (arg 3))
        !           343:                (t 99999999)))))
        !           344: 
        !           345: 
        !           346: ;--- delq   - val - s-expression
        !           347: ;          - list - list to delete fromm
        !           348: ;          -[n] optional count , if not specified, it is infinity
        !           349: ; delq removes every thing in the top level of list which eq's val
        !           350: ; the list structure is modified
        !           351: ;
        !           352: (def delq
        !           353:   (lexpr (nargs)
        !           354:         ((lambda (val list n)
        !           355:                  (cond ((or (atom list) (zerop n)) list)
        !           356:                        ((eq val (car list)) 
        !           357:                         (delq val (cdr list) (sub1 n)))
        !           358:                        (t (rplacd list (delq val (cdr list) n)))))
        !           359:          (arg 1) 
        !           360:          (arg 2) 
        !           361:          (cond ((equal nargs 3) (arg 3))
        !           362:                (t -1)))))
        !           363: 
        !           364: ;--- evenp : num   -  return 
        !           365: ;
        !           366: (def evenp
        !           367:   (lambda (n)
        !           368:          (cond ((not (zerop (boole 4 1 n))) t))))
        !           369: 
        !           370: ;--- ex [name] : unevaluated name of file to edit.
        !           371: ;      the ex editor is forked to edit the given file, if no
        !           372: ;      name is given the previous name is used
        !           373: ;
        !           374: (def ex 
        !           375:   (nlambda (x) 
        !           376:           (prog (handy handyport bigname)
        !           377:                 (cond ((null x) (setq x (list edit_file)))
        !           378:                       (t (setq edit_file (car x))))             
        !           379:                 (setq bigname (concat (car x) '".l"))
        !           380:                 (cond ((setq handyport (car (errset (infile bigname) nil)))
        !           381:                        (close handyport)
        !           382:                        (setq handy bigname))
        !           383:                       (t (setq handy (car x))))
        !           384:                 (setq handy (concat '"ex " handy))
        !           385:                 (setq handy (list 'process handy))
        !           386:                 (eval handy))))
        !           387: 
        !           388: ;--- exec - arg1 [arg2 [arg3 ...] ] unevaluated atoms
        !           389: ;      A string of all the args concatenated together seperated by 
        !           390: ;      blanks is forked as a process.
        !           391: ;
        !           392: (def exec
        !           393:  (nlambda ($list)
        !           394:    (prog ($handy)
        !           395:          (setq $handy (quote ""))
        !           396:     loop (cond ((null $list)
        !           397:                 (return (eval (list (quote process) $handy))))
        !           398:                (t (setq $handy
        !           399:                         (concat (concat $handy (car $list))
        !           400:                                 (quote " ")))
        !           401:                   (setq $list (cdr $list))
        !           402:                   (go loop))))))
        !           403: 
        !           404: 
        !           405: ;--- exl - [name] : unevaluated name of file to edit and load.
        !           406: ;      If name is not given the last file edited will be used.
        !           407: ;      After the file is edited it will be `load'ed into lisp.
        !           408: ;
        !           409: (def exl (nlambda (fil) (cond (fil (setq edit_file (car fil))))
        !           410:                        (eval (list 'ex edit_file)) 
        !           411:                        (load edit_file)))
        !           412: 
        !           413: ;----- explode functions -------
        !           414: ; These functions, explode , explodec and exploden, implement the 
        !           415: ; maclisp explode functions completely.
        !           416: ; They have a similar structure and are written with efficiency, not
        !           417: ; beauty in mind (and as a result they are quite ugly)
        !           418: ; The basic idea in all of them is to keep a pointer to the last
        !           419: ; thing added to the list, and rplacd the last cons cell of it each time.
        !           420: ;
        !           421: ;--- explode - arg : lispval
        !           422: ;      explode returns a list of characters which print would use to
        !           423: ; print out arg.  Slashification is included.
        !           424: ;
        !           425: (def explode
        !           426:   (lambda (arg)
        !           427:          (cond ((atom arg) (aexplode arg))
        !           428:                (t (do ((ll (cdr arg) (cdr ll))
        !           429:                        (sofar (setq arg (cons '"(" (explode (car arg)))))
        !           430:                        (xx))
        !           431:                       ((cond ((null ll) (rplacd (last sofar) (ncons '")" )) 
        !           432:                               t)
        !           433:                              ((atom ll) (rplacd (last sofar)
        !           434:                                                 `(" " "." " " ,@(explode ll) 
        !           435:                                                     ,@(ncons '")")))
        !           436:                               t))
        !           437:                        arg)
        !           438:                       (setq xx (last sofar)
        !           439:                             sofar (cons '" " (explode (car ll))))
        !           440:                       (rplacd xx sofar))))))
        !           441: 
        !           442: ;--- explodec - arg : lispval
        !           443: ; returns the list of character which would be use to print arg assuming that
        !           444: ; patom were used to print all atoms.
        !           445: ; that is, no slashification would be used.
        !           446: ;
        !           447: (def explodec
        !           448:   (lambda (arg)
        !           449:          (cond ((atom arg) (aexplodec arg))
        !           450:                (t (do ((ll (cdr arg) (cdr ll))
        !           451:                        (sofar (setq arg (cons '"(" (explodec (car arg)))))
        !           452:                        (xx))
        !           453:                       ((cond ((null ll) (rplacd (last sofar) (ncons '")" )) 
        !           454:                               t)
        !           455:                              ((atom ll) (rplacd (last sofar)
        !           456:                                                 `(" " "." " " ,@(explodec ll) 
        !           457:                                                     ,@(ncons '")")))
        !           458:                               t))
        !           459:                        arg)
        !           460:                       (setq xx (last sofar)
        !           461:                             sofar (cons '" " (explodec (car ll))))
        !           462:                       (rplacd xx sofar))))))
        !           463: 
        !           464: ;--- exploden - arg : lispval
        !           465: ;      returns a list just like explodec, except we return fixnums instead
        !           466: ; of characters.
        !           467: ;
        !           468: (def exploden
        !           469:   (lambda (arg)
        !           470:          (cond ((atom arg) (aexploden arg))
        !           471:                (t (do ((ll (cdr arg) (cdr ll))
        !           472:                        (sofar (setq arg (cons 40. (exploden (car arg)))))
        !           473:                        (xx))
        !           474:                       ((cond ((null ll) (rplacd (last sofar) (ncons 41.)) 
        !           475:                               t)
        !           476:                              ((atom ll) (rplacd (last sofar)
        !           477:                                                 `(32. 46. 32. ,@(exploden ll) 
        !           478:                                                     ,@(ncons 41.)))
        !           479:                               t))
        !           480:                        arg)
        !           481:                       (setq xx (last sofar)
        !           482:                             sofar (cons 32. (exploden (car ll))))
        !           483:                       (rplacd xx sofar))))))
        !           484: 
        !           485: ;-- expt  - x
        !           486: ;        - y
        !           487: ;
        !           488: ;         y
        !           489: ; returns x
        !           490: ;
        !           491: (defun expt(x y)
        !           492:   (cond ((or (floatp y) (lessp y 0))
        !           493:         (exp(times y (log x)))) ; bomb out for (-3)^4 or (-3)^4.0 or 0^y.
        !           494:        (t ; y is integer, y>= 0
        !           495:           (prog (res)
        !           496:                 (setq res 1)
        !           497:            loop
        !           498:                 (cond ((equal y 0) (return res))
        !           499:                       ((oddp y)(setq res (times  res x) y (sub1 y)))
        !           500:                       (t (setq x (times x x) y (quotient y 2))))
        !           501:                 (go loop)))))
        !           502: 
        !           503: 
        !           504: ;--- expt
        !           505: ; old
        !           506: '(defun expt(x y)
        !           507:   (prog (res)
        !           508:        (setq res 1)
        !           509:  loop  (cond ((equal y 0) (return res))
        !           510:              (t (setq res (times x res)
        !           511:                       y (sub1 y))))
        !           512:        (go loop)))
        !           513: 
        !           514: ;--- fixp - l : lispval
        !           515: ;      returns t if l is a fixnum or bignum
        !           516: ;
        !           517: (defun fixp (x) (or (equal (type x) 'fixnum)
        !           518:                    (equal (type x) 'bignum)))
        !           519: 
        !           520: 
        !           521: ;--- floatp - l : lispval
        !           522: ;      returns t if l is a flonum
        !           523: ;
        !           524: (defun floatp (x) (equal 'flonum (type x)))
        !           525: 
        !           526: 
        !           527: ;--- getchar,getcharn   - x : atom
        !           528: ;                      - n : fixnum
        !           529: ; returns the n'th character of x's pname (the first corresponds to n=1)
        !           530: ; if n is out of bounds, nil is return
        !           531: (def getchar
        !           532:   (lambda (x n)
        !           533:          (cond ((lessp n 1) nil)
        !           534:                (t (do ((i n (sub1 i))
        !           535:                        (lis (aexplodec x) (cdr lis)))
        !           536:                       ((cond ((null lis) (return nil))
        !           537:                              ((equal i 1) (return (car lis))))))))))
        !           538: 
        !           539: (def getcharn
        !           540:   (lambda (x n)
        !           541:          (cond ((lessp n 1) nil)
        !           542:                (t (do ((i n (sub1 i))
        !           543:                        (lis (aexploden x) (cdr lis)))
        !           544:                       ((cond ((null lis) (return nil))
        !           545:                              ((equal i 1) (return (car lis))))))))))
        !           546: 
        !           547: 
        !           548: (def getl 
        !           549:   (lambda (atm lis)
        !           550:          (do ((ll (cond ((atom atm) (plist atm))
        !           551:                         (t (cdr atm)))
        !           552:                   (cddr ll)))
        !           553:              ((null ll) nil)
        !           554:              (cond ((member (car ll) lis) (return ll))))))
        !           555: 
        !           556: ;--- last - l : list
        !           557: ;      returns the last cons cell of the list, NOT the last element
        !           558: ;
        !           559: (def last 
        !           560:   (lambda (a)
        !           561:          (do ((ll a (cdr ll)))
        !           562:              ((null (cdr ll))  ll))))
        !           563: 
        !           564: ;--- include - read in the file name given
        !           565: ;
        !           566: (def include (nlambda (l) (load (car l))))
        !           567: 
        !           568: ;--- length - l : list
        !           569: ;      returns the number of elements in the list.
        !           570: ;
        !           571: (def length 
        !           572:   (lambda ($l$)
        !           573:          (cond ((atom $l$) 0))
        !           574:          (do ((ll $l$ (cdr ll))
        !           575:               (i 0 (add1 i)))
        !           576:              ((null ll) i))))
        !           577: 
        !           578: 
        !           579: ;--- let - vb - binding forms
        !           580: ;       - bd - body
        !           581: ;      this macro allow one to express lambda binding for certain
        !           582: ;      variables and keep the information together.
        !           583: ;      the binding forms have this form
        !           584: ;        (vrbl (vrbl2 val2) )
        !           585: ;      here vrbl will be bound to nil, and vrbl2 will be bound to the
        !           586: ;      result of evaluating val2
        !           587: ;      the general form using let is
        !           588: ;      (let (vrbl1 (vrbl2 val2))  
        !           589: ;           .. body ..
        !           590: ;      )
        !           591: ;
        !           592: (def let
        !           593:   (macro (l)
        !           594:         `((lambda ,(mapcar '(lambda (x) (cond ((atom x) x)
        !           595:                                               (t (car x))))
        !           596:                            (cadr l))
        !           597:                   ,@(cddr l))
        !           598:           ,@(mapcar '(lambda (x) (cond ((atom x) nil)
        !           599:                                       (t (cadr x))))
        !           600:                    (cadr l)))))
        !           601: 
        !           602:                   
        !           603: ;--- listify : n  - integer
        !           604: ;      returns a list of the first n args to the enclosing lexpr if
        !           605: ; n is positive, else returns the last -n args to the lexpr if n is
        !           606: ; negative.
        !           607: ;
        !           608: (def listify 
        !           609:   (macro (lis)
        !           610:         `(let ((n ,(cadr lis)))
        !           611:               (cond ((minusp n)
        !           612:                      (do ((i (arg nil)  (1- i))
        !           613:                           (result nil (cons (arg i) result)))
        !           614:                          ((< i (+ (arg nil) n  1)) result) ))
        !           615:                     (t (do ((i n  (1- i))
        !           616:                             (result nil (cons (arg i) result)))
        !           617:                            ((< i 1) result) ))))))
        !           618:         
        !           619: ;--- macroexpand - form 
        !           620: ;      expands out all macros it can
        !           621: ;
        !           622: (def macroexpand
        !           623:   (lambda (form)
        !           624:     (prog nil
        !           625:   top (cond ((atom form) (return form))
        !           626:            ((atom (car form))
        !           627:             (return
        !           628:              (let ((nam (car form)) def disc)
        !           629:                   (setq def (getd nam))
        !           630:                   (setq disc (cond ((bcdp def) (getdisc def))
        !           631:                                    (t (car def))))
        !           632:                   (cond ((memq disc '(lambda lexpr nil))
        !           633:                          (cons nam (mapcar 'macroexpand (cdr form))))
        !           634:                         ((eq disc 'nlambda) form)
        !           635:                         ((eq disc 'macro)
        !           636:                          (setq form 
        !           637:                                (apply (cond ((bcdp def)
        !           638:                                              (mfunction (getentry def)
        !           639:                                                         'nlambda))
        !           640:                                             (t (cons 'nlambda
        !           641:                                                      (cdr def))))
        !           642:                                       form))
        !           643:                          (go top))))))
        !           644:            (t (return (cons (macroexpand (car form))
        !           645:                             (mapcar 'macroexpand (cdr form)))))))))
        !           646: 
        !           647: 
        !           648: ;--- max - arg1 arg2 ... : sequence of numbe
        !           649: ;      returns the maximum
        !           650: ;
        !           651: (def max
        !           652:   (lexpr (nargs)
        !           653:         (do ((i nargs (sub1 i))
        !           654:              (max (arg 1)))
        !           655:             ((lessp i 2) max)
        !           656:             (cond ((greaterp (arg i) max) (setq max (arg i)))))))
        !           657: 
        !           658: 
        !           659: 
        !           660: 
        !           661: ;--- member - VAL : lispval
        !           662: ;          - LIS : list
        !           663: ;      returns that portion of LIS beginning with the first occurance
        !           664: ;      of VAL  if  VAL is found at the top level of list LIS.
        !           665: ;      uses equal for comparisons.
        !           666: ;
        !           667: (def member 
        !           668:   (lambda ($a$ $l$)
        !           669:          (do ((ll $l$ (cdr ll)))
        !           670:              ((null ll) nil)
        !           671:              (cond ((equal $a$ (car ll)) (return ll))))))
        !           672: 
        !           673: ;--- memq - arg : (probably a symbol)
        !           674: ;        - lis : list
        !           675: ; returns part of lis beginning with arg if arg is in lis
        !           676: ;      
        !           677: (def memq
        !           678:   (lambda ($a$ $l$)
        !           679:          (do ((ll $l$ (cdr ll)))
        !           680:              ((null ll) nil)
        !           681:              (cond ((eq $a$ (car ll)) (return ll))))))
        !           682: 
        !           683: ;--- min - arg1 ... numbers 
        !           684: ;
        !           685: ;      returns minimum of n numbers. 
        !           686: ;
        !           687: 
        !           688: (def min
        !           689:   (lexpr (nargs)
        !           690:         (do ((i nargs (sub1 i))
        !           691:              (min (arg 1)))
        !           692:             ((lessp i 2) min)
        !           693:             (cond ((lessp (arg i) min) (setq min (arg i)))))))
        !           694: 
        !           695: ;--- nconc - x1 x2 ...: lists
        !           696: ;      The cdr of the last cons cell of xi is set to xi+1.  This is the
        !           697: ;      structure modification version of append
        !           698: ;
        !           699: (def nconc 
        !           700:   (lexpr (nargs) 
        !           701:         (cond ((zerop nargs) nil)
        !           702:               (t (do ((i 1 nxt)
        !           703:                       (nxt 2 (add1 nxt))
        !           704:                       (res (cons nil (arg 1)))) 
        !           705:                      ((equal i nargs) (cdr res))
        !           706:                      (cond ((arg i) (rplacd (last (arg i)) (arg nxt)))
        !           707:                            (t (rplacd (last res) (arg nxt)))))))))
        !           708: 
        !           709: 
        !           710: ;--- nreverse - l : list
        !           711: ;      reverse the list in place
        !           712: ;
        !           713: (defun nreverse (x)
        !           714:     (cond ((null x) nil)
        !           715:          (t (n$reverse1 x nil))))
        !           716: 
        !           717: (defun n$reverse1 (x y)
        !           718:     (cond ((null (cdr x)) (rplacd x y))
        !           719:     (t (n$reverse1 (cdr x) (rplacd x y)))))
        !           720: 
        !           721: (def oddp
        !           722:   (lambda (n)
        !           723:          (cond ((not (zerop (boole 1 1 n))) t))))
        !           724: 
        !           725: ;--- plusp : x - number
        !           726: ; returns t iff x is greater than zero
        !           727: 
        !           728: (def plusp
        !           729:   (lambda (x)
        !           730:          (greaterp x 0)))
        !           731: 
        !           732: ;--- reverse : l - list
        !           733: ;      returns the list reversed using cons to create new list cells.
        !           734: ;
        !           735: (def reverse 
        !           736:   (lambda (x)
        !           737:          (cond ((null x) nil)
        !           738:                (t (do ((cur (cons (car x) nil) 
        !           739:                             (cons (car res) cur))
        !           740:                        (res (cdr x) (cdr res)))
        !           741:                       ((null res) cur))))))
        !           742: 
        !           743: ;--- shell - invoke a new c shell
        !           744: ;
        !           745: (def shell (lambda nil (process csh)))
        !           746: 
        !           747: 
        !           748: 
        !           749: ;--- signp - test - unevaluated atom
        !           750: ;         - value - evaluated value
        !           751: ; test can be l, le, e, n, ge or g   with the obvious meaning
        !           752: ; we return t if value compares to 0 by test
        !           753: (def signp
        !           754:   (macro (l)
        !           755:         `(signphelpfcn ',(cadr l) ,(caddr l))))
        !           756: 
        !           757: ;-- signphelpfcn
        !           758: (def signphelpfcn
        !           759:   (lambda (tst val)
        !           760:          (cond ((eq 'l tst) (minusp val 0))
        !           761:                ((eq 'le tst) (or (zerop val) (minusp val)))
        !           762:                ((eq 'e tst) (zerop val))
        !           763:                ((eq 'n tst) (not (zerop val)))
        !           764:                ((eq 'ge tst) (not (minusp val)))
        !           765:                ((eq 'g tst) (greaterp val 0)))))
        !           766: 
        !           767: 
        !           768: ;--- sload : fn - file name (must include the .l)
        !           769: ;      loads in the file printing each result as it is seen
        !           770: ;
        !           771: (def sload
        !           772:   (lambda (fn)
        !           773:          (prog (por)
        !           774:                (cond ((setq por (infile fn)))
        !           775:                      (t (patom '"bad file name")(terpr)(return nil)))
        !           776:                (do ((x (read por) (read por)))
        !           777:                    ((eq 'eof x))
        !           778:                    (print x)
        !           779:                    (eval x)))))
        !           780: 
        !           781: (defun sort(a fun)
        !           782:   (prog (n)
        !           783:        (cond   ((null a) (return nil)) ;no elements
        !           784:                (t
        !           785:                 (setq n (length a))
        !           786:                 (do i 1  (add1 i) (greaterp i n)(sorthelp a fun))
        !           787:                 (return a) ))))
        !           788: 
        !           789: (defun sorthelp (a fun)
        !           790:   (cond ((null (cdr a)) a)
        !           791:         ((funcall fun (cadr a) (car a))  
        !           792:         (exchange2 a)
        !           793:         (sorthelp (cdr a) fun))
        !           794:        (t (sorthelp (cdr a) fun))))
        !           795: 
        !           796: (defun exchange2 (a)
        !           797:   (prog (temp)
        !           798:        (setq temp (cadr a))
        !           799:        (rplaca (cdr a) (car a))
        !           800:        (rplaca a temp)))
        !           801: 
        !           802: ;--- sublis: alst - assoc list ((a . val) (b . val2) ...)
        !           803: ;           exp  - s-expression
        !           804: ; for each atom in exp which corresponds to a key in alst, the associated
        !           805: ; value from alst is substituted.  The substitution is done by adding
        !           806: ; list cells, no struture mangling is done.  Only the minimum number
        !           807: ; of list cells will be created.
        !           808: ;
        !           809: (def sublis
        !           810:   (lambda (alst exp)
        !           811:      (let (tmp)
        !           812:          (cond ((atom exp) 
        !           813:                 (cond ((setq tmp (assoc exp alst))
        !           814:                        (cdr tmp))
        !           815:                       (t exp)))
        !           816:                ((setq tmp (sublishelp alst exp))
        !           817:                 (car tmp))
        !           818:                (t exp)))))
        !           819: 
        !           820: ;--- sublishelp : alst - assoc list
        !           821: ;                exp  - s-expression
        !           822: ; this function helps sublis work.  it is different from sublis in that
        !           823: ; it return nil if no change need be made to exp, or returns a list of
        !           824: ; one element which is the changed exp.
        !           825: ;
        !           826: (def sublishelp
        !           827:   (lambda (alst exp)
        !           828:      (let (carp cdrp)
        !           829:          (cond ((atom exp)
        !           830:                 (cond ((setq carp (assoc exp alst))
        !           831:                        (list (cdr carp)))
        !           832:                       (t nil)))
        !           833:                (t (setq carp (sublishelp alst (car exp))
        !           834:                         cdrp (sublishelp alst (cdr exp)))
        !           835:                   (cond ((not (or carp cdrp)) nil)             ; no change
        !           836:                         ((and carp (not cdrp))                 ; car change
        !           837:                          (list (cons (car carp) (cdr exp))))   
        !           838:                         ((and (not carp) cdrp)                 ; cdr change
        !           839:                          (list (cons (car exp) (car cdrp))))   
        !           840:                         (t                                     ; both change 
        !           841:                          (list (cons (car carp) (car cdrp))))))))))
        !           842: 
        !           843: 
        !           844: ;--- subst : new - sexp
        !           845: ;           old - sexp
        !           846: ;           patrn - sexp
        !           847: ; substitutes in patrn all occurances eq to old with new and returns the
        !           848: ; result
        !           849: ; MUST be put in the manual
        !           850: (def subst
        !           851:   (lambda (new old patrn)
        !           852:          (cond ((eq old patrn) new)
        !           853:                ((atom patrn) patrn)
        !           854:                (t (cons (subst new old (car patrn))
        !           855:                         (subst new old (cdr patrn)))))))
        !           856: 
        !           857: ;--- xcons : a - sexp
        !           858: ;           b - sexp
        !           859: ; returns (b . a)   that is, it is an exchanged cons
        !           860: ;
        !           861: (def xcons  (lambda (a b) (cons b a)))
        !           862: 
        !           863: ;---------------------------------------
        !           864: ; ARRAY functions .
        !           865: ;
        !           866: (def array
        !           867:   (macro ($lis$)
        !           868:         `(*array ',(cadr $lis$) ',(caddr $lis$) ,@(cdddr $lis$))))
        !           869: 
        !           870: 
        !           871: 
        !           872: ; array access function 
        !           873: 
        !           874: (def arracfun
        !           875:   (lambda (actlst ardisc)
        !           876:           (prog (diml ind val)
        !           877: 
        !           878:                 (setq actlst (mapcar 'eval actlst)
        !           879:                       diml   (getaux ardisc))
        !           880: 
        !           881:                 (cond ((null (equal (length actlst)
        !           882:                                     (length (cdr diml))))
        !           883:                        (break '"Wrong number of indexes to array ref"))
        !           884: 
        !           885:                       (t (setq ind (arrcomputeind (cdr actlst)
        !           886:                                                   (cddr diml)
        !           887:                                                   (car actlst))
        !           888:                                val (arrayref ardisc ind))
        !           889:                          (cond ((equal (car diml) t)
        !           890:                                 (setq val (eval val))))
        !           891:                          (return val))))))
        !           892: 
        !           893: 
        !           894: 
        !           895: 
        !           896: (def *array
        !           897:   (lexpr (nargs)
        !           898:           (prog (name type rtype dims size tname)
        !           899: 
        !           900:                 (setq name  (arg 1)
        !           901:                       type  (arg 2)
        !           902:                       rtype (cond ((or (null type)
        !           903:                                        (equal type t))
        !           904:                                    (setq type t)       ; nil is equiv to t
        !           905:                                    'value)
        !           906:                                   (t type))
        !           907:                       dims  (do ((i 3 (add1 i))
        !           908:                                  (res nil (cons (arg i) res)))
        !           909:                                 ((greaterp i nargs) (nreverse res)))
        !           910:                       size  (apply 'times dims))
        !           911: 
        !           912:                 (setq tname (marray (segment rtype size)
        !           913:                                     (getd 'arracfun)
        !           914:                                     (cons type dims)
        !           915:                                     size
        !           916:                                     (sizeof rtype)))
        !           917:                 (cond (name (set name tname)
        !           918:                             (putd name tname)))
        !           919:                 (return tname))))
        !           920: 
        !           921: (def arraycall
        !           922:   (nlambda ($$lis$$)
        !           923:           ; form (arraycall type name sub1 sub2 ... subn)
        !           924:           ((lambda (ardisc)
        !           925:                    (cond ((not (equal (car (getaux ardisc))) (car $$lis$$))
        !           926:                           (patom '" Type given arraycall:")
        !           927:                           (patom (car $$lis$$))
        !           928:                           (patom '" doesnt match array type:")
        !           929:                           (patom (car (getaux ardisc)))
        !           930:                           (break nil)))
        !           931:                    (apply (getaccess ardisc) 
        !           932:                           (list (cddr $$lis$$) ardisc)))
        !           933:            (eval (cadr $$lis$$)))))
        !           934:                                
        !           935:                       
        !           936:                        
        !           937: 
        !           938: ; function to compute the raw array index
        !           939: 
        !           940: (def arrcomputeind
        !           941:   (lambda (indl diml res)
        !           942:          (cond ((null diml) res)
        !           943:                (t (arrcomputeind (cdr indl)
        !           944:                                  (cdr diml)
        !           945:                                  (plus (times res (car diml))
        !           946:                                        (car indl)))))))
        !           947: 
        !           948: ; store  
        !           949: ;  we make store a macro to insure that all parts are evaluated at the
        !           950: ; right time even if it is compiled.
        !           951: ;  (store (foo 34 i) (plus r f))
        !           952: ; gets translated to
        !           953: ;  (storeintern foo (plus r f) (list 34 i))
        !           954: ; and storeintern is a lambda, so when foo is evaluated it will pass the
        !           955: ;      array descriptor to storeintern, so storeintern can look at the
        !           956: ;      aux part to determine the type of array.
        !           957: ;
        !           958: (defmacro store ( (arrname . indexes) value)
        !           959:   (cond ((eq 'funcall arrname) 
        !           960:         (setq arrname `(eval ,(car indexes))
        !           961:               indexes (cdr indexes))))
        !           962:   `(storeintern ,arrname ,value (list ,@indexes)))
        !           963: 
        !           964: (def storeintern
        !           965:   (lambda (arrnam vl actlst)
        !           966:           (prog (loc)
        !           967:                 (cond ((equal t (car (getaux arrnam)))
        !           968:                        (setq loc (arracfcnsimp actlst arrnam))
        !           969:                        (set loc vl))
        !           970: 
        !           971:                       (t (replace (apply arrnam actlst) vl)))
        !           972:                 (return vl))))
        !           973: 
        !           974: 
        !           975: (def arracfcnsimp
        !           976:   (lambda (indexes adisc)
        !           977:          (prog (dims)
        !           978:                (setq dims (cdr (getaux adisc)))
        !           979:                (cond ((null (equal (length indexes)
        !           980:                                    (length dims)))
        !           981:                       (break '"wrong number of indexes to array"))
        !           982:                      (t (setq dims (arrcomputeind (cdr indexes)
        !           983:                                                   (cdr dims)
        !           984:                                                   (car indexes)))))
        !           985:                (return (arrayref adisc dims)))))
        !           986: 
        !           987: (def arraydims (lambda (arg) (cond ((atom arg) (getaux (eval arg)))
        !           988:                                   ((arrayp arg) (getaux arg))
        !           989:                                   (t (break '"non array arg to arraydims")))))
        !           990: 
        !           991: ; fill array from list or array
        !           992: 
        !           993: (def fillarray
        !           994:   (lambda (arr lis)
        !           995:          (prog (maxv typept)
        !           996:                (cond ((atom arr) (setq arr (eval arr))))
        !           997: 
        !           998:                (cond ((atom lis)
        !           999:                       (setq lis (eval lis))
        !          1000:                       (return (fillarrayarray arr lis)))
        !          1001: 
        !          1002:                      ((arrayp lis) (return (fillarrayarray arr lis))))
        !          1003: 
        !          1004:                (setq maxv (sub1 (getlength arr))
        !          1005:                      typept (cond ((equal t (car (getaux arr)))
        !          1006:                                    t)
        !          1007:                                   (t nil)))
        !          1008:                (do ((ls lis)
        !          1009:                     (i 0 (add1 i)))
        !          1010:                    ((greaterp i maxv))
        !          1011: 
        !          1012:                    (cond (typept (set (arrayref arr i) (car ls)))
        !          1013:                          (t (replace (arrayref arr i) (car ls))))
        !          1014: 
        !          1015:                    (cond ((cdr ls) (setq ls (cdr ls))))))))
        !          1016: 
        !          1017: (def fillarrayarray
        !          1018:   (lambda (arrto arrfrom)
        !          1019:          (prog (maxv)
        !          1020:                (setq maxv (sub1 (min (getlength arrto)
        !          1021:                                      (getlength arrfrom))))
        !          1022:                (do ((i 0 (add1 i)))
        !          1023:                    ((greaterp i maxv))
        !          1024:                    (replace (arrayref arrto i) (arrayref arrfrom i))))))
        !          1025: 
        !          1026: ;----------------------
        !          1027: ; equivalences 
        !          1028: 
        !          1029: (putd 'abs (getd 'absval))
        !          1030: (putd 'add (getd 'sum))
        !          1031: (putd 'chrct (getd 'charcnt))
        !          1032: (putd 'diff (getd 'difference))
        !          1033: (putd 'numbp  (getd 'numberp))
        !          1034: (putd 'princ (getd 'patom))
        !          1035: (putd 'remainder (getd 'mod))
        !          1036: (putd 'terpri (getd 'terpr))
        !          1037: (putd 'typep (getd 'type))
        !          1038: (putd 'symeval (getd 'eval))
        !          1039: (putd '< (getd 'lessp))
        !          1040: (putd '= (getd 'equal))
        !          1041: (putd '> (getd 'greaterp))
        !          1042: (putd '- (getd 'difference))
        !          1043: (putd '"=" (getd 'equal))
        !          1044: (putd '"/" (getd 'quotient))
        !          1045: (putd '"+" (getd 'add))
        !          1046: (putd '"-" (getd 'difference))
        !          1047: (putd '*dif (getd 'difference))
        !          1048: (putd '\\ (getd 'mod)) 
        !          1049: (putd '"1+" (getd 'add1))
        !          1050: (putd '"1-" (getd 'sub1))
        !          1051: (putd '* (getd 'times))
        !          1052: (putd '*$ (getd 'times))
        !          1053: (putd '/$ (getd 'quotient))
        !          1054: (putd '+$ (getd 'add))
        !          1055: (putd '-$ (getd 'difference))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.