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