![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ucifnc.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib|
Return to ucifnc.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-ucifnc-
2: "$Header: /usr/lib/lisp/ucifnc.l,v 1.1 83/01/29 18:41:16 jkf Exp $")
3:
4: ;
5: ; There is problems with the ucilisp do being
6: ; incompatible with maclisp/franz do,
7: ; The problems with compiling do are gone, but
8: ; due to these possible problems, the ucilisp do function
9: ; is in a seperate file ucido.l and users of it
10: ; should also load that file in at compile time before
11: ; any call to do (since do is a macro) (and
12: ; at runtime if do is to be interpreted).
13: ;
14: ; This file is meant to be fasl'd or used with liszt -u
15: ; not to be read in interpretively (the syntax changes
16: ; will not work in that case.
17: ;
18: ; to compile this file do liszt ucifnc.l
19: ;
20: ; one who wants to use these functions or compile and run
21: ; a ucilisp program should do both
22: ; liszt -u file.l when compiling.
23: ; and
24: ; (fasl '/usr/lib/lisp/ucifnc)
25: ; before loading in and running them
26: ; programs in lisp.
27: ; This is because some functions are macros and others are too
28: ; complicated and need other functions around.
29: ; Note this file will not load in directly and when fasl'd in will
30: ; cause the syntax of lisp to change to ucilisp syntax.
31: ;
32: (declare (macros t))
33:
34: ;
35: ; ucilisp (de df dm) declare function macros.
36: ;
37: ; (de name args body) -> declare exprs and lexprs.
38: ;
39: (defun de macro (l)
40: `(defun ,@(cdr l)))
41:
42: ;
43: ; (df name args body) -> declare fexprs.
44: ;
45: (defun df macro (l)
46: `(defun ,(cadr l)
47: fexpr
48: ,@(cddr l)))
49:
50: ;
51: ; macro's are not compiled except under the same
52: ; conditions as in franz lisp.
53: ; (usually just do (declare (macros t))
54: ; to have macros also compiled).
55: ;
56: ;
57: ; (dm name args body) -> declare macros. same as (defun name 'macro body)
58: ;
59: (defun dm macro (l)
60: `(defun ,(cadr l)
61: macro
62: ,@(cddr l)))
63:
64: ;
65: ; ucilisp let macro.
66: ;
67: (eval-when (compile load eval)
68: (defun let1 (l vars vals body)
69: (cond ((null l)
70: (cons (cons 'lambda (cons vars body)) vals))
71: (t
72: (let1 (cddr l)
73: (cons (car l) vars)
74: (cons (cadr l) vals) body)))))
75:
76: (defun let macro (l)
77: (let1 (cadr l) nil nil (cddr l)))
78:
79: (defun nconc1 macro (l)
80: `(nconc ,(cadr l) (list ,(caddr l))))
81:
82: (putd 'expandmacro (getd 'macroexpand))
83:
84: ;
85: ; ucilisp selectq function. (written by jkf)
86: ;
87: (def selectq
88: (macro (form)
89: ((lambda (x)
90: `((lambda (,x)
91: (cond
92: ,@(maplist
93: '(lambda (ff)
94: (cond ((null (cdr ff))
95: `(t ,(car ff)))
96: ((atom (caar ff))
97: `((eq ,x ',(caar ff))
98: . ,(cdar ff)))
99: (t
100: `((memq ,x ',(caar ff))
101: . ,(cdar ff)))))
102: (cddr form))))
103: ,(cadr form)))
104: (gensym 'Z))))
105:
106: ;
107: ; ucilisp functions which declare read macros.
108: ;
109: ; dsm - declare splicing read macro.
110: ;
111: (defun dsm macro (l)
112: `(eval-when (compile load eval)
113: (setsyntax ',(cadr l) 'splicing ',(caddr l))))
114:
115: ;
116: ; drm - declare read macro.
117: ;
118: (defun drm macro (l)
119: `(eval-when (compile load eval)
120: (setsyntax ',(cadr l) 'macro ',(caddr l))))
121:
122: ;
123: ;(:= a b) -> ucilisp assignment macro.
124: ;
125: (defun := macro (expression)
126: (let (lft (macroexpand (cadr expression)) rgt (caddr expression))
127: (cond ((atom lft)
128: `(setq ,lft ,(subst lft '*-* rgt)))
129: ((get (car lft) 'set-program)
130: (cons (get (car lft) 'set-program)
131: (append (cdr lft) (list (subst lft '*-* rgt))))))))
132:
133: (defprop car rplaca set-program)
134: (defprop cdr rplacd set-program)
135: (defprop cadr rplacad set-program)
136: (defprop cddr rplacdd set-program)
137: (defprop caddr rplacadd set-program)
138: (defprop cadddr rplacaddd set-program)
139: (defprop get get-set-program set-program)
140:
141: (defun get-set-program (atm prop val)
142: (putprop atm val prop))
143:
144: (defun rplacad (exp1 exp2)
145: (rplaca (cdr exp1) exp2))
146:
147: (defun rplacdd (exp1 exp2)
148: (rplacd (cdr exp1) exp2))
149:
150: (defun rplacadd (exp1 exp2)
151: (rplaca (cddr exp1) exp2))
152:
153: (defun rplacaddd (exp1 exp2)
154: (rplaca (cdddr exp1) exp2))
155:
156: ;
157: ; ucilisp record-type package to declare records and field extraction
158: ; macros.
159: ;
160:
161: (declare (special *type*))
162:
163: (defun record-type macro (l)
164: (let (*type* (cadr l) *flag* (caddr l) slots (car (last l)))
165: `(progn 'compile
166: (defun ,*type*
167: ,(slot-funs-extract slots (and *flag* '(d)))
168: ,(cond ((null *flag*) (struc-cons-form slots))
169: (t (append `(cons ',*flag*)
170: (list (struc-cons-form slots))))))
171: ,(cond (*flag*
172: (cond ((dtpr *flag*) (setq *flag* *type*)))
173: `(defun ,(concat 'is- *type*)
174: macro
175: (l)
176: (list 'and (list 'dtpr (cadr l))
177: (list 'eq (list 'car (cadr l))
178: '',*flag*))))))))
179:
180: (defun slot-funs-extract (slots path)
181: (cond ((null slots) nil)
182: ((atom slots)
183: (eval `(defun ,(concat slots ': *type*)
184: macro
185: (l)
186: (list ',(readlist `(c ,@path r))
187: (cadr l))))
188: (list slots))
189: ((nconc (slot-funs-extract (car slots) (cons 'a path))
190: (slot-funs-extract (cdr slots) (cons 'd path))))))
191:
192: (defun struc-cons-form (struc)
193: (cond ((null struc) nil)
194: ((atom struc) struc)
195: (t `(cons ,(struc-cons-form (car struc))
196: ,(struc-cons-form (cdr struc))))))
197:
198: (defun some macro (l)
199: `((lambda (f a)
200: (prog ()
201: loop
202: (cond ((null a) (return nil))
203: ((funcall f (car a))
204: (return a))
205: (t (setq a (cdr a))
206: (go loop)))))
207: ,(cadr l)
208: ,(caddr l)))
209:
210: (declare (special vars))
211:
212: (defun for macro (*l*)
213: (let (vars (vars:for *l*)
214: args (args:for *l*)
215: test (test:for *l*)
216: type (type:for *l*)
217: body (body:for *l*))
218: (cons (make-mapfn vars test type body)
219: (cons (list 'quote
220: (make-lambda
221: vars (add-test test
222: (make-body vars test type body))))
223: args))))
224:
225: (defun type:for (*l*)
226: (let (item (item:for '(do save splice filter) *l*))
227: (cond (item (car item))
228: ((error '"No body in for loop")))))
229:
230: (defun error (l &optional x)
231: (cond (x (terpri) (patom l) (terpri) (drain) (break) l)
232: (t l)))
233:
234: (defun vars:for (*m*)
235: (mapcan '(lambda (x) (cond ((is-var-form x) (list (var:var-form x))))) *m*))
236:
237: (defun args:for (*n*)
238: (mapcan '(lambda (x)
239: (cond ((is-var-form x) (list (args:var-form x)))))
240: *n*))
241:
242: (defun is-var-form (x) (and (eq (length x) 3) (eq (cadr x) 'in)))
243:
244: (defun var:var-form (x) (car x))
245: (defun args:var-form (x) (caddr x))
246:
247: (defun test:for (*o*)
248: (let (item (item:for '(when) *o*))
249: (cond (item (cadr item)))))
250:
251: (defun body:for (*p*)
252: (let (item (item:for '(do save splice filter) *p*))
253: (cond ((not item) (error '"NO body in for loop"))
254: ((eq (length (cdr item)) 1) (cadr item))
255: ((cons 'progn (cdr item))))))
256:
257: (declare (special *l* item))
258:
259: (defun item:for (keywords *l*)
260: (let (item nil)
261: (some '(lambda (key) (setq item (assoc key (cdr *l*))))
262: keywords)
263: item))
264:
265: (defun make-mapfn (vars test type body)
266: (cond ((equal type 'do) 'mapc)
267: ((not (equal type 'save)) 'mapcan)
268: ((null test) 'mapcar)
269: ((subset-test vars body) 'subset)
270: ('mapcan)))
271:
272: (defun subset-test (vars body)
273: (and (equal (length vars) 1) (equal (car vars) body)))
274:
275: (defun make-body (vars test type body)
276: (cond ((equal type 'filter)
277: (list 'let (list 'x body) '(cond (x (list x)))))
278: ((or (not (equal type 'save)) (null test)) body)
279: ((subset-test vars body) nil)
280: ((list 'list body))))
281:
282: (defun add-test (test body)
283: (cond ((null test) body)
284: ((null body) test)
285: (t (list 'cond (cond ((eq (car body) 'progn) (cons test (cdr body)))
286: ((list test body)))))))
287:
288: (defun make-lambda (var body)
289: (cond ((equal var (cdr body)) (car body))
290: ((eq (car body) 'progn) (cons 'lambda (cons vars (cdr body))))
291: ((list 'lambda vars body))))
292:
293: (defun pop macro (q)
294: `(prog (*q*)
295: (setq *q* (car ,(cadr q)))
296: (setq ,(cadr q) (cdr ,(cadr q)))
297: (return *q*)))
298:
299: (defun length (*u*)
300: (cond ((null *u*) 0)
301: ((atom *u*) 0)
302: ((add1 (length (cdr *u*))))))
303:
304: (declare (special l))
305:
306: (defun every macro (l)
307: `(prog ($$k $v)
308: (setq $$k ,(caddr l))
309: loop
310: (cond ((null $$k)
311: (return t))
312: ((apply ,(cadr l) (list (car $$k)))
313: (setq $$k (cdr $$k))
314: (go loop)))
315: (return nil)))
316:
317: (defun timer fexpr (request)
318: (prog (timein timeout result cpu garbage)
319: (setq timein (ptime))
320: (prog ()
321: loop (setq result (eval (car request)))
322: (setq request (cdr request))
323: (cond ((null request) (return result))
324: ((go loop))))
325: (setq timeout (ptime))
326: (setq cpu (quotient (times 1000.0
327: (quotient (difference (car timeout)
328: (car timein))
329: 60.0))
330: 1000.0))
331: (setq garbage (quotient (times 1000.0
332: (quotient (difference (cadr timeout)
333: (cadr timein))
334: 60.0))
335: 1000.0))
336: (print (cons cpu garbage))
337: (terpri)
338: (return result)))
339:
340: (defun addprop (id value prop)
341: (putprop id (enter value (get id prop)) prop))
342:
343: (defun enter (v l)
344: (cond ((member v l) l)
345: (t (cons v l))))
346:
347: (defmacro subset (fun lis)
348: `(mapcan '(lambda (ele)
349: (cond ((funcall ,fun ele) (ncons ele))))
350: ,lis))
351:
352: (defun push macro (varval)
353: `(setq ,(cadr varval)
354: (cons ,(caddr varval)
355: ,(cadr varval))))
356:
357: (putd 'consp (getd 'dtpr))
358:
359: (defun prelist (a b)
360: (cond ((null a) nil)
361: ((eq b 0) nil)
362: ((cons (car a) (prelist (cdr a) (sub1 b))))))
363:
364: (defun suflist (a b)
365: (cond ((null a) nil)
366: ((eq b 0) a)
367: ((suflist (cdr a) (sub1 b)))))
368:
369: (defun loop macro (l)
370: `(prog ,(var-list (get-keyword 'initial l))
371: ,@(subset (function caddr)
372: (setq-steps (get-keyword 'initial l)))
373: loop
374: ,@(apply (function append) (mapcar (function do-clause) (cdr l)))
375: (go loop)
376: exit
377: (return ,@(get-keyword 'result l))))
378:
379: (defun do-clause (clause)
380: (cond ((memq (car clause) '(initial result)) nil)
381: ((eq (car clause) 'while)
382: (list (list 'or (cadr clause) '(go exit))))
383: ((eq (car clause) 'do) (cdr clause))
384: ((eq (car clause) 'next) (setq-steps (cdr clause)))
385: ((eq (car clause) 'until)
386: (list (list 'and (cadr clause) '(go exit))))
387: (t (terpri) (patom '"unknown keyword clause")
388: (patom (car clause))
389: (terpri))))
390:
391: (defun get-keyword (key l)
392: (cdr (assoc key (cdr l))))
393:
394: (defun var-list (r)
395: (and r (cons (car r) (var-list (cddr r)))))
396:
397: (defun setq-steps (s)
398: (and s (cons (list 'setq (car s) (cadr s))
399: (setq-steps (cddr s)))))
400:
401: (putd 'readch (getd 'readc))
402:
403:
404: ;
405: ; ucilisp msg function. (written by jkf)
406: ;
407: (defmacro msg ( &rest body)
408: `(progn ,@(mapcar
409: '(lambda (form)
410: (cond ((eq form t) '(line-feed 1))
411: ((numberp form)
412: (cond ((greaterp form 0)
413: `(msg-space ,form))
414: (t `(line-feed ,(minus form)))))
415: ((atom form) `(patom ,form))
416: ((eq (car form) t) '(patom '/ ))
417: ((eq (car form) 'e)
418: `(patom ,(cadr form)))
419: (t `(patom ,form))))
420: body)))
421:
422: ;
423: ; this must be fixed to not use do.
424: ;
425: (defmacro msg-space (n)
426: (cond ((eq 1 n) '(patom '" "))
427: (t `(do i ,n (sub1 i) (lessp i 1) (patom '/ )))))
428:
429: (defmacro line-feed (n)
430: (cond ((eq 1 n) '(terpr))
431: (t `(do i ,n (sub1 i) (lessp i 1) (terpr)))))
432:
433: (defmacro prog1 ( first &rest rest &aux (foo (gensym)))
434: `((lambda (,foo) ,@rest ,foo) ,first))
435:
436: (defun append1 (l x) (append l (list x)))
437:
438: ; compatability functions: functions required by uci lisp but not
439: ; present in franz
440: ;
441: ; union uses the franz do loop (not the ucilisp one defined in this file).
442: ;
443:
444: (def union
445: (lexpr (n)
446: (do ((res (arg n))
447: (i (sub1 n) (sub1 i)))
448: ((zerop i) res)
449: (mapc '(lambda (arg)
450: (cond ((not (member arg res))
451: (setq res (cons arg res)))))
452: (arg i)))))
453:
454:
455: (putd 'newsym (getd 'gensym)) ; this is not exactly correct.
456: ; it only uses the first letter of the arg.
457: (putd 'remove (getd 'delete))
458:
459: ; ignore column count
460: (def sprint
461: (lambda (form column)
462: ($prpr form)))
463:
464: (def save (lambda (f) (putprop f (getd f) 'olddef)))
465:
466: (def unsave
467: (lambda (f)
468: (putd f (get f 'olddef))))
469:
470: (putd 'atcat (getd 'concat))
471: (putd 'consp (getd 'dtpr))
472:
473: (defun neq macro (x)
474: `(not (eq ,@(cdr x))))
475:
476: (putd 'gt (getd '>))
477: (putd 'lt (getd '<))
478:
479: (defun le macro (x)
480: `(not (> ,@(cdr x))))
481:
482: (defun ge macro (x)
483: `(not (< ,@(cdr x))))
484:
485: (defun litatom macro (x)
486: `(and (atom ,@(cdr x))
487: (not (numberp ,@(cdr x)))))
488:
489: (putd 'apply\# (getd 'apply))
490:
491: (defun tconc (ptr x)
492: (cond ((null ptr)
493: (prog (temp)
494: (setq temp (list x))
495: (return (setq ptr (cons temp (last temp))))))
496: ((null (car ptr))
497: (rplaca ptr (list x))
498: (rplacd ptr (last (car ptr)))
499: ptr)
500: (t (prog (temp)
501: (setq temp (cdr ptr))
502: (rplacd (cdr ptr) (list x))
503: (rplacd ptr (cdr temp))
504: (return ptr)))))
505:
506: ;
507: ; unbound - (setq x (unbound)) will unbind x.
508: ; "this [code] is sick" - jkf.
509: ;
510: (defun unbound macro (l)
511: `(fake -4))
512:
513: ;
514: ;
515: ; due to problems with franz do in the compiler, this
516: ; has been commented out and is left in a seperate
517: ; file called /usr/lib/lisp/ucido.l
518: ;
519: ;(defun do macro (l)
520: ; ((lambda (dotype alist)
521: ; (selectq dotype
522: ; (while (dowhile (car alist) (cdr alist)))
523: ; (until (dowhile (list 'not (car alist))
524: ; (cdr alist)))
525: ; (for (dofor (car alist)
526: ; (cadr alist)
527: ; (caddr alist)
528: ; (cdddr alist)))
529: ; `((lambda ()
530: ; ,@alist))))
531: ; (cadr l)
532: ; (cddr l)))
533: ;
534: ;(defun dowhile (expr alist)
535: ; `(prog (returnvar)
536: ; loop
537: ; (cond (,expr
538: ; (setq returnvar ((lambda ()
539: ; ,@alist)))
540: ; (go loop))
541: ; (t (return returnvar)))))
542: ;
543: ;(defun dofor (var fortype varlist stmlist)
544: ; (selectq fortype
545: ; (in `(prog (returnvar l1 l2)
546: ; (setq l2 ',varlist)
547: ; loop
548: ; (setq l1 (car l2))
549: ; (setq l2 (cdr l2))
550: ; (cond ((null l1)
551: ; (return returnvar)))
552: ; (setq returnvar
553: ; ((lambda (,var)
554: ; ,@stmlist)
555: ; (l1)))
556: ; (go loop)))
557: ; (on `(prog (returnvar l1 l2)
558: ; (setq l2 ',varlist)
559: ; loop
560: ; (cond ((null l2)
561: ; (return returnvar)))
562: ; (setq returnvar
563: ; ((lambda (,var)
564: ; ,@stmlist)
565: ; (l2)))
566: ; (setq l2 (cdr l2))
567: ; (go loop)))
568: ; (rpt `(prog (returnvar ,var)
569: ; (setq ,var 1)
570: ; loop
571: ; (cond ((not (> ,var ,varlist))
572: ; (setq returnvar ((lambda ()
573: ; ,@stmlist)))
574: ; (setq ,var (1+ ,var))
575: ; (go loop))
576: ; (t (return returnvar)))))
577: ; nil))
578: ;
579: (putd 'dddd* (getd 'boundp))
580: (defun boundp (l)
581: (cond ((arrayp l))
582: ((dddd* l))))
583:
584: ;
585: ; now change to ucilisp syntax.
586: ;
587: (sstatus uctolc t)
588: ;
589: ; Leave backquote macro in for now.
590: ; These characters should be declared as follows for real
591: ; ucilisp syntax though.
592: ;(setsyntax '\` 2)
593: ;(setsyntax '\, 2)
594: ;(setsyntax '\@ 201)
595: ;(setsyntax '\@ 'macro '(lambda () (list 'quote (read))))
596: ;
597: ; ~ as comment character, not ; and / instead of \ for escape
598: (setsyntax '\~ 'splicing 'zapline)
599: (setsyntax '\; 2)
600: (setsyntax '\# 2)
601: (setsyntax '\/ 143)
602: (setsyntax '\\ 2)
603: (setsyntax '\! 2)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.