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