![[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.