Return to common1.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib

Annotation of 42BSD/ucb/lisp/lisplib/common1.l, revision 1.1

1.1     ! root        1: (setq rcs-common1-
        !             2:    "$Header: common1.l,v 1.8 83/09/07 08:17:20 jkf Exp $")
        !             3: 
        !             4: ;;
        !             5: ;; common1.l                           -[Sun Sep  4 14:04:15 1983 by jkf]-
        !             6: ;;
        !             7: ;;   common lisp functions.  These are the most common lisp functions
        !             8: ;; [which don't have to be defined in common0.l in order to support 
        !             9: ;;  the macros]
        !            10: ;;
        !            11: 
        !            12: (declare (macros t))           ;; compile macros in this file
        !            13: 
        !            14: ;--- Section 0 - variables
        !            15: (declare (special Standard-Input Standard-Output Standard-Error
        !            16:                  lisp-library-directory))
        !            17: 
        !            18: (or (boundp 'lisp-library-directory)
        !            19:    (setq lisp-library-directory '/usr/lib/lisp))
        !            20: 
        !            21: 
        !            22: ;--- Section 0 - equivalences
        !            23: ; 
        !            24: (defmacro make-equivalent (a b)
        !            25:    `(progn (putd ',a (getd ',b))
        !            26:           (putprop ',a (get ',b 'fcn-info) 'fcn-info)))
        !            27: 
        !            28: (make-equivalent abs absval)
        !            29: (make-equivalent add sum)
        !            30: (make-equivalent bcdcall funcall)
        !            31: (make-equivalent chrct charcnt)
        !            32: (make-equivalent diff difference)
        !            33: (make-equivalent numbp  numberp)
        !            34: (make-equivalent remainder mod)
        !            35: (make-equivalent terpri terpr)
        !            36: (make-equivalent typep type)
        !            37: (make-equivalent symeval eval)
        !            38: (make-equivalent < lessp)
        !            39: (make-equivalent <& lessp)     ; fixnum version
        !            40: (make-equivalent = equal)
        !            41: (make-equivalent =& equal)     ; fixnum version
        !            42: (make-equivalent > greaterp)
        !            43: (make-equivalent >& greaterp)  ; fixnum version
        !            44: (make-equivalent *dif difference)
        !            45: (make-equivalent \\ mod) 
        !            46: (make-equivalent \1+$ add1)
        !            47: (make-equivalent \1-$ sub1)
        !            48: (make-equivalent *$ times)
        !            49: (make-equivalent /$ quotient)
        !            50: (make-equivalent +$ add)
        !            51: (make-equivalent -$ difference)
        !            52: 
        !            53: ;--- Section I - functions and macros
        !            54: 
        !            55: 
        !            56: ;--- max - arg1 arg2 ... : sequence of numbe
        !            57: ;      returns the maximum
        !            58: ;
        !            59: (def max
        !            60:   (lexpr (nargs)
        !            61:         (do ((i nargs (1- i))
        !            62:              (max (arg 1)))
        !            63:             ((< i 2) max)
        !            64:             (cond ((greaterp (arg i) max) (setq max (arg i)))))))
        !            65: 
        !            66: 
        !            67: ;--- catch form [tag]  
        !            68: ;  catch is now a macro which translates to (*catch 'tag form)
        !            69: ;
        !            70: (def catch
        !            71:   (macro (l)
        !            72:         `(*catch ',(caddr l) ,(cadr l))))
        !            73: 
        !            74: ;--- throw form [tag]
        !            75: ;  throw isnow a macro
        !            76: ;
        !            77: (def throw
        !            78:   (macro (l)
        !            79:         `(*throw ',(caddr l) ,(cadr l))))
        !            80: 
        !            81: 
        !            82:       
        !            83: ;--- desetq
        !            84: ;      - pattern - pattern containing vrbl names
        !            85: ;      - expr    - expression to be evaluated
        !            86: ;
        !            87: (defmacro desetq (&rest forms &aux newgen destrs)
        !            88:   (do ((xx forms (cddr xx))
        !            89:        (res)
        !            90:        (patt)
        !            91:        (expr))
        !            92:       ((null xx) (cond ((null (cdr res)) (car res))
        !            93:                       (t (cons 'progn (nreverse res)))))
        !            94:       (setq patt (car xx) expr (cadr xx))
        !            95:       (setq res 
        !            96:            (cons (cond ((atom patt) `(setq ,patt ,expr))       ;trivial case
        !            97:                        (t (setq newgen (gensym)
        !            98:                                 destrs (de-compose patt '(r)))
        !            99:                           `((lambda (,newgen)
        !           100:                                     ,@(mapcar '(lambda (frm)
        !           101:                                                        `(setq  ,(cdr frm) 
        !           102:                                                                (,(car frm) ,newgen)))
        !           103:                                               destrs)
        !           104:                                     ,newgen)
        !           105:                             ,expr)))
        !           106:                  res))))
        !           107: 
        !           108: ;--- sassoc
        !           109: ;      - x : form
        !           110: ;      - y : assoc list
        !           111: ;      - fcn : function or lambda expression
        !           112: ; If (assoc x y) is non nil, then we apply the function fcn to nil.  
        !           113: ; This must be written as a macro if we expect to handle the case of
        !           114: ; a lambda expression as fcn in the compiler.  
        !           115: ;
        !           116: (defmacro sassoc (x y fcn)
        !           117:   (cond ((or (atom fcn) (not (eq 'quote (car fcn))))
        !           118:         `(or (assoc ,x ,y)
        !           119:              (funcall ,fcn)))
        !           120:        (t `(or (assoc ,x ,y)
        !           121:                (,(cadr fcn))))))
        !           122: 
        !           123: ;--- sassq
        !           124: ;      - x : form
        !           125: ;      - y : assoc list
        !           126: ;      - fcn : function or lambda expression
        !           127: ; like sassoc above except it uses assq instead of assoc.
        !           128: ;
        !           129: (defmacro sassq (x y fcn)
        !           130:   (cond ((or (atom fcn) (not (eq 'quote (car fcn))))
        !           131:         `(or (assq ,x ,y)
        !           132:              (funcall ,fcn)))
        !           133:        (t `(or (assq ,x ,y)
        !           134:                (,(cadr fcn))))))
        !           135: 
        !           136:                    
        !           137: 
        !           138: ;--- signp - test - unevaluated atom
        !           139: ;         - value - evaluated value
        !           140: ; test can be l, le, e, n, ge or g   with the obvious meaning
        !           141: ; we return t if value compares to 0 by test
        !           142: 
        !           143: (defmacro signp (tst val)
        !           144:   (setq tst  (cond ((eq 'l tst)  `(minusp signp-arg))
        !           145:                   ((eq 'le tst) `(not (greaterp signp-arg 0)))
        !           146:                   ((eq 'e tst)  `(zerop signp-arg))
        !           147:                   ((eq 'n tst)  `(not (zerop signp-arg)))
        !           148:                   ((eq 'ge tst) `(not (minusp signp-arg)))
        !           149:                   ((eq 'g tst)  `(greaterp signp-arg 0))
        !           150:                   (t (error "bad arg to signp " tst))))
        !           151:   (cond ((atom val) `(and (numberp ,val) ,(subst val 'signp-arg tst)))
        !           152:        (t `((lambda (signp-arg) (and (numberp signp-arg) ,tst))
        !           153:             ,val))))
        !           154: 
        !           155: 
        !           156: 
        !           157: ;--- unwind-protect
        !           158: ;  The form of a call to unwind-protect is
        !           159: ;   (unwind-protect pform
        !           160: ;                  form1 form2 ...)
        !           161: ; and it works as follows:
        !           162: ;  pform is evaluated, if nothing unusual happens, form1 form2 etc are
        !           163: ;      then evaluated and unwind-protect returns the value of pform.
        !           164: ;  if while evaluating pform, a throw or error caught by an errset which
        !           165: ;   would cause control to pass through the unwind-protect, then
        !           166: ;   form1 form2 etc are evaluated and then the error or throw continues.
        !           167: ; Thus, no matter what happens, form1, form2 etc will be evaluated.
        !           168: ;
        !           169: (defmacro unwind-protect (protected &rest conseq &aux (localv (gensym 'G)))
        !           170:   `((lambda (,localv)
        !           171:            (setq ,localv (*catch 'ER%unwind-protect ,protected))
        !           172:            ,@conseq
        !           173:            (cond ((and (dtpr ,localv) (eq 'ER%unwind-protect (car ,localv)))
        !           174:                   (I-throw-err (cdr ,localv)))
        !           175:                  (t ,localv)))
        !           176:     nil))
        !           177: 
        !           178: 
        !           179: ;----Section III -- Interrupt handlers 
        !           180: ; 
        !           181: 
        !           182: (def sys:fpeint-serv
        !           183:    (lambda (x$) (error "Floating Exception ")))
        !           184: 
        !           185: (def sys:int-serv
        !           186:    (lambda (dummy) (patom '"Interrupt:  ") (drain) (break)))
        !           187: 
        !           188: 
        !           189: (signal 8 'sys:fpeint-serv)
        !           190: (signal 2 'sys:int-serv)
        !           191: 
        !           192: 
        !           193: ;---- Section IV - interrupt handlers
        !           194: ;
        !           195: (cond ((null (boundp '$gcprint))
        !           196:        (setq $gcprint nil)))           ; dont print gc stats by default
        !           197: 
        !           198: (cond ((null (boundp '$gccount$))
        !           199:        (setq $gccount$ 0)))
        !           200: 
        !           201: ;--- prtpagesused - [arg] : type of page allocated last time.
        !           202: ;      prints a summary of pages used for certain selected types
        !           203: ;      of pages.  If arg is given we put a star beside that type
        !           204: ;      of page.  This is normally called after a gc.
        !           205: ;
        !           206: (def prtpagesused
        !           207:   (lambda (space tottime gctime)
        !           208:          (patom "[")
        !           209:          (do ((curtypl (cond ((memq space '(list fixnum ))
        !           210:                               '(list fixnum))
        !           211:                              (t (cons space '(list fixnum))))
        !           212:                        (cdr curtypl))
        !           213:               (temp))
        !           214:              ((null curtypl) (print 'ut:)
        !           215:               (print (max 0 (quotient (times 100 (difference tottime gctime))
        !           216:                                       tottime)))
        !           217:               (patom "%]") (terpr))
        !           218:              (setq temp (car curtypl))
        !           219:              (cond ((greaterp (cadr (opval temp)) 0)
        !           220:                     (cond ((eq space temp)
        !           221:                            (patom '*)))
        !           222:                     (patom temp)
        !           223:                     (patom '":")
        !           224:                     (print (cadr (opval temp)))
        !           225:                     (patom '"{")
        !           226:                     (print (fix (quotient 
        !           227:                                  (times 100.0
        !           228:                                         (car (opval temp)))
        !           229:                                  (* (cadr (opval temp))
        !           230:                                         (caddr (opval temp))))))
        !           231:                     (patom '"%}")
        !           232:                     (patom '"; "))))))
        !           233: 
        !           234: (declare (special gcafter-panic-mode $gccount$ $gc_midlim $gc_minalloc 
        !           235:                  $gc_pct $gc_lowlim $gcprint ptimeatlastgc))
        !           236: 
        !           237: (setq gcafter-panic-mode nil)
        !           238: (setq $gc_minalloc 10)
        !           239: (setq $gc_lowlim 60)
        !           240: (setq $gc_midlim 85)
        !           241: (setq $gc_pct    .10)
        !           242: (setq ptimeatlastgc (ptime))
        !           243: 
        !           244: ;--- gcafter - [s] : type of item which ran out forcing garbage collection.
        !           245: ;      This is called after each gc.
        !           246: ; the form of an opval element is  (number_of_items_in_use
        !           247: ;                                  number_of_pages_allocated
        !           248: ;                                  number_of_items_per_page)
        !           249: ;
        !           250: ;
        !           251: (def gcafter 
        !           252:   (nlambda (s)
        !           253:           (prog (x pct amt-to-allocate thisptime diffptime difftottime
        !           254:                    diffgctime)
        !           255:                 (cond ((null s) (return)))  
        !           256:                 (cond ((null (boundp '$gccount$)) (setq $gccount$ 0)))
        !           257:                 (setq $gccount$ (1+ $gccount$))
        !           258:                 (setq x (opval (car s)))
        !           259:                 (setq thisptime (ptime)
        !           260:                       difftottime (max  (difference (car thisptime)
        !           261:                                                     (car ptimeatlastgc))
        !           262:                                         1)
        !           263:                       diffgctime (difference (cadr thisptime)
        !           264:                                              (cadr ptimeatlastgc))
        !           265:                       ptimeatlastgc thisptime)
        !           266:                 ; pct is the percentage of space used
        !           267:                 (setq pct (quotient (times 100 (car x))
        !           268:                                     (max 1 (times (cadr x) (caddr x)))))
        !           269:                 (setq amt-to-allocate
        !           270:                       (cond (gcafter-panic-mode 
        !           271:                              (cond ((greaterp pct 95) 
        !           272:                                     (patom "[Storage space totally exhausted]")
        !           273:                                     (terpr)
        !           274:                                     (error "Space exhausted when allocating "
        !           275:                                            (car s)))
        !           276:                                    (t 0)))
        !           277:                             ((greaterp pct $gc_midlim)
        !           278:                              (max $gc_minalloc (fix (times $gc_pct (cadr x)))))
        !           279:                             ((greaterp pct $gc_lowlim)
        !           280:                              $gc_minalloc)
        !           281:                             ((lessp (cadr x) 100)
        !           282:                              $gc_minalloc)
        !           283:                             (t 0)))
        !           284:                 (cond ((and (null gcafter-panic-mode) (greaterp amt-to-allocate
        !           285:                                                                 0))
        !           286:                        (cond ((atom (errset (allocate (car s) amt-to-allocate)))
        !           287:                               (cond ($gcprint 
        !           288:                                        (patom "[Now in storage allocation panic mode]")
        !           289:                                        (terpr)))
        !           290:                               (setq gcafter-panic-mode t)))))
        !           291: 
        !           292:                 (cond ($gcprint (prtpagesused (car s) difftottime diffgctime)
        !           293:                                 (comment (cond ((and (getd 'gcstat)
        !           294:                                             (eq $gcprint '$all))
        !           295:                                        (print (gcstat))
        !           296:                                        (terpr)))))))))
        !           297: 
        !           298: ;----Section V - the functions
        !           299: ; 
        !           300: 
        !           301: 
        !           302: ;--- bigp - x : lispval
        !           303: ;      returns t if x is a bignum
        !           304: ;
        !           305: (def bigp (lambda (arg) (equal (type arg) 'bignum)))
        !           306: 
        !           307: ;--- comment - any
        !           308: ;      ignores the rest of the things in the list
        !           309: (def comment
        !           310:   (nlambda (x) 'comment))
        !           311: 
        !           312: 
        !           313: ;--- copy - l : list (will work if atom but will have no effect)
        !           314: ;      makes a copy of the list.
        !           315: ; will also copy vector and vectori's, if their property list
        !           316: ; doesn't have the 'unique' flag
        !           317: ;
        !           318: (def copy
        !           319:    (lambda (l)
        !           320:       (cond ((dtpr l) (cons (copy (car l)) (copy (cdr l))))
        !           321:            ((vectorp l)
        !           322:             (if (vget l 'unique)
        !           323:                then l
        !           324:                else (let ((size (vsize l)))
        !           325:                        (do ((newv (new-vector size))
        !           326:                             (i 0 (1+ i)))
        !           327:                            ((not (<& i size))
        !           328:                             (vsetprop newv (copy (vprop l)))
        !           329:                             newv)
        !           330:                            (vset newv i (copy (vref l i)))))))
        !           331:            ((vectorip l)
        !           332:             (if (vget l 'unique)
        !           333:                then l
        !           334:                else (let ((size (vsize-byte l)))
        !           335:                        (do ((newv (new-vectori-byte size))
        !           336:                             (i 0 (1+ i)))
        !           337:                            ((not (<& i size))
        !           338:                             (vsetprop newv (copy (vprop l)))
        !           339:                             newv)
        !           340:                            (vseti-byte newv i (vrefi-byte l i))))))
        !           341:            (t l))))
        !           342: 
        !           343: 
        !           344: ;--- copysymbol - sym : symbol to copy
        !           345: ;              - flag : t or nil
        !           346: ;  generates an uninterned symbol with the same name as sym.  If flag is t
        !           347: ; then the value, function binding and property list of sym are placed
        !           348: ; in the uninterned symbol.
        !           349: ;
        !           350: (def copysymbol 
        !           351:   (lambda (sym flag)
        !           352:          ((lambda (newsym)
        !           353:                   (cond (flag (cond ((boundp sym) (set newsym (eval sym))))
        !           354:                               (putd newsym (getd sym))
        !           355:                               (setplist newsym (plist sym))))
        !           356: 
        !           357:                   newsym)
        !           358:           (uconcat sym))))
        !           359: 
        !           360: 
        !           361: ;--- cvttointlisp -- convert reader syntax to conform to interlisp
        !           362: ;
        !           363: (def cvttointlisp
        !           364:   (lambda nil
        !           365:          (setsyntax '\% 'vescape)              ; escape character
        !           366:          (setsyntax '\\ 'vcharacter)           ; normal character
        !           367:          (setsyntax '\` 'vcharacter)           ; normal character
        !           368:          (setsyntax '\, 'vcharacter)           ; normal character
        !           369:          (sstatus uctolc t)                    ; one case
        !           370:          ))
        !           371: 
        !           372: 
        !           373: ;--- cvttomaclisp - converts the readtable to a maclisp character syntax
        !           374: ;
        !           375: (def cvttomaclisp
        !           376:   (lambda nil
        !           377:          (setsyntax '\/ 'vescape)              ; escape
        !           378:          (setsyntax '\\ 'vcharacter)           ; normal char
        !           379:          (setsyntax '\[ 'vcharacter)           ; normal char
        !           380:          (setsyntax '\] 'vcharacter)           ; normal char
        !           381:          (sstatus uctolc t)))
        !           382: 
        !           383: (declare (special readtable))
        !           384: ;--- cvttoucilisp - converts the readtable to a ucilisp character syntax
        !           385: ;
        !           386: (def cvttoucilisp
        !           387:   (lambda nil
        !           388:          (sstatus uctolc t)            ; upper case to lower case
        !           389:                                        ; change backquote character.
        !           390:                                        ; to ` and ! and !@ from ` , and ,@
        !           391:                                        ; undo comma.
        !           392:        (setsyntax '\! 'splicing (get '\, readtable))
        !           393:        (setsyntax '\, 'vcharacter)
        !           394:                ; 
        !           395:                ; ~ as comment character, not ; and / instead of \ for escape
        !           396:        (setsyntax '\~ 'splicing 'zapline)
        !           397:        (setsyntax '\; 'vcharacter)
        !           398:        (setsyntax '\/ 'vescape)
        !           399:        (setsyntax '\\   'vcharacter)))
        !           400: 
        !           401: 
        !           402: ;--- cvttofranzlisp - converts the readtable to the standard franz readtable
        !           403: ; this just does the obvious conversions, assuming that the user was
        !           404: ; in the maclisp syntax before.
        !           405: (def cvttofranzlisp
        !           406:    (lambda nil
        !           407:       (setsyntax '\/ 'vcharacter)
        !           408:       (setsyntax '\\ 'vescape)
        !           409:       (setsyntax '\[ 'vleft-bracket)
        !           410:       (setsyntax '\] 'vright-bracket)
        !           411:       (sstatus uctolc nil)))
        !           412: 
        !           413: ;--- defprop - like putprop except args are not evaled
        !           414: ;
        !           415: (def defprop 
        !           416:     (nlambda (argl)
        !           417:        (putprop (car argl) (cadr argl) (caddr argl) )))
        !           418: 
        !           419: ;--- delete
        !           420: ;      - val - lispval
        !           421: ;      - lst - list
        !           422: ;      - n   - Optional arg, number of occurances to delete
        !           423: ; removes up to n occurances of val from the top level of lst.
        !           424: ; if n is not given, all occurances will be removed.
        !           425: ;
        !           426: (def delete
        !           427:   (lexpr (nargs)
        !           428:         (prog (val lst cur ret nmb)
        !           429:               (cond ((= nargs 2)
        !           430:                      (setq nmb -1))
        !           431:                     ((= nargs 3) 
        !           432:                      (setq nmb (arg 3)))
        !           433:                     (t (error " wrong number of args to delete "
        !           434:                               (cons 'delete (listify nargs)))))
        !           435:               (setq val (arg 1) lst (arg 2))
        !           436:               (cond ((and (atom lst) (not (null lst)))         
        !           437:                      (error " non-list arg to delete " 
        !           438:                               (cons 'delete (listify nargs)))))
        !           439:               (setq cur (cons nil lst)
        !           440:                     ret cur)
        !           441:           loop
        !           442:               (cond ((or (atom lst) (zerop nmb))
        !           443:                      (return (cdr ret)))
        !           444:                     ((equal val (car lst))
        !           445:                      (rplacd cur (cdr lst))
        !           446:                      (setq nmb (1- nmb)))
        !           447:                     (t (setq cur (cdr cur))))
        !           448:               (setq lst (cdr lst))
        !           449:               (go loop))))
        !           450: 
        !           451: ;--- delq 
        !           452: ;  same as delete except eq is used for testing.
        !           453: ;
        !           454: (def delq
        !           455:   (lexpr (nargs)
        !           456:         (prog (val lst cur ret nmb)
        !           457:               (cond ((= nargs 2)
        !           458:                      (setq nmb -1))
        !           459:                     ((= nargs 3) 
        !           460:                      (setq nmb (arg 3)))
        !           461:                     (t (error " wrong number of args to delq "
        !           462:                               (cons 'delq (listify nargs)))))
        !           463:               (setq val (arg 1) lst (arg 2))
        !           464:               (cond ((and (atom lst) (not (null lst)))         
        !           465:                      (error " non-list arg to delq " 
        !           466:                               (cons 'delq (listify nargs)))))
        !           467:               (setq cur (cons nil lst)
        !           468:                     ret cur)
        !           469:           loop
        !           470:               (cond ((or (atom lst) (zerop nmb))
        !           471:                      (return (cdr ret)))
        !           472:                     ((eq val (car lst))
        !           473:                      (rplacd cur (cdr lst))
        !           474:                      (setq nmb (1- nmb)))
        !           475:                     (t (setq cur (cdr cur))))
        !           476:               (setq lst (cdr lst))
        !           477:               (go loop))))
        !           478: 
        !           479: ;--- evenp : num   -  return 
        !           480: ;
        !           481: ;
        !           482: (def evenp
        !           483:   (lambda (n)
        !           484:          (cond ((not (zerop (boole 4 1 n))) t))))
        !           485: 
        !           486: ;--- ex [name] : unevaluated name of file to edit.
        !           487: ;      the ex editor is forked to edit the given file, if no
        !           488: ;      name is given the previous name is used
        !           489: ;
        !           490: (def ex (nlambda (x) (exvi 'ex x nil)))
        !           491: 
        !           492: (declare (special edit_file))
        !           493: 
        !           494: (def exvi 
        !           495:   (lambda (cmd x doload) 
        !           496:           (prog (handy handyport bigname)
        !           497:                 (cond ((null x) (setq x (list edit_file)))
        !           498:                       (t (setq edit_file (car x))))             
        !           499:                 (setq bigname (concat (car x) '".l"))
        !           500:                 (cond ((setq handyport (car (errset (infile bigname) nil)))
        !           501:                        (close handyport)
        !           502:                        (setq handy bigname))
        !           503:                       (t (setq handy (car x))))
        !           504:                 (setq handy (concat cmd '" " handy))
        !           505:                 (setq handy (list 'process handy))
        !           506:                 (eval handy)
        !           507:                 (cond (doload (load edit_file))))))
        !           508: 
        !           509: ;--- exec - arg1 [arg2 [arg3 ...] ] unevaluated atoms
        !           510: ;      A string of all the args concatenated together seperated by 
        !           511: ;      blanks is forked as a process.
        !           512: ;
        !           513: (def exec
        !           514:  (nlambda (list)
        !           515:      (do ((xx list (cdr xx))
        !           516:          (res "" (concat res " " (car xx))))
        !           517:         ((null xx) (*process res)))))
        !           518: 
        !           519: ;--- exl - [name] : unevaluated name of file to edit and load.
        !           520: ;      If name is not given the last file edited will be used.
        !           521: ;      After the file is edited it will be `load'ed into lisp.
        !           522: ;
        !           523: (def exl (nlambda (x) (exvi 'ex x t)))
        !           524: 
        !           525: ;----- explode functions -------
        !           526: ; These functions, explode , explodec and exploden, implement the 
        !           527: ; maclisp explode functions completely.
        !           528: ; They have a similar structure and are written with efficiency, not
        !           529: ; beauty in mind (and as a result they are quite ugly)
        !           530: ; The basic idea in all of them is to keep a pointer to the last
        !           531: ; thing added to the list, and rplacd the last cons cell of it each time.
        !           532: ;
        !           533: ;--- explode - arg : lispval
        !           534: ;      explode returns a list of characters which print would use to
        !           535: ; print out arg.  Slashification is included.
        !           536: ;
        !           537: (def explode
        !           538:   (lambda (arg)
        !           539:          (cond ((atom arg) (aexplode arg))
        !           540:                ((vectorp arg)
        !           541:                 (aexplode (concat "vector[" (vsize arg) "]")))
        !           542:                ((vectorip arg)
        !           543:                 (aexplode (concat "vectori[" (vsize-byte arg) "]")))
        !           544:                (t (do ((ll (cdr arg) (cdr ll))
        !           545:                        (sofar (setq arg (cons '|(| (explode (car arg)))))
        !           546:                        (xx))
        !           547:                       ((cond ((null ll) (rplacd (last sofar) (ncons '|)| )) 
        !           548:                               t)
        !           549:                              ((atom ll) (rplacd (last sofar)
        !           550:                                                 `(| | |.| | | ,@(explode ll) 
        !           551:                                                     ,@(ncons '|)|)))
        !           552:                               t))
        !           553:                        arg)
        !           554:                       (setq xx (last sofar)
        !           555:                             sofar (cons '| | (explode (car ll))))
        !           556:                       (rplacd xx sofar))))))
        !           557: 
        !           558: ;--- explodec - arg : lispval
        !           559: ; returns the list of character which would be use to print arg assuming that
        !           560: ; patom were used to print all atoms.
        !           561: ; that is, no slashification would be used.
        !           562: ;
        !           563: (def explodec
        !           564:   (lambda (arg)
        !           565:          (cond ((atom arg) (aexplodec arg))
        !           566:                ((vectorp arg)
        !           567:                 (aexplodec (concat "vector[" (vsize arg) "]")))
        !           568:                ((vectorip arg)
        !           569:                 (aexplodec (concat "vectori[" (vsize-byte arg) "]")))
        !           570:                (t (do ((ll (cdr arg) (cdr ll))
        !           571:                        (sofar (setq arg (cons '|(| (explodec (car arg)))))
        !           572:                        (xx))
        !           573:                       ((cond ((null ll) (rplacd (last sofar) (ncons '|)| )) 
        !           574:                               t)
        !           575:                              ((atom ll) (rplacd (last sofar)
        !           576:                                                 `(| | |.| | | ,@(explodec ll) 
        !           577:                                                     ,@(ncons '|)|)))
        !           578:                               t))
        !           579:                        arg)
        !           580:                       (setq xx (last sofar)
        !           581:                             sofar (cons '| | (explodec (car ll))))
        !           582:                       (rplacd xx sofar))))))
        !           583: 
        !           584: ;--- exploden - arg : lispval
        !           585: ;      returns a list just like explodec, except we return fixnums instead
        !           586: ; of characters.
        !           587: ;
        !           588: (def exploden
        !           589:   (lambda (arg)
        !           590:          (cond ((atom arg) (aexploden arg))
        !           591:                ((vectorp arg)
        !           592:                 (aexploden (concat "vector[" (vsize arg) "]")))
        !           593:                ((vectorip arg)
        !           594:                 (aexploden (concat "vectori[" (vsize-byte arg) "]")))
        !           595:                (t (do ((ll (cdr arg) (cdr ll))
        !           596:                        (sofar (setq arg (cons 40. (exploden (car arg)))))
        !           597:                        (xx))
        !           598:                       ((cond ((null ll) (rplacd (last sofar) (ncons 41.)) 
        !           599:                               t)
        !           600:                              ((atom ll) (rplacd (last sofar)
        !           601:                                                 `(32. 46. 32. ,@(exploden ll) 
        !           602:                                                     ,@(ncons 41.)))
        !           603:                               t))
        !           604:                        arg)
        !           605:                       (setq xx (last sofar)
        !           606:                             sofar (cons 32. (exploden (car ll))))
        !           607:                       (rplacd xx sofar))))))
        !           608: 
        !           609: ;-- expt  - x
        !           610: ;        - y
        !           611: ;
        !           612: ;         y
        !           613: ; returns x
        !           614: ;
        !           615: (defun expt (x y)
        !           616:   (cond ((equal x 1) x)
        !           617:        ((zerop x) x)   ; Maclisp does this 
        !           618:        ((lessp y 0) (quotient 1.0 (expt x (times -1 y))))
        !           619:        ((floatp y) 
        !           620:         (exp (times y (log x)))) ; bomb out for (-3)^4 or (-3)^4.0 or 0^y.
        !           621:        ((bigp y)
        !           622:         (error "expt: Can't compute number to a bignum power" y))
        !           623:        (t ; y is integer, y>= 0
        !           624:           (prog (res)
        !           625:                 (setq res 1)
        !           626:                 loop
        !           627:                 (cond ((equal y 0) (return res))
        !           628:                       ((oddp y)(setq res (times  res x) y (1- y)))
        !           629:                       (t (setq x (times x x) y (/ y 2))))
        !           630:                 (go loop)))))
        !           631: 
        !           632: 
        !           633: 
        !           634: ;--- ffasl :: fasl in a fortran file
        !           635: ;  arg #
        !           636: ;   1  - fnam : file name
        !           637: ;   2  - entry : entry point name
        !           638: ;   3  - fcn  : entry name
        !           639: ;   4   - disc : optional discipline
        !           640: ;   5   - lib  ; optional library specifier
        !           641: ;
        !           642: (defun ffasl (fnam entry fcn &optional (disc 'subroutine) (lib " "))
        !           643:   (cfasl fnam entry fcn disc (concat lib " -lI77 -lF77 -lm")))
        !           644: 
        !           645: 
        !           646: ;
        !           647: ; filepos function (maclisp compatibility)
        !           648: ;
        !           649: (defun filepos n
        !           650:   (cond ((zerop n) nil)
        !           651:        ((onep n)
        !           652:         (fseek (arg 1) 0 1))
        !           653:        ((equal n 2)
        !           654:         (fseek (arg 1) (arg 2) 0))))
        !           655: 
        !           656: ;--- fixp - l : lispval
        !           657: ;      returns t if l is a fixnum or bignum
        !           658: ;
        !           659: (defun fixp (x) (or (equal (type x) 'fixnum)
        !           660:                    (equal (type x) 'bignum)))
        !           661: 
        !           662: 
        !           663: 
        !           664: ;--- flatsize - l : lispval
        !           665: ;           the second arg should be:
        !           666: ;            - n : limit for what we care about
        !           667: ;           but we dont care about this at present, since we have
        !           668: ;           to explode the whole thing anyway.
        !           669: ;      returns the number of characters which print would
        !           670: ;      use to print l
        !           671: ;
        !           672: (defun flatsize n
        !           673:   (length (explode (arg 1))))
        !           674: 
        !           675: 
        !           676: ;--- floatp - l : lispval
        !           677: ;      returns t if l is a flonum
        !           678: ;
        !           679: (defun floatp (x) (equal 'flonum (type x)))
        !           680: 
        !           681: 
        !           682: ;--- getchar,getcharn   - x : atom
        !           683: ;                      - n : fixnum
        !           684: ; returns the n'th character of x's pname (the first corresponds to n=1)
        !           685: ; if n is negative then it counts from the end of the pname
        !           686: ; if n is out of bounds, nil is returned
        !           687: 
        !           688: (def getchar
        !           689:   (lambda (x n)
        !           690:          (concat (substring x n 1))))
        !           691: 
        !           692: 
        !           693: (def getcharn
        !           694:   (lambda (x n)
        !           695:          (substringn x n 0)))
        !           696: 
        !           697: 
        !           698: (def getl 
        !           699:   (lambda (atm lis)
        !           700:          (do ((ll (cond ((atom atm) (plist atm))
        !           701:                         (t (cdr atm)))
        !           702:                   (cddr ll)))
        !           703:              ((null ll) nil)
        !           704:              (cond ((memq (car ll) lis) (return ll))))))
        !           705: 
        !           706: 
        !           707: ;--- help
        !           708: ; retrive selected portions of the Franz Lisp manual.
        !           709: ; There are four types of help offered:
        !           710: ; (help) prints a description of the other three options
        !           711: ; (help tc) prints a table of contents.
        !           712: ; (help n) {where n is a number or b or c} prints the whole chapter.
        !           713: ; (help fcn) prints info on function fcn
        !           714: ;
        !           715: ; An index to the functions is kept in the documentation directory.
        !           716: ; The index has entries like (append ch2.r).  
        !           717: ; When asked to print info on a function, it locates the chapter
        !           718: ; using the index then asks more to locate the definition.
        !           719: ;
        !           720: (declare (localf locatefunction))
        !           721: 
        !           722: (defun help fexpr (lis)
        !           723:   (cond ((null lis) 
        !           724:  (patom "type (help fnc) for info on function fnc")(terpr)
        !           725:  (patom "type (help n) to see chapter n")(terpr)
        !           726:  (patom "type (help tc) for a table of contents")(terpr))
        !           727:        (t (do ((ll lis (cdr ll))
        !           728:                (fcn))
        !           729:               ((null ll))
        !           730:               (cond ((not (atom (setq fcn (car ll))))
        !           731:                      (patom "Bad option to help ")(print fcn)(terpr))
        !           732:                     ((and (stringp fcn) (setq fcn (concat fcn)) nil))
        !           733:                     ((eq fcn 'tc)
        !           734:                      (patom "Table of contents")(terpr)
        !           735:  (patom "1 - intro; 2 - data structure; 3 - arithmetic; 4 - special")(terpr)
        !           736:  (patom "5 - i/o; 6 - system; 7 - reader; 8 - functions; 9 - arrays")(terpr)
        !           737:  (patom "10 - exceptions; 11 - trace package; 12 - Liszt;")(terpr)
        !           738:  (patom "14 - step package; 15 - fixit package") (terpr)
        !           739:  (patom "b - special symbols; c - gc & debugging & top level ")(terpr))
        !           740:                     ((or (and (numberp fcn) (lessp fcn 16) (greaterp fcn -1))
        !           741:                          (memq fcn '(b c)))
        !           742:                      (apply 'process 
        !           743:                         (ncons (concat "/usr/ucb/ul "
        !           744:                                        lisp-library-directory
        !           745:                                        "/manual/ch"
        !           746:                                       fcn ".r | /usr/ucb/more -f" ))))
        !           747:                     ((locatefunction fcn))
        !           748:                     (t (patom "Unknown function: ")(print fcn)(terpr)))))))
        !           749: 
        !           750: (declare (special readtable))
        !           751: 
        !           752: (defun locatefunction (fc)
        !           753:   (let (x inf )
        !           754:        (cond ((null (get 'append 'helplocation)) 
        !           755:              (patom "[Reading help index]")(drain)
        !           756:              (setq inf (infile (concat lisp-library-directory
        !           757:                                        "/manual/helpindex")))
        !           758:              (do ((readtable (makereadtable t))
        !           759:                   (x (read inf) (read inf)))
        !           760:                  ((null x) (close inf) (terpr))
        !           761:                  (cond ((null (cddr x))
        !           762:                         (putprop (car x) (cadr x) 'helplocation))
        !           763:                        (t (putprop (concat (car x) " " (cadr x))
        !           764:                                    (caddr x)
        !           765:                                    'helplocation))))))
        !           766:        (cond ((setq x (get fc 'helplocation))
        !           767:              (apply 'process (ncons (concat "/usr/ucb/ul "
        !           768:                                             lisp-library-directory
        !           769:                                             "/manual/"
        !           770:                                             x 
        !           771:                                             " | /usr/ucb/more -f \"+/(" 
        !           772:                                             fc 
        !           773:                                             "\"")))
        !           774:              t))))
        !           775: 
        !           776: ;
        !           777: ; (hunk 'g_arg1 [...'g_argn])
        !           778: ;
        !           779: ; This function makes a hunk. The hunk is preinitialized to the
        !           780: ; arguments present. The size of the hunk is determined by the
        !           781: ; number of arguments present.
        !           782: ;
        !           783: 
        !           784: (defun hunk n
        !           785:   (prog (size)
        !           786:        (setq size -1)
        !           787:        (cond ((> n 128) (error "hunk: size is too big" n))
        !           788:              ((eq n 1) (setq size 0))
        !           789:              ((eq n 0) (return nil))   ; hunk of zero length
        !           790:              (t (setq size (1- (haulong (1- n))))))
        !           791:        (setq size (*makhunk size))
        !           792:        (do
        !           793:         ((argnum 0 (1+ argnum)))
        !           794:         ((eq argnum n))
        !           795:         (*rplacx argnum size (arg (1+ argnum))))
        !           796:        (return size)))
        !           797: 
        !           798: 
        !           799: ;--- last - l : list
        !           800: ;      returns the last cons cell of the list, NOT the last element
        !           801: ;
        !           802: (def last 
        !           803:   (lambda (a)
        !           804:          (do ((ll a (cdr ll)))
        !           805:              ((null (cdr ll))  ll))))
        !           806: 
        !           807: ;---- load 
        !           808: ; load will either load (read-eval)  or fasl in the file.
        !           809: ; it is affected by these global flags
        !           810: ;  tilde-expansion :: expand filenames preceeded by ~ just like
        !           811: ;      csh does (we do the expansion here so each i/o function we call
        !           812: ;      doesn't have to do it).
        !           813: ;  load-most-recent :: if there is a choice between a .o and a .l file,
        !           814: ;      load the youngest one
        !           815: ;
        !           816: (declare (localf load-a-file))
        !           817: (declare (special gcdisable load-most-recent tilde-expansion))
        !           818: 
        !           819: (or (boundp 'load-most-recent) (setq load-most-recent nil))
        !           820: (or (boundp 'tilde-expansion) (setq tilde-expansion t))
        !           821: 
        !           822: (defun load (filename &rest fasl-args)
        !           823:   (cond ((not (or (symbolp filename) (stringp filename))) 
        !           824:         (error "load: illegal filename " filename)))
        !           825:   (let ( load-only fasl-only no-ext len search-path name pred shortname explf
        !           826:         faslfile loadfile)
        !           827: 
        !           828:        
        !           829:        (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           830:                
        !           831:        ; determine the length of the filename, ignoring the possible
        !           832:        ; list of directories.  set explf to the reversed exploded filename
        !           833:        (setq len (do ((xx (setq explf (nreverse (exploden filename))) (cdr xx))
        !           834:                      (i 0 (1+ i)))
        !           835:                     ((null xx) i)
        !           836:                     (cond ((eq #// (car xx)) (return i)))))
        !           837: 
        !           838:        (cond ((> len 2)
        !           839:              (cond ((eq (cadr explf) #/.)
        !           840:                     (cond ((eq (car explf) #/o)
        !           841:                            (setq fasl-only t))
        !           842:                           ((eq (car explf) #/l)
        !           843:                            (setq load-only t))
        !           844:                           (t (setq no-ext t))))
        !           845:                    (t (setq no-ext t))))
        !           846:             (t (setq no-ext t)))
        !           847: 
        !           848:        ; a short name is less or equal 12 characters.  If a name is not
        !           849:        ; short, then load will not try to append .l or .o
        !           850:        (cond ((or (< len 13) (status feature long-filenames))
        !           851:              (setq shortname t)))
        !           852: 
        !           853:        (cond ((and (> len 0) (eq (getchar filename 1) '/))
        !           854:              (setq search-path '(||)))
        !           855:             (t (setq search-path (status load-search-path))))
        !           856:        (do ((xx search-path (cdr xx)))
        !           857:           ((null xx) (error "load: file not found " filename))
        !           858:           (setq pred (cond ((memq (car xx) '(|| |.|)) '||)
        !           859:                            (t (concat (car xx) "/"))))
        !           860:           (cond (no-ext
        !           861:                  (cond ((and shortname
        !           862:                              load-most-recent
        !           863:                              (probef
        !           864:                                 (setq faslfile (concat pred filename ".o")))
        !           865:                              (probef
        !           866:                                 (setq loadfile (concat pred filename ".l"))))
        !           867:                         ; both an object and a source file exist.
        !           868:                         ; load the last modified one (fasl wins in ties)
        !           869:                         (let ((faslstat (filestat faslfile))
        !           870:                               (loadstat (filestat loadfile)))
        !           871:                            (cond ((< (filestat:mtime faslstat)
        !           872:                                      (filestat:mtime loadstat))
        !           873:                                   (return (load-a-file loadfile)))
        !           874:                                  (t (return
        !           875:                                        (fasl-a-file faslfile
        !           876:                                                     (car fasl-args)
        !           877:                                                     (cadr fasl-args)))))))
        !           878:                        ((and shortname
        !           879:                              (probef (setq name
        !           880:                                            (concat pred filename ".o"))))
        !           881:                         (return (fasl-a-file name (car fasl-args)
        !           882:                                              (cadr fasl-args))))
        !           883:                        ((and shortname
        !           884:                              (probef (setq name
        !           885:                                            (concat pred filename ".l"))))
        !           886:                         (return (load-a-file name)))
        !           887:                        ((probef (setq name (concat pred filename)))
        !           888:                         (cond (fasl-args (return
        !           889:                                             (fasl-a-file name
        !           890:                                                          (car fasl-args)
        !           891:                                                          (cadr fasl-args))))
        !           892:                               (t (return (load-a-file name)))))))
        !           893:                 (fasl-only
        !           894:                  (cond ((probef (setq name (concat  pred  filename)))
        !           895:                         (return (fasl-a-file name (car fasl-args)
        !           896:                                              (cadr fasl-args))))))
        !           897:                 (load-only
        !           898:                  (cond ((probef (setq name (concat pred filename)))
        !           899:                         (return (load-a-file name)))))))))
        !           900: 
        !           901: ;--- tilde-expand :: given a ~filename, expand it
        !           902: ;
        !           903: (defun tilde-expand (name)
        !           904:    (cond ((or (symbolp name) (stringp name))
        !           905:          (cond ((eq (getcharn name 1) #/~)
        !           906:                 (let ((form (exploden name)))
        !           907:                    (do ((xx (cdr form) (cdr xx))
        !           908:                         (res)
        !           909:                         (val))
        !           910:                        ((or (null xx) (eq (car xx) #//))
        !           911:                         ;; if this is the current user, just get value
        !           912:                         ;; from environment variable HOME
        !           913:                         (cond ((or (null res)
        !           914:                                    (equal (setq res (implode (nreverse res)))
        !           915:                                           (getenv 'USER)))
        !           916:                                (setq val (getenv 'HOME)))
        !           917:                               (t (setq val (username-to-dir res))))
        !           918:                         (cond ((null val)
        !           919:                                (error "tilde-expand: unknown user " res))
        !           920:                               (t (concat val (implode xx)))))
        !           921:                        (setq res (cons (car xx) res)))))
        !           922:                (t name)))
        !           923:         (t (error "tilde-expand: illegal argument " name))))
        !           924: 
        !           925:       
        !           926: 
        !           927: ;--- fasl-a-file
        !           928: ; The arguments are just like those to fasl.  This fasl's a file
        !           929: ; and if the translink's are set, it does the minimum work necessary to rebind
        !           930: ; the links (so that the new functions just fasl'ed in will be used).
        !           931: ; 
        !           932: (defun fasl-a-file (name map warnflag)
        !           933:    (let ((translinkarg (status translink)))
        !           934:       (prog1
        !           935:         (fasl name map warnflag)
        !           936:         (cond ((and translinkarg (setq translinkarg (status translink)))
        !           937:                ; if translink was set before and is still set
        !           938:                (cond ((eq translinkarg t)
        !           939:                       (sstatus translink nil)  ; clear all links
        !           940:                       (sstatus translink t))   ; set to make links
        !           941:                      (t ; must be 'on'
        !           942:                         (sstatus translink on) ; recompute all links
        !           943:                         ))))))) 
        !           944: 
        !           945: (declare (special $ldprint))   ; print message before loading
        !           946: (declare (special prinlevel prinlength))
        !           947: 
        !           948: (defun load-a-file (fname)
        !           949:    (cond ($ldprint (patom "[load ")(patom fname)(patom "]")(terpr)))
        !           950:    (let ((translinkarg (status translink)))
        !           951:       (prog1
        !           952:         (let ((Piport (infile fname))
        !           953:               ; (gcdisable t)  ; too dangerous: removed for now
        !           954:               ; don't gc when loading, it slows things down
        !           955:               (eof (list nil)))
        !           956:            (do ((form (errset (read Piport eof)) (errset (read Piport eof)))
        !           957:                 (lastform "<no form read successfully>"))
        !           958:                ((eq eof (car form)) (close Piport) t)
        !           959:                (cond ((null form)
        !           960:                       (error "load aborted due to read error after form "
        !           961:                              lastform))
        !           962:                      (t (setq lastform (car form))
        !           963:                         (eval (car form))))))
        !           964:         (cond ((and translinkarg (setq translinkarg (status translink)))
        !           965:                ; if translink was set before and is still set
        !           966:                (cond ((eq translinkarg t)
        !           967:                       (sstatus translink nil)  ; clear all links
        !           968:                       (sstatus translink t))   ; set to make links
        !           969:                      (t ; must be 'on'
        !           970:                         (sstatus translink on) ; recompute all links
        !           971:                         )))))))
        !           972: 
        !           973: (funcall 'sstatus (list 'load-search-path (list '|.| lisp-library-directory)))
        !           974: ;--- include - read in the file name given, the name not evaluated
        !           975: ;
        !           976: (def include (nlambda (l) (load (car l))))
        !           977: 
        !           978: ;--- includef - read in the file name given and eval the first arg
        !           979: ;
        !           980: (def includef (lambda (l) (load l)))
        !           981: 
        !           982: 
        !           983: ;--- list-to-bignum
        !           984: ;  convert a list of fixnums to a bignum.
        !           985: ; there is a function bignum-to-list but it is written in C
        !           986: ;
        !           987: ;(author: kls)
        !           988: ;
        !           989: (def list-to-bignum
        !           990:  (lambda (x) (cond (x (scons (car x) (list-to-bignum (cdr x))))
        !           991:                   (t nil))))
        !           992: 
        !           993: 
        !           994: 
        !           995: ;--- macroexpand - form 
        !           996: ;      expands out all macros it can
        !           997: ;
        !           998: (def macroexpand
        !           999:   (lambda (form)
        !          1000:     (prog nil
        !          1001:   top (cond ((atom form) (return form))
        !          1002:            ((atom (car form))
        !          1003:             (return
        !          1004:              (let ((nam (car form)) def disc)
        !          1005:                   (setq def (getd nam))
        !          1006:                   (setq disc (cond ((bcdp def) (getdisc def))
        !          1007:                                    ((arrayp def) 'array)
        !          1008:                                    ((dtpr def) (car def))))
        !          1009:                   (cond ((and (null def)
        !          1010:                               (get nam 'macro-autoload))
        !          1011:                          (setq disc 'macro)))
        !          1012:                   (cond ((memq disc '(array lambda lexpr nil))
        !          1013:                          (cons nam (mapcar 'macroexpand (cdr form))))
        !          1014:                         ((eq disc 'macro)
        !          1015:                          (setq form (apply nam form))
        !          1016:                          (go top))
        !          1017:                         ((eq nam 'prog)
        !          1018:                          (cons nam
        !          1019:                                (cons (cadr form)
        !          1020:                                      (mapcar 'macroexpand (cddr form)))))
        !          1021:                         (t form)))))
        !          1022:            (t (return (cons (macroexpand (car form))
        !          1023:                             (mapcar 'macroexpand (cdr form)))))))))
        !          1024: 
        !          1025: 
        !          1026: 
        !          1027: 
        !          1028: ;
        !          1029: ; (makhunk 'n)
        !          1030: ;
        !          1031: ; This function is similar to hunk, except that:
        !          1032: ;
        !          1033: ; n can be a fixnum, which specifies the length of the hunk.
        !          1034: ;      The hunk is preinitialized to nil's
        !          1035: ; n can be a list which is used to preinitialize the hunk.
        !          1036: ;
        !          1037: (defun makhunk (n)
        !          1038:   (prog (size Hunk)
        !          1039:        (setq size -1)
        !          1040:        (cond ((numberp n)
        !          1041: ;
        !          1042: ; If n is a number then build a nil hunk of the right size
        !          1043: ;
        !          1044:               (cond ((greaterp n 128) (error "makhunk: size is too big" n))
        !          1045:                     ((= n 1) (setq size 0))
        !          1046:                     (t (setq size (1- (haulong (1- n))))))
        !          1047:               (cond ((minusp size) (return nil)))
        !          1048:               (setq Hunk (*makhunk size))
        !          1049:               (do ((i 0 (1+ i)))
        !          1050:                   ((=& i n))
        !          1051:                   (*rplacx i Hunk nil))
        !          1052:               (return Hunk))
        !          1053: ;
        !          1054: ; If it isn't a number, then try hunk on it
        !          1055: ;
        !          1056:              (t (return (apply 'hunk n))))))
        !          1057: 
        !          1058: ;--- member - VAL : lispval
        !          1059: ;          - LIS : list
        !          1060: ;      returns that portion of LIS beginning with the first occurance
        !          1061: ;      of VAL  if  VAL is found at the top level of list LIS.
        !          1062: ;      uses equal for comparisons.
        !          1063: ;
        !          1064: (def member 
        !          1065:   (lambda ($a$ $l$)
        !          1066:          (do ((ll $l$ (cdr ll)))
        !          1067:              ((null ll) nil)
        !          1068:              (cond ((equal $a$ (car ll)) (return ll))))))
        !          1069: 
        !          1070: ;--- memq - arg : (probably a symbol)
        !          1071: ;        - lis : list
        !          1072: ; returns part of lis beginning with arg if arg is in lis
        !          1073: ;      
        !          1074: ; [ defintion moved to top of file to allow backquote macro to work ]
        !          1075: 
        !          1076: ;--- min - arg1 ... numbers 
        !          1077: ;
        !          1078: ;      returns minimum of n numbers. 
        !          1079: ;
        !          1080: 
        !          1081: (def min
        !          1082:   (lexpr (nargs)
        !          1083:         (do ((i nargs (1- i))
        !          1084:              (min (arg 1)))
        !          1085:             ((lessp i 2) min)
        !          1086:             (cond ((lessp (arg i) min) (setq min (arg i)))))))
        !          1087: 
        !          1088: 
        !          1089: ;
        !          1090: (def oddp
        !          1091:   (lambda (n)
        !          1092:          (cond ((not (zerop (boole 1 1 n))) t))))
        !          1093: 
        !          1094: ;--- plusp : x - number
        !          1095: ; returns t iff x is greater than zero
        !          1096: 
        !          1097: (def plusp
        !          1098:   (lambda (x)
        !          1099:          (greaterp x 0)))
        !          1100: 
        !          1101: 
        !          1102: ;--- princ : l - any s-expression
        !          1103: ;          [p] - port to write to
        !          1104: ; prints using patom for atoms (unslashified)
        !          1105: ;
        !          1106: (def princ
        !          1107:   (lexpr (n)
        !          1108:         (prog (port val)
        !          1109:               (cond ((eq n 2) (setq port (arg 2))))
        !          1110:               (cond ((dtpr (setq val (arg 1)))
        !          1111:                      (cond ((and (eq 'quote (car val))
        !          1112:                                  (dtpr (cdr val))
        !          1113:                                  (null (cddr val)))
        !          1114:                             (patom "'" port)
        !          1115:                             (princ (cadr val) port))
        !          1116:                            (t 
        !          1117:                             (patom "(" port)
        !          1118:                             (do ((xx val))
        !          1119:                                 ((null xx) (patom ")" port))
        !          1120:                                 (princ (car xx) port)
        !          1121:                                 (cond ((null (setq xx (cdr xx))))
        !          1122:                                       ((not (dtpr xx))
        !          1123:                                        (patom " . " port)
        !          1124:                                        (princ xx port)
        !          1125:                                        (setq xx nil))
        !          1126:                                       (t (patom " " port)))))))
        !          1127:                     (t (patom val port)))
        !          1128:               (return t))))
        !          1129: 
        !          1130: ;--- prog1 : return the first value computed in a list of forms
        !          1131: ;
        !          1132: (def prog1
        !          1133:   (lexpr (n)
        !          1134:         (arg 1)))
        !          1135: 
        !          1136: ;--- reverse : l - list
        !          1137: ;      returns the list reversed using cons to create new list cells.
        !          1138: ;
        !          1139: (def reverse 
        !          1140:   (lambda (x)
        !          1141:          (cond ((null x) nil)
        !          1142:                (t (do ((cur (cons (car x) nil) 
        !          1143:                             (cons (car res) cur))
        !          1144:                        (res (cdr x) (cdr res)))
        !          1145:                       ((null res) cur))))))
        !          1146: 
        !          1147: 
        !          1148: ;--- shell - invoke a new c shell
        !          1149: ;
        !          1150: (def shell 
        !          1151:   (lambda nil 
        !          1152:          ((lambda (shellname)
        !          1153:                   (cond ((lessp (flatc shellname) 1) (setq shellname 'csh)))
        !          1154:                   (apply 'process (ncons shellname)))
        !          1155:           (getenv 'SHELL))))
        !          1156: 
        !          1157: 
        !          1158: 
        !          1159: ; S L O A D  stuff
        !          1160: ;
        !          1161: (defvar $sldprint t)
        !          1162: (declare (special sload-print))
        !          1163: (setq sload-print nil)
        !          1164: 
        !          1165: (defmacro sl-print (&rest args)
        !          1166:    `(cond ((and sload-print
        !          1167:                (getd sload-print))
        !          1168:           (funcall sload-print . ,args))
        !          1169:          (t (print . ,args))))
        !          1170: 
        !          1171: ;--- sload : fn - file name (must include the .l)
        !          1172: ;      loads in the file printing each result as it is seen
        !          1173: ;
        !          1174: (defun sload (&rest files)
        !          1175:    (mapc '(lambda (fn)
        !          1176:             (prog (por eof argnum result)
        !          1177:                (cond ((setq por (infile fn))
        !          1178:                       (and $sldprint
        !          1179:                            (progn (princ "[sload ")
        !          1180:                                   (princ fn)
        !          1181:                                   (princ "]")
        !          1182:                                   (terpr))))
        !          1183:                      (t (patom "bad file name: ")
        !          1184:                         (patom fn)
        !          1185:                         (terpr)
        !          1186:                         (return nil)))
        !          1187:                (setq eof (gensym))
        !          1188:                (do ((input (read por eof) (read por eof)))
        !          1189:                    ((eq eof input) (close por))
        !          1190:                    (and $sldprint
        !          1191:                         (cond ((and (dtpr input)
        !          1192:                                     (setq argnum
        !          1193:                                           (get (car input) 'sloadprintarg)))
        !          1194:                                (print (nth argnum input)))
        !          1195:                               (t (print input))))
        !          1196:                    (setq result (eval input))
        !          1197:                    (and (eq 'value $sldprint)
        !          1198:                         (progn (princ ": ")
        !          1199:                                (sl-print result)))
        !          1200:                    (and $sldprint
        !          1201:                         (terpr)))
        !          1202:                (return t)))
        !          1203:         files))
        !          1204: 
        !          1205: (defprop def 1 sloadprintarg)
        !          1206: (defprop defun 1 sloadprintarg)
        !          1207: 
        !          1208: (defprop setq 1 sloadprintarg)
        !          1209: (defprop declare 1 sloadprintarg)
        !          1210: 
        !          1211: 
        !          1212: 
        !          1213: 
        !          1214: 
        !          1215: ;---- bubble merge sort 
        !          1216: ; it recursively splits the list to sort until the list is small.  At that
        !          1217: ; point it uses a bubble sort.  Finally the sorted lists are merged.
        !          1218: 
        !          1219: (declare (special sort-function))
        !          1220: 
        !          1221: ;--- sort :: sort a lisp list
        !          1222: ; args: lst - list of items
        !          1223: ;       fcn - function to compare two items.
        !          1224: ; returns: the list with such that for each pair of adjacent elements,
        !          1225: ;         either the elements are equal, or fcn applied to the two 
        !          1226: ;         args returns a non nil value.
        !          1227: ;
        !          1228: (defun sort (lst fcn)
        !          1229:   (setq sort-function (cond (fcn)   ; store function name in global cell
        !          1230:                            (t 'alphalessp)))
        !          1231:   ; (setq sort-compares 0)             ; count number of comparisons
        !          1232:   (sortmerge lst (length lst)))
        !          1233: 
        !          1234: 
        !          1235: ;--- sortmerge :: utility routine to sort
        !          1236: ; args: lst - list of items to sort
        !          1237: ;      nitems - a rough idea of how many items are in the list
        !          1238: ;
        !          1239: ; result - sorted list (see the result of sort above)
        !          1240: ;
        !          1241: (defun sortmerge (lst nitems)
        !          1242:   (prog (tmp tmp2)
        !          1243:        (cond ((greaterp nitems 7)
        !          1244:               ; do a split and merge
        !          1245:               (setq tmp (splitlist lst (setq tmp2 (quotient nitems 2))))
        !          1246:               (return (mergelists (sortmerge (car tmp) tmp2)
        !          1247:                              (sortmerge (cdr tmp) tmp2))))
        !          1248:              (t ; do a bubble sort
        !          1249:                 (do ((l lst (cdr l))
        !          1250:                      (fin))
        !          1251:                     ((null l))
        !          1252:                     (do ((ll lst (cdr ll)))
        !          1253:                         ((eq fin (cdr ll)) (setq fin ll))
        !          1254:                         ;(setq sort-compares (1+ sort-compares))
        !          1255:                         (cond ((not (funcall sort-function (car ll) (cadr ll)))
        !          1256:                                (rplaca ll (prog1 (cadr ll)
        !          1257:                                                 (rplaca (cdr ll)
        !          1258:                                                         (car ll))))))))
        !          1259:                 (return lst)))))
        !          1260: 
        !          1261: ;--- splitlist :: utility routine to split a list
        !          1262: ; args : lst - list to split
        !          1263: ;        spliton - number of items to put in the first list
        !          1264: ;
        !          1265: ; returns: a cons cell whose car is the first part of the list
        !          1266: ;         and whose cdr is the second part.
        !          1267: ;
        !          1268: (defun splitlist (lst spliton)
        !          1269:   (prog (second)
        !          1270:        (do ((i spliton (sub1 i))
        !          1271:             (l lst))
        !          1272:            ((or (null (cdr l)) (zerop i))
        !          1273:             (setq second (cdr l))
        !          1274:             (rplacd l nil))
        !          1275:            (setq l (cdr l)))
        !          1276:        (return (cons lst second))))
        !          1277: 
        !          1278: 
        !          1279: ;--- mergelists ::utility routine to merge two lists based on predicate function
        !          1280: ; args: ls1 - lisp list
        !          1281: ;      ls2 - lisp list
        !          1282: ;      sort-function (global) - compares items of the lists
        !          1283: ;
        !          1284: ; returns: a sorted list containing the elements of the two lists.
        !          1285: ; 
        !          1286: (defun mergelists  (ls1 ls2)
        !          1287:   (prog (result current)
        !          1288:        ; initialize
        !          1289:        (setq current (setq result (cons nil nil)))
        !          1290: loop   (cond ((null ls1)
        !          1291:               (rplacd current ls2)
        !          1292:               (return (cdr result)))
        !          1293:              ((null ls2)
        !          1294:               (rplacd current ls1)
        !          1295:               (return (cdr result)))
        !          1296:              ((funcall sort-function (car ls1) (car ls2))
        !          1297:               ;(setq sort-compares (1+ sort-compares))
        !          1298:               (rplacd current ls1)
        !          1299:               (setq current ls1
        !          1300:                     ls1 (cdr ls1)))
        !          1301:              (t ;(setq sort-compares (1+ sort-compares))
        !          1302:                 (rplacd current ls2)
        !          1303:                 (setq current ls2
        !          1304:                       ls2 (cdr ls2))))
        !          1305:        (go loop)))
        !          1306: 
        !          1307: ;--- end bubble merge sort
        !          1308: (declare (localf exchange2))
        !          1309: 
        !          1310: (defun sortcar (a fun)
        !          1311:    (prog (n)
        !          1312:        (if (null fun) then (setq fun 'alphalessp))
        !          1313:        (cond ((null a) (return nil)) ;no elements
        !          1314:             (t (setq n (length a))
        !          1315:                (do i 1 (1+ i) (greaterp i n) (sortcarhelp a fun))
        !          1316:                (return a)))))
        !          1317: 
        !          1318: (defun sortcarhelp (a fun)
        !          1319:   (cond ((null (cdr a)) a)
        !          1320:         ((funcall fun (caadr a) (caar a))  
        !          1321:         (exchange2 a)
        !          1322:         (sortcarhelp (cdr a) fun))
        !          1323:        (t (sortcarhelp (cdr a) fun))))
        !          1324: 
        !          1325: 
        !          1326: (defun exchange2 (a)
        !          1327:   (prog (temp)
        !          1328:        (setq temp (cadr a))
        !          1329:        (rplaca (cdr a) (car a))
        !          1330:        (rplaca a temp)))
        !          1331: 
        !          1332: ;--- sublis: alst - assoc list ((a . val) (b . val2) ...)
        !          1333: ;           exp  - s-expression
        !          1334: ; for each atom in exp which corresponds to a key in alst, the associated
        !          1335: ; value from alst is substituted.  The substitution is done by adding
        !          1336: ; list cells, no struture mangling is done.  Only the minimum number
        !          1337: ; of list cells will be created.
        !          1338: ;
        !          1339: (def sublis
        !          1340:   (lambda (alst exp)
        !          1341:      (let (tmp)
        !          1342:          (cond ((atom exp) 
        !          1343:                 (cond ((setq tmp (assoc exp alst))
        !          1344:                        (cdr tmp))
        !          1345:                       (t exp)))
        !          1346:                ((setq tmp (sublishelp alst exp))
        !          1347:                 (car tmp))
        !          1348:                (t exp)))))
        !          1349: 
        !          1350: ;--- sublishelp : alst - assoc list
        !          1351: ;                exp  - s-expression
        !          1352: ; this function helps sublis work.  it is different from sublis in that
        !          1353: ; it return nil if no change need be made to exp, or returns a list of
        !          1354: ; one element which is the changed exp.
        !          1355: ;
        !          1356: (def sublishelp
        !          1357:   (lambda (alst exp)
        !          1358:      (let (carp cdrp)
        !          1359:          (cond ((atom exp)
        !          1360:                 (cond ((setq carp (assoc exp alst))
        !          1361:                        (list (cdr carp)))
        !          1362:                       (t nil)))
        !          1363:                (t (setq carp (sublishelp alst (car exp))
        !          1364:                         cdrp (sublishelp alst (cdr exp)))
        !          1365:                   (cond ((not (or carp cdrp)) nil)             ; no change
        !          1366:                         ((and carp (not cdrp))                 ; car change
        !          1367:                          (list (cons (car carp) (cdr exp))))   
        !          1368:                         ((and (not carp) cdrp)                 ; cdr change
        !          1369:                          (list (cons (car exp) (car cdrp))))   
        !          1370:                         (t                                     ; both change 
        !          1371:                          (list (cons (car carp) (car cdrp))))))))))
        !          1372: 
        !          1373: 
        !          1374: ;--- subst : new - sexp
        !          1375: ;           old - sexp
        !          1376: ;           pat - sexp
        !          1377: ; substitutes in patrn all occurrences equal to old with new and returns the
        !          1378: ; result
        !          1379: ; MUST be put in the manual
        !          1380: 
        !          1381: (declare (special new old))
        !          1382: 
        !          1383: (def subst 
        !          1384:   (lambda (new old pat)
        !          1385:          (cond ((symbolp old) (substeq pat))
        !          1386:                (t (substequal pat)))))
        !          1387: 
        !          1388: ;use this function for substituting for symbols
        !          1389: (def substeq
        !          1390:   (lambda (pat)
        !          1391:          (cond ((eq old pat) new)
        !          1392:                ((atom pat) pat)
        !          1393:                (t (cons (substeq (car pat))(substeq (cdr pat)))))))
        !          1394: 
        !          1395: (def substequal
        !          1396:   (lambda (pat)
        !          1397:          (cond ((equal old pat) new)
        !          1398:                ((atom pat) pat)
        !          1399:                (t (cons (substequal (car pat))
        !          1400:                         ; in interlisp, the next line would be
        !          1401:                         ;(substeq (cdr pat))
        !          1402:                         ; for maclisp compatibility, we do this.
        !          1403:                         (substequal (cdr pat)))))))
        !          1404: 
        !          1405: (declare (unspecial new old))
        !          1406: ;--- vi: arg is unevaluated name of function to run vi on
        !          1407: ;
        !          1408: (def vi (nlambda (x) (exvi 'vi x nil)))
        !          1409: 
        !          1410: ;--- vil : arg is unevaluated, edits file and then loads it
        !          1411: ;
        !          1412: (def vil (nlambda (x) (exvi 'vi x t)))
        !          1413: 
        !          1414: ;--- *quo : returns integer part of x/y
        !          1415: ; x and y must be fixnums.
        !          1416: ;
        !          1417: (putd '*quo (getd 'quotient))
        !          1418: 
        !          1419: ;--- xcons : a - sexp
        !          1420: ;           b - sexp
        !          1421: ; returns (b . a)   that is, it is an exchanged cons
        !          1422: ;
        !          1423: (def xcons  (lambda (a b) (cons b a)))
        !          1424: 
        !          1425: 
        !          1426: 
        !          1427: 
        !          1428: 
        !          1429: 
        !          1430: ;--- mode lines, must be last lines of the file
        !          1431: ; vi: set lisp :
        !          1432: ;

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