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