Return to common2.l CVS log

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

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

1.1     ! root        1: (setq rcs-common2-
        !             2:    "$Header: common2.l,v 1.7 83/09/12 15:23:23 layer Exp $")
        !             3: 
        !             4: ;;
        !             5: ;; common2.l                           -[Sat Aug 13 12:55:56 1983 by jkf]-
        !             6: ;;
        !             7: ;; lesser used functions
        !             8: ;;
        !             9: 
        !            10: 
        !            11: (declare (macros t))
        !            12: 
        !            13: ;--- process functions
        !            14: ; these functions permit the user to start up processes and either
        !            15: ; to either wait for their completion or to continue processing,
        !            16: ; communicating with them through a pipe.
        !            17: ;
        !            18: ; the main function, *process, is written in C.  These functions
        !            19: ; handle the common cases
        !            20: ;
        !            21: ;--- *process-send  :: start a process and return port to write to
        !            22: ;
        !            23: (defun *process-send (command)
        !            24:    (cadr (*process command nil t)))
        !            25: 
        !            26: ;--- *process-receive :: start a process and return port to read from
        !            27: ;
        !            28: (defun *process-receive (command)
        !            29:    (car (*process command t)))
        !            30: 
        !            31: ;--- process :: the old nlambda version of process
        !            32: ;  this function is kept around for compatibility
        !            33: ; use: (process command [frompipe [topipe]])
        !            34: ;  if the from and to pipes aren't given, run it and wait
        !            35: ;
        !            36: (defun process fexpr (args)
        !            37:    (declare (*args 1 3))
        !            38:    (let ((command (car args))
        !            39:         (fromport (cadr args))
        !            40:         (toport (caddr args)))
        !            41:       (cond ((null (cdr args)) (*process command))  ; call and wait
        !            42:            (t (let ((res (*process command fromport toport)))
        !            43:                  (cond (fromport (set fromport (cadr res))))
        !            44:                  (cond (toport (set toport (car res))))
        !            45:                  ; return pid
        !            46:                  (caddr res))))))
        !            47: 
        !            48: 
        !            49: ;--- msg : print a message consisting of strings and values
        !            50: ; arguments are:
        !            51: ;   N      - print a newline
        !            52: ;   (N foo) - print foo newlines (foo is evaluated)
        !            53: ;   B       - print a blank
        !            54: ;   (B foo) - print foo blanks (foo is evaluated)
        !            55: ;   (P foo) - print following args to port foo (foo is evaluated)
        !            56: ;   D      - drain
        !            57: ;   other   - evaluate a princ the result (remember strings eval to themselves)
        !            58: 
        !            59: (defmacro msg (&rest msglist)
        !            60:   (do ((ll msglist (cdr ll))
        !            61:        (result)
        !            62:        (cur nil nil)
        !            63:        (curport nil)
        !            64:        (current))
        !            65:       ((null ll) `(progn ,@(nreverse result)))
        !            66:       (setq current (car ll))
        !            67:       (If (dtpr current)
        !            68:          then (If (eq (car current) 'N)
        !            69:                   then (setq cur `(msg-tyo-char 10 ,(cadr current)))
        !            70:                elseif (eq (car current) 'B)
        !            71:                   then (setq cur `(msg-tyo-char 32 ,(cadr current)))
        !            72:                elseif (eq (car current) 'P)
        !            73:                   then (setq curport (cadr current))
        !            74:                else (setq cur `(msg-print ,current)))
        !            75:        elseif (eq current 'N)
        !            76:          then (setq cur (list 'terpr))         ; (can't use backquote
        !            77:        elseif (eq current 'B)                  ; since must have new
        !            78:          then (setq cur (list 'tyo 32))        ; dtpr cell at end)
        !            79:        elseif (eq current 'D)
        !            80:          then (setq cur '(drain))
        !            81:        else (setq cur `(msg-print ,current)))
        !            82:       (If cur 
        !            83:          then (setq result (cons (If curport then (nconc cur (ncons curport))
        !            84:                                              else cur)
        !            85:                                  result)))))
        !            86: 
        !            87: (defun msg-tyo-char (ch n &optional (port nil))
        !            88:   (do ((i n (1- i)))
        !            89:       ((< i 1))
        !            90:       (cond ((eq ch 10) (terpr port))
        !            91:            (t (tyo ch port)))))
        !            92: 
        !            93: (defun msg-print (item &optional (port nil))
        !            94:    (patom item port))
        !            95: 
        !            96: ;--- printblanks :: print out a stream of blanks to the given port
        !            97: ; (printblanks 'x_numberofblanks 'p_port)
        !            98: ;
        !            99: (def printblanks
        !           100:    (lambda (n prt)
        !           101:       (let ((easy (memq n '( 0  ""
        !           102:                             1  " "
        !           103:                             2  "  "
        !           104:                             3  "   "
        !           105:                             4  "    "
        !           106:                             5  "     "
        !           107:                             6  "      "
        !           108:                             7  "       "
        !           109:                             8  "        "))))
        !           110:         (cond (easy (patom (cadr easy) prt))
        !           111:               (t (do ((i n (1- i)))
        !           112:                      ((<& i 1))
        !           113:                      (patom " " prt)))))))
        !           114: 
        !           115: 
        !           116: 
        !           117: 
        !           118: 
        !           119: ; --- linelength [numb]
        !           120: ;
        !           121: ; sets the linelength (actually just varib linel) to the
        !           122: ; number given: numb
        !           123: ; if numb is not given, the current line length is returned
        !           124: ; 
        !           125: 
        !           126: (declare (special linel))
        !           127: 
        !           128: (setq linel 80)
        !           129: 
        !           130: (def linelength
        !           131:      (nlambda (form)
        !           132:              (cond ((null form) linel )
        !           133:                    ((numberp (car form)) (setq linel (car form)))
        !           134:                    (t linel))))
        !           135: 
        !           136: ; ========================================
        !           137: ;
        !           138: ;      (charcnt port) 
        !           139: ; returns the number of characters left on the current line
        !           140: ; on the given port
        !           141: ;
        !           142: ; =======================================
        !           143: 
        !           144: 
        !           145: (def charcnt
        !           146:      (lambda (port) (- linel (nwritn port))))
        !           147: 
        !           148: ;--- nthcdr :: do n cdrs of the list and return the result
        !           149: ;
        !           150: ; 
        !           151: (defun nthcdr (index list)
        !           152:    (cond ((fixp index)
        !           153:          (cond ((<& index 0)
        !           154:                 (cons nil list))
        !           155:                ((=& index 0)
        !           156:                 list)
        !           157:                (t (nthcdr (1- index) (cdr list)))))
        !           158:         (t (error "Non fixnum first argument to nthcdr " index))))
        !           159: 
        !           160: ;--- nthcdr (cmacro) :: version of nthcdr for use by the compiler
        !           161: ;
        !           162: (defcmacro nthcdr (index list)
        !           163:    (if (and (fixp index) (=& index 0))
        !           164:       then list        ; (nthcdr 0 expr) => expr
        !           165:       else (let ((val (assq index '((1  . cdr)
        !           166:                                    (2  . cddr)
        !           167:                                    (3  . cdddr)
        !           168:                                    (4  . cddddr)
        !           169:                                    (5  . cdddddr)
        !           170:                                    (6  . cddddddr)))))
        !           171:              (cond (val `(,(cdr val) ,list))   ; (nthcdr 1-6 list)
        !           172:                    (t `(nthcdr ,index ,list)))))) ; other cases
        !           173: 
        !           174: 
        !           175: ;--- nth :: return nth element of the list
        !           176: ; cdr index times and then car to get the element.
        !           177: ; thus the first element is 0
        !           178: ;
        !           179: (defun nth (index list)
        !           180:    (car (nthcdr index list)))
        !           181: 
        !           182: ;--- nth (cmacro) :: compiler macro to do the same thing
        !           183: ;
        !           184: (defcmacro nth (index list)
        !           185:    `(car (nthcdr ,index ,list)))
        !           186: 
        !           187:    
        !           188: 
        !           189: 
        !           190: ;;==============================
        !           191: ;  (assqr val alist)
        !           192: ; acts much like assq, it looks for val in the cdr of elements of
        !           193: ; the alist and returns the element if found.
        !           194: ; fix this when the compiler works
        !           195: (eval-when nil (def assqr 
        !           196:     (lambda (val alist)
        !           197:        (do ((al alist (cdr al)))
        !           198:            ((null al) nil)
        !           199:            (cond ((eq val (cdar al)) (return (car al))))))))
        !           200: 
        !           201: 
        !           202: ; ====================
        !           203: ; (listp 'x) is t if x is a non-atom or nil
        !           204: ; ====================
        !           205: (def listp (lambda (val) (or (dtpr val) (null val))))
        !           206: 
        !           207: 
        !           208: 
        !           209: ;--- memcar - VAL : lispval
        !           210: ;          - LIS : list
        !           211: ;      returns t if VAL found as the car of a top level element.
        !           212: ;temporarily turn this off till the compiler can handle it.
        !           213: (eval-when nil (def memcar 
        !           214:   (lambda (a l)
        !           215:          (do ((ll l (cdr ll)))
        !           216:              ((null ll) nil)
        !           217:              (cond ((equal (caar ll) a) (return (cdar ll))))))))
        !           218: 
        !           219: ; =================================
        !           220: ;
        !           221: ;      (memcdr 'val 'listl)
        !           222: ;
        !           223: ; the list listl is searched for a list
        !           224: ; with cdr equal to val. if found, the
        !           225: ; car of that list is returned.
        !           226: ; ==================================
        !           227: ;fix this when compiler works ok
        !           228: (eval-when nil (def memcdr 
        !           229:   (lambda (a l)
        !           230:          (do ((ll l (cdr ll)))
        !           231:              ((null ll) nil)
        !           232:              (cond ((equal (cdar ll) a) (return (caar l))))))))
        !           233: 
        !           234: 
        !           235: ;this looks like funcall, so we will just use it
        !           236: '(def apply* 
        !           237:   (nlambda ($x$)
        !           238:        (eval (cons (eval (car $x$)) (cdr $x$)))))
        !           239: 
        !           240: (putd 'apply* (getd 'funcall))
        !           241: 
        !           242: (defun remq (item list &optional (cnt -1))     ;no tail recursion sucks.
        !           243:    (let ((head nil)
        !           244:         (tail nil))
        !           245:       (do ((l list (cdr l))
        !           246:           (newcell))
        !           247:          ((null l) head)
        !           248:          (cond ((or (not (eq (car l) item))
        !           249:                     (=& 0 cnt))
        !           250:                 (setq newcell (list (car l)))
        !           251:                 (cond ((null head) (setq head newcell))
        !           252:                       (t (rplacd tail newcell)))
        !           253:                 (setq tail newcell))
        !           254:                (t (setq cnt (1- cnt)))))))
        !           255: 
        !           256: (defun tab n
        !           257:    (prog (nn prt over)
        !           258:       (setq nn (arg 1))
        !           259:       (cond ((>& n 1) (setq prt (arg 2))))
        !           260:       (cond ((>& (setq over (nwritn prt)) nn)
        !           261:             (terpri prt)
        !           262:             (setq over 0)))
        !           263:       (printblanks (- nn over) prt)))
        !           264: 
        !           265: ;--- charcnt :: returns the number of characters left on the current line
        !           266: ;      p - port
        !           267: ;(local function)
        !           268: (def charcnt
        !           269:      (lambda (port) (- linel (nwritn port))))
        !           270: 
        !           271: ;(local function)
        !           272: ;
        !           273: (declare (special $outport$))
        !           274: (def $patom1 (lambda (x) (patom x $outport$)))
        !           275: 
        !           276: ;;; --- cmu  functions ---
        !           277: (def attach
        !           278:    (lambda (x y)
        !           279:           (cond ((dtpr y) (rplacd y (cons (car y) (cdr y))) (rplaca y x))
        !           280:                 (t (error "An atom can't be attached to " y)))))
        !           281: (def Cnth
        !           282:    (lambda (x n)
        !           283:           (cond ((> 1 n) (cons nil x))
        !           284:                 (t
        !           285:                    (prog nil
        !           286:                     lp   (cond ((or (atom x) (eq n 1)) (return x)))
        !           287:                          (setq x (cdr x))
        !           288:                          (setq n (1- n))
        !           289:                          (go lp))))))
        !           290: 
        !           291: 
        !           292: 
        !           293: 
        !           294: (def dsubst
        !           295:    (lambda (x y z)
        !           296:           (prog (b)
        !           297:                 (cond ((eq y (setq b z)) (return (copy x))))
        !           298:                 lp
        !           299:                 (cond ((atom z) (return b))
        !           300:                       ((cond ((symbolp y) (eq y (car z))) (t (equal y (car z))))
        !           301:                        (rplaca z (copy x)))
        !           302:                       (t (dsubst x y (car z))))
        !           303:                 (cond ((and y (eq y (cdr z))) (rplacd z (copy x)) (return b)))
        !           304:                 (setq z (cdr z))
        !           305:                 (go lp))))
        !           306: 
        !           307: (putd 'eqstr (getd 'equal))
        !           308: 
        !           309: (defun insert (x l comparefn nodups)
        !           310:       (cond ((null l) (list x))
        !           311:             ((atom l) (error "an atom, can't be inserted into" l))
        !           312:             ((and nodups (member x l)) l)
        !           313:            (t (cond
        !           314:                 ((null comparefn) (setq comparefn (function alphalessp))))
        !           315:                (prog (l1 n n1 y)
        !           316:                      (setq l1 l)
        !           317:                      (setq n (length l))
        !           318:                 a    (setq n1 (/ (add1 n) 2))
        !           319:                      (setq y (Cnth l1 n1))
        !           320:                      (cond ((< n 3)
        !           321:                             (cond ((funcall comparefn x (car y))
        !           322:                                    (cond
        !           323:                                     ((not (equal x (car y)))
        !           324:                                      (rplacd y (cons (car y) (cdr y)))
        !           325:                                      (rplaca y x))))
        !           326:                                   ((eq n 1) (rplacd y (cons x (cdr y))))
        !           327:                                   ((funcall comparefn x (cadr y))
        !           328:                                    (cond
        !           329:                                     ((not (equal x (cadr y)))
        !           330:                                      (rplacd (cdr y)
        !           331:                                              (cons (cadr y) (cddr y)))
        !           332:                                      (rplaca (cdr y) x))))
        !           333:                                   (t (rplacd (cdr y) (cons x (cddr y))))))
        !           334:                            ((funcall comparefn x (car y))
        !           335:                             (cond
        !           336:                              ((not (equal x (car y)))
        !           337:                               (setq n (sub1 n1))
        !           338:                               (go a))))
        !           339:                            (t (setq l1 (cdr y)) (setq n (- n n1)) (go a))))
        !           340:                l)))
        !           341: 
        !           342: 
        !           343: 
        !           344: 
        !           345: (def kwote (lambda (x) (list 'quote x)))
        !           346: 
        !           347: (def lconc
        !           348:      (lambda 
        !           349:       (ptr x)
        !           350:       (prog (xx)
        !           351:             (return
        !           352:              (cond ((atom x) ptr)
        !           353:                    (t (setq xx (last x))
        !           354:                       (cond ((atom ptr) (cons x xx))
        !           355:                             ((dtpr (cdr ptr))
        !           356:                              (rplacd (cdr ptr) x)
        !           357:                              (rplacd ptr xx))
        !           358:                             (t (rplaca (rplacd ptr xx) x)))))))))
        !           359: (def ldiff
        !           360:      (lambda (x y)
        !           361:       (cond ((eq x y) nil)
        !           362:             ((null y) x)
        !           363:             (t
        !           364:              (prog (v z)
        !           365:                    (setq z (setq v (ncons (car x))))
        !           366:               loop (setq x (cdr x))
        !           367:                    (cond ((eq x y) (return z))
        !           368:                          ((null x) (error "not a tail - ldiff")))
        !           369:                    (setq v (cdr (rplacd v (ncons (car x)))))
        !           370:                    (go loop))))))
        !           371: 
        !           372: (def lsubst
        !           373:      (lambda (x y z)
        !           374:       (cond ((null z) nil)
        !           375:             ((atom z) (cond ((eq y z) x) (t z)))
        !           376:             ((equal y (car z)) (nconc (copy x) (lsubst x y (cdr z))))
        !           377:             (t (cons (lsubst x y (car z)) (lsubst x y (cdr z)))))))
        !           378: 
        !           379: (def merge
        !           380:    (lambda (a b %%cfn)
        !           381:       (declare (special %%cfn))
        !           382:       (cond ((null %%cfn) (setq %%cfn (function alphalessp))))
        !           383:       (merge1 a b)))
        !           384: 
        !           385: (def merge1
        !           386:    (lambda (a b)
        !           387:       (declare (special %%cfn))
        !           388:       (cond ((null a) b)
        !           389:            ((null b) a)
        !           390:            (t
        !           391:               (prog (val end)
        !           392:                  (setq val
        !           393:                        (setq end
        !           394:                              (cond ((funcall %%cfn (car a) (car b))
        !           395:                                     (prog1 a (setq a (cdr a))))
        !           396:                                    (t (prog1 b (setq b (cdr b)))))))
        !           397:                  loop (cond ((null a) (rplacd end b) (return val))
        !           398:                             ((null b) (rplacd end a) (return val))
        !           399:                             ((funcall %%cfn (car a) (car b))
        !           400:                              (rplacd end a)
        !           401:                              (setq a (cdr a)))
        !           402:                             (t (rplacd end b) (setq b (cdr b))))
        !           403:                  (setq end (cdr end))
        !           404:                  (go loop))))))
        !           405: 
        !           406: (defmacro neq (a b) `(not (eq ,a ,b)))
        !           407: 
        !           408: (putd 'nthchar (getd 'getchar))
        !           409: ;(def nthchar
        !           410: ;     (lambda (x n)
        !           411: ;      (cond ((plusp n) (car (Cnth (explodec x) n)))
        !           412: ;            ((minusp n) (car (Cnth (reverse (explodec x)) (minus n))))
        !           413: ;            ((zerop n) nil))))
        !           414: 
        !           415: (defmacro quote! (&rest a) (quote!-expr-mac a))
        !           416: 
        !           417: (eval-when (compile eval load)
        !           418:    
        !           419: (defun quote!-expr-mac (form)
        !           420:    (cond ((null form) nil)
        !           421:         ((atom form) `',form)
        !           422:         ((eq (car form) '!)
        !           423:          `(cons ,(cadr form) ,(quote!-expr-mac (cddr form))))
        !           424:         ((eq (car form) '!!)
        !           425:          (cond ((cddr form) `(append ,(cadr form)
        !           426:                                       ,(quote!-expr-mac (cddr form))))
        !           427:                (t (cadr form))))
        !           428:         (t `(cons ,(quote!-expr-mac (car form))
        !           429:                    ,(quote!-expr-mac (cdr form))))))
        !           430: 
        !           431: )
        !           432: 
        !           433: (defun remove (item list &optional (cnt -1))
        !           434:   (let ((head '())
        !           435:        (tail nil))
        !           436:     (do ((l list (cdr l))
        !           437:         (newcell))
        !           438:        ((null l) head)
        !           439:       (cond ((or (not (equal (car l) item))
        !           440:                 (zerop cnt))
        !           441:             (setq newcell (list (car l)))
        !           442:             (cond ((null head) (setq head newcell))
        !           443:                   (t (rplacd tail newcell)))
        !           444:             (setq tail newcell))
        !           445:            (t (setq cnt (1- cnt)))))))
        !           446: 
        !           447: (def subpair
        !           448:      (lambda (old new expr)
        !           449:       (cond (old (subpr expr old (or new '(nil)))) (t expr))))
        !           450: 
        !           451: (def subpr
        !           452:    (lambda (expr l1 l2)
        !           453:           (prog (d a)
        !           454:                 (cond ((atom expr) (go lp))
        !           455:                       ((setq d (cdr expr)) (setq d (subpr d l1 l2))))
        !           456:                 (setq a (subpr (car expr) l1 l2))
        !           457:                 (return
        !           458:                    (cond ((or (neq a (car expr))
        !           459:                               (neq d (cdr expr))) (cons a d))
        !           460:                          (t expr)))
        !           461:                 lp   (cond ((null l1) (return expr))
        !           462:                            (l2 (cond ((eq expr (car l1))
        !           463:                                       (return (car l2)))))
        !           464:                            (t (cond ((eq expr (caar l1))
        !           465:                                      (return (cdar l1))))))
        !           466:                 (setq l1 (cdr l1))
        !           467:                 (and l2 (setq l2 (or (cdr l2) '(nil))))
        !           468:                 (go lp))))
        !           469: (def tailp
        !           470:    (lambda (x y)
        !           471:           (and x
        !           472:                (prog nil
        !           473:                      lp   (cond ((atom y) (return nil)) ((eq x y) (return x)))
        !           474:                  (setq y (cdr y))
        !           475:                  (go lp)))))
        !           476: 
        !           477: (def tconc
        !           478:      (lambda (p x)
        !           479:       (cond ((atom p) (cons (setq x (ncons x)) x))
        !           480:             ((dtpr (cdr p)) (rplacd p (cdr (rplacd (cdr p) (ncons x)))))
        !           481:             (t (rplaca p (cdr (rplacd p (ncons x))))))))
        !           482: 
        !           483: ;--- int:vector-range-error
        !           484: ; this is called from compiled code if a vector reference is made
        !           485: ; which is out of bounds.  it should print an error message and
        !           486: ; never return
        !           487: (defun int:vector-range-error (vec index)
        !           488:    (error "vector index out of range detected in compiled code "
        !           489:          (list vec index)))
        !           490: 
        !           491: ;--- int:wrong-number-of-args-error :: pass wna error message to user
        !           492: ; this is called from compiled code (through wnaerr in the C interpreter)
        !           493: ; when it has been detected that the wrong number of arguments have
        !           494: ; been passed.  The state of the arguments are:
        !           495: ;      args 1 to (- n 3) are the acutal arguments
        !           496: ;      arg (- n 2) is the name of the function called
        !           497: ;      arg (- n 1) is the minimum number of arguments allowed
        !           498: ;      arg n is the maximum number of arguments allowed
        !           499: ;              (or -1 if there is no maximum)
        !           500: (defun int:wrong-number-of-args-error n
        !           501:    (let ((max (arg n))
        !           502:         (min (arg (1- n)))
        !           503:         (name (arg (- n 2))))
        !           504:       (do ((i (- n 3) (1- i))
        !           505:           (x)
        !           506:           (args))
        !           507:          ((<& i 1)
        !           508:           ; cases
        !           509:           ;  exact number
        !           510:           ;  min and max
        !           511:           ;  only a min
        !           512:           (if (=& min max)
        !           513:              then (setq x
        !           514:                    (format nil
        !           515:                     "`~a' expects ~r argument~p but was given ~@d:"
        !           516:                     name min min (length args)))
        !           517:            elseif (=& max -1)
        !           518:              then (setq x
        !           519:                    (format nil
        !           520:                     "`~a' expects at least ~r argument~p but was given ~@d:"
        !           521:                      name min min (length args)))
        !           522:              else (setq x
        !           523:                    (format nil
        !           524:                     "`~a' expects between ~r and ~r arguments but was given ~@d:"
        !           525:                     name min max (length args))))
        !           526:                   
        !           527:           (error x args))
        !           528:          (push (arg i) args))))   
        !           529: ;--- functions to retrieve parts of the vector returned by
        !           530: ;    filestat
        !           531: ;
        !           532: (eval-when (compile eval)
        !           533:    (defmacro filestat-chk (name index)
        !           534:             `(defun ,name (arg)
        !           535:                      (cond ((vectorp arg)
        !           536:                             (vref arg ,index))
        !           537:                            (t (error (concat ',name '|: bad arg |) arg))))))
        !           538: (filestat-chk filestat:mode    0)
        !           539: (filestat-chk filestat:type    1)
        !           540: (filestat-chk filestat:nlink   2)
        !           541: (filestat-chk filestat:uid     3)
        !           542: (filestat-chk filestat:gid     4)
        !           543: (filestat-chk filestat:size    5)
        !           544: (filestat-chk filestat:atime   6)
        !           545: (filestat-chk filestat:mtime   7)
        !           546: (filestat-chk filestat:ctime   8)
        !           547: (filestat-chk filestat:dev     9)
        !           548: (filestat-chk filestat:rdev    10)
        !           549: (filestat-chk filestat:ino     11)
        !           550: 
        !           551: ;; lisp coded showstack and baktrace.
        !           552: ;;
        !           553: 
        !           554: (declare (special showstack-prinlevel showstack-prinlength
        !           555:                  showstack-printer prinlevel prinlength))
        !           556: 
        !           557: (or (boundp 'showstack-prinlevel) (setq showstack-prinlevel 3))
        !           558: (or (boundp 'showstack-prinlength) (setq showstack-prinlength 4))
        !           559: (or (boundp 'showstack-printer)        (setq showstack-printer 'print))
        !           560: (or (getd 'old-showstack) (putd 'old-showstack (getd  'showstack)))
        !           561: (or (getd 'old-baktrace) (putd 'old-baktrace (getd  'baktrace)))
        !           562: 
        !           563: ;--- showstack :: do a stack backtrace.
        !           564: ; arguments (unevaluated) are
        !           565: ;      t  - print trace expressions too (normally they are not printed)
        !           566: ;      N  - for some fixnum N, only print N levels.
        !           567: ;      len N - set prinlength to N
        !           568: ;      lev N - set prinlevel to N
        !           569: ;
        !           570: (defun showstack fexpr (args)
        !           571:    (showstack-baktrace args t))
        !           572: 
        !           573: (defun baktrace fexpr (args)
        !           574:    (showstack-baktrace args nil))
        !           575: 
        !           576: (defun showstack-baktrace (args showstackp)
        !           577:    (let ((print-trace nil)
        !           578:         (levels-to-print -1)
        !           579:         (prinlevel showstack-prinlevel)
        !           580:         (prinlength showstack-prinlength)
        !           581:         (res nil)
        !           582:         (newres nil)
        !           583:         (oldval nil)
        !           584:         (stk nil))
        !           585:       ;; scan arguments
        !           586:       (do ((xx args (cdr xx)))
        !           587:          ((null xx))
        !           588:          (cond ((eq t (car xx)) (setq print-trace t))
        !           589:                ((fixp (car xx)) (setq levels-to-print (car xx)))
        !           590:                ((eq 'lev (car xx))
        !           591:                 (setq xx (cdr xx) prinlevel (car xx)))
        !           592:                ((eq 'len (car xx))
        !           593:                 (setq xx (cdr xx) prinlength (car xx)))))
        !           594:       ;; print the levels
        !           595:       (do ((levs levels-to-print)
        !           596:           (firsttime t nil))
        !           597:          ((or (equal 0 stk)
        !           598:               (zerop levs))
        !           599:           (terpr))
        !           600:          (setq res (int:showstack stk))
        !           601:          (cond ((null res) (terpr) (return nil)))
        !           602:          (setq stk (cdr res)
        !           603:                res (car res))
        !           604:          (cond ((or print-trace (not (trace-funp res)))
        !           605:                 (cond ((and oldval showstackp)
        !           606:                        (setq newres (subst-eq '<**> oldval res)))
        !           607:                       (t (setq newres res)))
        !           608:                 (cond (showstackp (funcall showstack-printer newres) (terpr))
        !           609:                       (t (baktraceprint newres firsttime)))
        !           610:                 (setq levs (1- levs))
        !           611:                 (setq oldval res))))))
        !           612: 
        !           613: (defun baktraceprint (form firsttime)
        !           614:    (cond ((not firsttime) (patom " -- ")))
        !           615:    (cond ((> (nwritn) 65) (terpr)))
        !           616:    (cond ((atom form) (print form))
        !           617:         (t (let ((prinlevel 1)
        !           618:                  (prinlength 2))
        !           619:               (cond ((dtpr form) (print (car form)))
        !           620:                     (t (print form)))))))
        !           621: 
        !           622: 
        !           623: ;--- trace-funp  :: see if this is a trace function call
        !           624: ; return t if this call is a result of tracing a function, or of calling
        !           625: ; showstack
        !           626: ;
        !           627: (defun trace-funp (expr)
        !           628:    (or (and (symbolp expr)
        !           629:            (memq expr '(T-eval  T-apply T-setq
        !           630:                                 eval int:showstack showstack-baktrace)))
        !           631:        (and (dtpr expr)
        !           632:            (cond ((symbolp (car expr))
        !           633:                   (memq (car expr) '(trace-break T-cond T-eval T-setq
        !           634:                                                  T-apply)))
        !           635:                  ((dtpr (car expr))
        !           636:                   (and (eq 'lambda (caar expr))
        !           637:                        (eq 'T-arglst (caadar expr))))))))
        !           638: 
        !           639: ;--- subst-eq  :: replace parts eq to new with old
        !           640: ; make new list structure
        !           641: ;
        !           642: (defun subst-eq (new old list)
        !           643:    (cond ((eq old list)
        !           644:          new)
        !           645:         ((and (dtpr list)
        !           646:               (subst-eqp old list))
        !           647:          (cond ((eq old (car list))
        !           648:                 (cons new (subst-eq new old (cdr list))))
        !           649:                ((dtpr (car list))
        !           650:                 (cons (subst-eq new old (car list))
        !           651:                       (subst-eq new old (cdr list))))
        !           652:                (t (cons (car list)
        !           653:                         (subst-eq new old (cdr list))))))
        !           654:         (t list)))
        !           655: 
        !           656: (defun subst-eqp (old list)
        !           657:    (cond ((eq old list) t)
        !           658:         ((dtpr list)
        !           659:          (or (subst-eqp old (car list))
        !           660:              (subst-eqp old (cdr list))))
        !           661:         (t nil)))
        !           662: 
        !           663: 
        !           664: 
        !           665: ;;; environment macros
        !           666: 
        !           667: (defmacro environment (&rest args)
        !           668:    (do ((xx args (cddr xx))
        !           669:        (when)(action)(res))
        !           670:        ((null xx)
        !           671:        `(progn 'compile
        !           672:                ,@(nreverse res)))
        !           673:        (setq when (car xx)
        !           674:             action (cadr xx))
        !           675:        (if (atom when)
        !           676:          then (setq when (ncons when)))
        !           677:        (if (and (dtpr action)
        !           678:                (symbolp (car action)))
        !           679:          then (setq action (cons (concat "environment-" (car action))
        !           680:                                  (cdr action))))
        !           681:        (push `(eval-when ,when ,action) res)))
        !           682:        
        !           683: 
        !           684: (defun environment-files fexpr (names)
        !           685:    (mapc '(lambda (filename)
        !           686:             (if (not (get filename 'version)) then (load filename)))
        !           687:         names))
        !           688: 
        !           689: (defun environment-syntax fexpr (names)
        !           690:    (mapc '(lambda (class)
        !           691:             (caseq class
        !           692:                 (maclisp (cvttomaclisp))
        !           693:                 (intlisp (cvttointlisp))
        !           694:                 (ucilisp (cvttoucilisp))
        !           695:                 ((franz franzlisp) (cvttofranzlisp))
        !           696:                 (t (error "unknown syntax conversion type " class))))
        !           697:         names))
        !           698: 
        !           699: ;--- standard environments
        !           700: (defmacro environment-maclisp (&rest args)
        !           701:    `(environment (compile load eval) (files machacks)
        !           702:                 (compile eval) (syntax maclisp)
        !           703:                 ,@args))
        !           704: 
        !           705: 
        !           706: (defmacro environment-lmlisp (&rest args)
        !           707:    `(environment (compile load eval) (files machacks lmhacks)
        !           708:                 (compile eval) (syntax maclisp)
        !           709:                 ,@args))
        !           710: 
        !           711: ;;;--- i/o functions redefined.
        !           712: ; The common I/O functions are redefined here to do tilde expansion
        !           713: ; if the tilde-expansion symbol is non nil
        !           714: (declare (special tilde-expansion))
        !           715:    
        !           716: ;First, define the current <name> as int:<name>
        !           717: ;
        !           718: (cond ((null (getd 'int:infile))
        !           719:        (putd 'int:infile (getd 'infile))
        !           720:        (putd 'int:outfile (getd 'outfile))
        !           721:        (putd 'int:fileopen (getd 'fileopen))
        !           722:        (putd 'int:cfasl (getd 'cfasl))
        !           723:        (putd 'int:fasl (getd 'fasl))))
        !           724: 
        !           725: ;Second, define the new functions:
        !           726: 
        !           727: (defun infile (filename)
        !           728:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           729:          (error "infile: non symbol or string filename " filename)))
        !           730:    (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           731:    (int:infile filename))
        !           732: 
        !           733: (defun outfile (filename &optional args)
        !           734:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           735:          (error "outfile: non symbol or string filename " filename)))
        !           736:    (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           737:    (int:outfile filename args))
        !           738: 
        !           739: ;--- fileopen :: open a file with a non-standard stdio file
        !           740: ;  [this should probably be flushed because it depends on stdio,
        !           741: ;   which we may not use in the future]
        !           742: (defun fileopen (filename mode)
        !           743:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           744:          (error "fileopen: non symbol or string filename " filename)))
        !           745:    (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           746:    (int:fileopen filename mode))
        !           747: 
        !           748: (defun fasl (filename &rest args)
        !           749:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           750:          (error "fasl: non symbol or string filename " filename)))
        !           751:    (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           752:    (lexpr-funcall 'int:fasl filename args))
        !           753: 
        !           754: (defun cfasl (filename &rest args)
        !           755:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           756:          (error "cfasl: non symbol or string filename " filename)))
        !           757:    (cond (tilde-expansion (setq filename (tilde-expand filename))))
        !           758:    (lexpr-funcall 'int:cfasl filename args))
        !           759: 
        !           760: 
        !           761: ;--- probef :: test if a file exists
        !           762: ;
        !           763: (defun probef (filename)
        !           764:    (cond ((not (or (symbolp filename) (stringp filename)))
        !           765:          (error "probef: non symbol or string filename " filename)))
        !           766:    (sys:access filename 0))
        !           767: 
        !           768: 
        !           769: 
        !           770: (declare (special user-name-to-dir-cache))
        !           771: (or (boundp 'user-name-to-dir-cache) (setq user-name-to-dir-cache nil))
        !           772: 
        !           773: ;--- username-to-dir
        !           774: ; given a user name, return the home directory name
        !           775: ;
        !           776: (defun username-to-dir (name)
        !           777:    (cond ((symbolp name) (setq name (get_pname name)))
        !           778:         ((stringp name))
        !           779:         (t (error "username-to-dir: Illegal name " name)))
        !           780:    (let ((val (assoc name user-name-to-dir-cache)))
        !           781:       (cond ((null val)
        !           782:             (setq val (sys:getpwnam name))
        !           783:             (cond (val (push (cons name val) user-name-to-dir-cache))))
        !           784:            (t (setq val (cdr val))))
        !           785:       (cond (val (sys:getpwnam-dir val)))))
        !           786:                    
        !           787: ;--- username-to-dir-flush-cache :: clear all memory of where users are
        !           788: ; it is important to call this function upon startup to clear all
        !           789: ; knowledge of pathnames since this object file could have been copied
        !           790: ; from another machine
        !           791: ;
        !           792: (defun username-to-dir-flush-cache ()
        !           793:    (setq user-name-to-dir-cache nil))
        !           794: 
        !           795: ;--- lisp interface to int:franz-call
        !           796: ;
        !           797: (eval-when (compile eval)
        !           798:    (setq fc_getpwnam 1   fc_access 2  fc_chdir 3  fc_unlink 4
        !           799:         fc_time   5     fc_chmod  6  fc_getpid 7 fc_stat  8
        !           800:         fc_gethostname 9 fc_link 10))
        !           801: 
        !           802: ;--- sys:getpwnam
        !           803: ; (sys:getpwnam 'st_username)
        !           804: ; rets vector: (t_name x_uid x_gid t_dir)
        !           805: ;
        !           806: (defun sys:getpwnam (name)
        !           807:    (cond ((or (symbolp name) (stringp name))
        !           808:          (int:franz-call #.fc_getpwnam name))
        !           809:         (t (error "sys:getpwnam : illegal name " name))))
        !           810: 
        !           811: ; return dir portion
        !           812: ;
        !           813: (defun sys:getpwnam-dir (vec) (vref vec 3))
        !           814: 
        !           815: (defun sys:access (name class)
        !           816:    (cond ((and (or (symbolp name) (stringp name))
        !           817:               (fixp class))
        !           818:          (cond (tilde-expansion (setq name (tilde-expand name))))
        !           819:          (zerop (int:franz-call #.fc_access name class)))
        !           820:         (t (error "sys:access : illegal name or class " name class))))
        !           821: 
        !           822: (defun chdir (dir)
        !           823:    (cond ((or (symbolp dir) (stringp dir))
        !           824:          (cond (tilde-expansion (setq dir (tilde-expand dir))))
        !           825:          (cond ((zerop (int:franz-call #.fc_chdir dir)))
        !           826:                (t (error "cd: can't chdir to " dir))))
        !           827:         (t (error "chdir: illegal argument " dir))))
        !           828: 
        !           829: ;--- sys:unlink :: unlink (remove) a file
        !           830: ;
        !           831: (defun sys:unlink (name)
        !           832:    (cond ((or (symbolp name) (stringp name))
        !           833:          (cond (tilde-expansion (setq name (tilde-expand name))))
        !           834:          (cond ((zerop (int:franz-call #.fc_unlink name)))
        !           835:                (t (error "sys:unlink : unlink failed of " name))))
        !           836:         (t (error "sys:unlink : illegal argument " name))))
        !           837: 
        !           838: ;--- sys:link :: make (hard) link to file
        !           839: ;
        !           840: (defun sys:link (oldname newname)
        !           841:    (cond ((or (symbolp oldname) (stringp oldname))
        !           842:          (cond (tilde-expansion (setq oldname (tilde-expand oldname))))
        !           843:          (cond ((or (symbolp newname) (stringp newname))
        !           844:                 (cond (tilde-expansion (setq newname 
        !           845:                                                (tilde-expand newname))))
        !           846:                 (cond ((zerop (int:franz-call #.fc_link oldname newname)))
        !           847:                       (t (error "sys:link : unlink failed of "
        !           848:                                 oldname newname))))
        !           849:                (t (error "sys:unlink : illegal argument " newname))))
        !           850:         (t (error "sys:unlink : illegal argument " oldname))))
        !           851: 
        !           852: ;--- sys:time :: return 'absolute' time in seconds
        !           853: ;
        !           854: (defun sys:time ()
        !           855:    (int:franz-call #.fc_time))
        !           856: 
        !           857: ;--- sys:chmod :: change mode of file
        !           858: ; return t iff it succeeded.
        !           859: ;
        !           860: (defun sys:chmod (name mode)
        !           861:    (cond ((and (or (stringp name) (symbolp name))
        !           862:               (fixp mode))
        !           863:          (cond (tilde-expansion (setq name (tilde-expand name))))
        !           864:          (cond ((zerop (int:franz-call #.fc_chmod name mode)))
        !           865:                (t (error "sys:chmod : chmod failed of " name))))
        !           866:         (t (error "sys:chmod : illegal argument(s): " name mode))))
        !           867:    
        !           868: (defun sys:getpid ()
        !           869:    (int:franz-call #.fc_getpid))
        !           870: 
        !           871: (defun filestat (name)
        !           872:    (let (ret)
        !           873:       (cond ((or (symbolp name) (stringp name))
        !           874:             (cond (tilde-expansion (setq name (tilde-expand name))))
        !           875:             (cond ((null (setq ret (int:franz-call #.fc_stat name)))
        !           876:                    (error "filestat : file doesn't exist " name))
        !           877:                   (t ret)))
        !           878:            (t (error "filestat : illegal argument " name)))))
        !           879: 
        !           880: ;--- sys:gethostname :: retrieve the current host name as a string
        !           881: ;
        !           882: (defun sys:gethostname ()
        !           883:    (int:franz-call #.fc_gethostname))
        !           884: 

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