"$Header: /usr/lib/lisp/ucifnc.l,v 1.1 83/01/29 18:41:16 jkf Exp $")
; There is problems with the ucilisp do being
; incompatible with maclisp/franz do,
; The problems with compiling do are gone, but
; due to these possible problems, the ucilisp do function
; is in a seperate file ucido.l and users of it
; should also load that file in at compile time before
; any call to do (since do is a macro) (and
; at runtime if do is to be interpreted).
; This file is meant to be fasl'd or used with liszt -u
; not to be read in interpretively (the syntax changes
; will not work in that case.
; to compile this file do liszt ucifnc.l
; one who wants to use these functions or compile and run
; a ucilisp program should do both
; liszt -u file.l when compiling.
; (fasl '/usr/lib/lisp/ucifnc)
; before loading in and running them
; This is because some functions are macros and others are too
; complicated and need other functions around.
; Note this file will not load in directly and when fasl'd in will
; cause the syntax of lisp to change to ucilisp syntax.
; ucilisp (de df dm) declare function macros.
; (de name args body) -> declare exprs and lexprs.
; (df name args body) -> declare fexprs.
; macro's are not compiled except under the same
; conditions as in franz lisp.
; (usually just do (declare (macros t))
; to have macros also compiled).
; (dm name args body) -> declare macros. same as (defun name 'macro body)
(eval-when (compile load eval)
(defun let1 (l vars vals body)
(cons (cons 'lambda (cons vars body)) vals))
(cons (cadr l) vals) body)))))
(let1 (cadr l) nil nil (cddr l)))
`(nconc ,(cadr l) (list ,(caddr l))))
(putd 'expandmacro (getd 'macroexpand))
; ucilisp selectq function. (written by jkf)
; ucilisp functions which declare read macros.
; dsm - declare splicing read macro.
`(eval-when (compile load eval)
(setsyntax ',(cadr l) 'splicing ',(caddr l))))
; drm - declare read macro.
`(eval-when (compile load eval)
(setsyntax ',(cadr l) 'macro ',(caddr l))))
;(:= a b) -> ucilisp assignment macro.
(defun := macro (expression)
(let (lft (macroexpand (cadr expression)) rgt (caddr expression))
`(setq ,lft ,(subst lft '*-* rgt)))
((get (car lft) 'set-program)
(cons (get (car lft) 'set-program)
(append (cdr lft) (list (subst lft '*-* rgt))))))))
(defprop car rplaca set-program)
(defprop cdr rplacd set-program)
(defprop cadr rplacad set-program)
(defprop cddr rplacdd set-program)
(defprop caddr rplacadd set-program)
(defprop cadddr rplacaddd set-program)
(defprop get get-set-program set-program)
(defun get-set-program (atm prop val)
(defun rplacad (exp1 exp2)
(rplaca (cdr exp1) exp2))
(defun rplacdd (exp1 exp2)
(rplacd (cdr exp1) exp2))
(defun rplacadd (exp1 exp2)
(rplaca (cddr exp1) exp2))
(defun rplacaddd (exp1 exp2)
(rplaca (cdddr exp1) exp2))
; ucilisp record-type package to declare records and field extraction
(declare (special *type*))
(defun record-type macro (l)
(let (*type* (cadr l) *flag* (caddr l) slots (car (last l)))
,(slot-funs-extract slots (and *flag* '(d)))
,(cond ((null *flag*) (struc-cons-form slots))
(t (append `(cons ',*flag*)
(list (struc-cons-form slots))))))
(cond ((dtpr *flag*) (setq *flag* *type*)))
`(defun ,(concat 'is- *type*)
(list 'and (list 'dtpr (cadr l))
(list 'eq (list 'car (cadr l))
(defun slot-funs-extract (slots path)
(eval `(defun ,(concat slots ': *type*)
(list ',(readlist `(c ,@path r))
((nconc (slot-funs-extract (car slots) (cons 'a path))
(slot-funs-extract (cdr slots) (cons 'd path))))))
(defun struc-cons-form (struc)
(t `(cons ,(struc-cons-form (car struc))
,(struc-cons-form (cdr struc))))))
(cond ((null a) (return nil))
(let (vars (vars:for *l*)
(cons (make-mapfn vars test type body)
(make-body vars test type body))))
(let (item (item:for '(do save splice filter) *l*))
((error '"No body in for loop")))))
(defun error (l &optional x)
(cond (x (terpri) (patom l) (terpri) (drain) (break) l)
(mapcan '(lambda (x) (cond ((is-var-form x) (list (var:var-form x))))) *m*))
(cond ((is-var-form x) (list (args:var-form x)))))
(defun is-var-form (x) (and (eq (length x) 3) (eq (cadr x) 'in)))
(defun var:var-form (x) (car x))
(defun args:var-form (x) (caddr x))
(let (item (item:for '(when) *o*))
(cond (item (cadr item)))))
(let (item (item:for '(do save splice filter) *p*))
(cond ((not item) (error '"NO body in for loop"))
((eq (length (cdr item)) 1) (cadr item))
((cons 'progn (cdr item))))))
(declare (special *l* item))
(defun item:for (keywords *l*)
(some '(lambda (key) (setq item (assoc key (cdr *l*))))
(defun make-mapfn (vars test type body)
(cond ((equal type 'do) 'mapc)
((not (equal type 'save)) 'mapcan)
((subset-test vars body) 'subset)
(defun subset-test (vars body)
(and (equal (length vars) 1) (equal (car vars) body)))
(defun make-body (vars test type body)
(cond ((equal type 'filter)
(list 'let (list 'x body) '(cond (x (list x)))))
((or (not (equal type 'save)) (null test)) body)
((subset-test vars body) nil)
(defun add-test (test body)
(t (list 'cond (cond ((eq (car body) 'progn) (cons test (cdr body)))
(defun make-lambda (var body)
(cond ((equal var (cdr body)) (car body))
((eq (car body) 'progn) (cons 'lambda (cons vars (cdr body))))
((list 'lambda vars body))))
(setq *q* (car ,(cadr q)))
(setq ,(cadr q) (cdr ,(cadr q)))
((add1 (length (cdr *u*))))))
((apply ,(cadr l) (list (car $$k)))
(defun timer fexpr (request)
(prog (timein timeout result cpu garbage)
loop (setq result (eval (car request)))
(setq request (cdr request))
(cond ((null request) (return result))
(setq cpu (quotient (times 1000.0
(quotient (difference (car timeout)
(setq garbage (quotient (times 1000.0
(quotient (difference (cadr timeout)
(print (cons cpu garbage))
(defun addprop (id value prop)
(putprop id (enter value (get id prop)) prop))
(defmacro subset (fun lis)
(cond ((funcall ,fun ele) (ncons ele))))
(defun push macro (varval)
(putd 'consp (getd 'dtpr))
((cons (car a) (prelist (cdr a) (sub1 b))))))
((suflist (cdr a) (sub1 b)))))
`(prog ,(var-list (get-keyword 'initial l))
,@(subset (function caddr)
(setq-steps (get-keyword 'initial l)))
,@(apply (function append) (mapcar (function do-clause) (cdr l)))
(return ,@(get-keyword 'result l))))
(defun do-clause (clause)
(cond ((memq (car clause) '(initial result)) nil)
((eq (car clause) 'while)
(list (list 'or (cadr clause) '(go exit))))
((eq (car clause) 'do) (cdr clause))
((eq (car clause) 'next) (setq-steps (cdr clause)))
((eq (car clause) 'until)
(list (list 'and (cadr clause) '(go exit))))
(t (terpri) (patom '"unknown keyword clause")
(defun get-keyword (key l)
(cdr (assoc key (cdr l))))
(and r (cons (car r) (var-list (cddr r)))))
(and s (cons (list 'setq (car s) (cadr s))
(putd 'readch (getd 'readc))
; ucilisp msg function. (written by jkf)
(defmacro msg ( &rest body)
(cond ((eq form t) '(line-feed 1))
(t `(line-feed ,(minus form)))))
((atom form) `(patom ,form))
((eq (car form) t) '(patom '/ ))
; this must be fixed to not use do.
(cond ((eq 1 n) '(patom '" "))
(t `(do i ,n (sub1 i) (lessp i 1) (patom '/ )))))
(cond ((eq 1 n) '(terpr))
(t `(do i ,n (sub1 i) (lessp i 1) (terpr)))))
(defmacro prog1 ( first &rest rest &aux (foo (gensym)))
`((lambda (,foo) ,@rest ,foo) ,first))
(defun append1 (l x) (append l (list x)))
; compatability functions: functions required by uci lisp but not
; union uses the franz do loop (not the ucilisp one defined in this file).
(cond ((not (member arg res))
(setq res (cons arg res)))))
(putd 'newsym (getd 'gensym)) ; this is not exactly correct.
; it only uses the first letter of the arg.
(putd 'remove (getd 'delete))
(def save (lambda (f) (putprop f (getd f) 'olddef)))
(putd f (get f 'olddef))))
(putd 'atcat (getd 'concat))
(putd 'consp (getd 'dtpr))
(not (numberp ,@(cdr x)))))
(putd 'apply\# (getd 'apply))
(return (setq ptr (cons temp (last temp))))))
(rplacd ptr (last (car ptr)))
(rplacd (cdr ptr) (list x))
; unbound - (setq x (unbound)) will unbind x.
; "this [code] is sick" - jkf.
; due to problems with franz do in the compiler, this
; has been commented out and is left in a seperate
; file called /usr/lib/lisp/ucido.l
; ((lambda (dotype alist)
; (while (dowhile (car alist) (cdr alist)))
; (until (dowhile (list 'not (car alist))
; (for (dofor (car alist)
;(defun dowhile (expr alist)
; (setq returnvar ((lambda ()
; (t (return returnvar)))))
;(defun dofor (var fortype varlist stmlist)
; (in `(prog (returnvar l1 l2)
; (on `(prog (returnvar l1 l2)
; (rpt `(prog (returnvar ,var)
; (cond ((not (> ,var ,varlist))
; (setq returnvar ((lambda ()
; (t (return returnvar)))))
(putd 'dddd* (getd 'boundp))
; now change to ucilisp syntax.
; Leave backquote macro in for now.
; These characters should be declared as follows for real
;(setsyntax '\@ 'macro '(lambda () (list 'quote (read))))
; ~ as comment character, not ; and / instead of \ for escape
(setsyntax '\~ 'splicing 'zapline)