home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Phoenix CD 2.0
/
Phoenix_CD.cdr
/
01e
/
lisp211.zip
/
PC-LISP.L
< prev
next >
Wrap
Lisp/Scheme
|
1986-05-15
|
7KB
|
160 lines
;; PC-LISP.L for PC-LISP.EXE V2.11
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; A small library of functions to help fill in the gap between PC and
;; Franz Lisp. These functions are not documented in the LISP.DOC file but
;; any Franz manual will cover them in detail. Especially the backquote
;; and other macro definitions towards the end of the file. These functions
;; were written pretty hastily so there could be bugs. Check them out for
;; yourself to make sure they behave in the way you are used to with Franz.
;;
;; This file is automatically loaded by PC-LISP.EXE. It should either
;; be located in the current working directory, or in a library directory
;; whose path is set in the LISP%LIB environment variable. All load files
;; should be put in your LISP%LIB directory. You should also strip out the
;; comments and white space from this file to make it load faster. This
;; is important if you load this file every time you run PC-LISP.
;;
;; Peter Ashwood-Smith
;; May 1986
;;
;; Pretty Print: (pp [(F file) (E expr) (P port)] symbol)
;; ~~~~~~~~~~~~
;; Print in a readable way the function associated with 'symbol'. If
;; the parameter (F file) is specified the output goes to file 'file. If
;; the parameter (P port) is specified the output goes to the open port
;; 'port'. If the parameter (E expr) is specified the expression 'expr'
;; is evaluated before the function is pretty printed. Makes use of the
;; predefined symbol poport whose binding is 'stdout'.
(defun pp fexpr(l)
(prog (expr name port alt)
(setq port poport)
(cond ((= (length l) 1) (setq name (car l)))
((= (length l) 2) (setq name (cadr l) alt (car l)))
(t (return nil))
)
(cond ((null (getd name)) (return nil)))
(setq expr (cons 'def (cons name (list (getd name)))))
(cond ((null alt) (go SKIP)))
(cond ((eq (car alt) 'F) (setq port (fileopen (cadr alt) 'w)))
((eq (car alt) 'P) (setq port (cadr alt)))
((eq (car alt) 'E) (eval (cadr alt)))
(t (return nil)))
(cond ((null port) (patom "cannot open port\n") (return nil)))
SKIP (pp-form expr port 0)
(cond ((not (equal port poport)) (close port)))
(return t)
)
)
;; ----------- ASSORTED PREDICATES ETC ------------
(defun tailp(l1 l2)(cond ((null l2) nil)((eq l1 l2) l1)(t(tailp l1(cdr l2]
(defun arrayp(x) nil)
(defun bcdp(x) nil)
(defun bigp(x) nil)
(defun dtpr(x) (and (listp x) (not (null x))))
(defun consp(x) (and (listp x) (not (null x))))
(defun litatom(n) (and(atom n)(not(floatp n]
(defun purep(n)(or(eq n t)(eq n nil)(eq n 'lambda)(eq n 'nlambda)(eq n 'macro]
(defun symbolp(n) (litatom n))
(defun valuep(n) nil)
(defun vectorp(n) nil)
(defun typep(n)(type n))
(defun eqstr(a b)(equal a b))
(defun neq(a b)(not(eq a b)))
(defun nequal(a b)(not(equal a b)))
(defun append1(a b)(append a (list b)))
(defun ncons(a)(cons a nil))
(defun xcons(a b)(cons b a))
(defun nthelem(n l) (nth (- n 1) l))
(defun minus(n)(- 0 n))
(defun onep(n)(= 1 n))
(defun infile(f)(fileopen f 'r))
(defun terpri macro(l) ; builds (princ "\n" [port])
(append (list 'princ "\n")(cdr l)))
;; BACKQUOTE READ MACRO AND PARTS
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; This file describes the back quote macro for PC-LISP. It works in
;; exactly the same way as the FRANZ backquote macro works. Basically the
;; backquote macro ` is supposed to work together with the comma , and at
;; @ macros. As follows: Backquote has the same effect as ' except that any
;; elements or sub elements that are preceeded by , are evaluated. If an
;; element is preceeded by ,@ then the element is evaluated and should
;; evaluate to a list. This list is spliced into the built list. I use
;; cons to do list building and append to do list splicing. For example
;; the input: `(a ,b c) will be read in as (a (*unquote* b) c) by the
;; back quote read macro because the comma macro will have read the b and
;; built up the list (*unquote* b). Next the back quote macro passes control
;; to the _BQB_ function (Back Quote Builder). This will construct the list
;; (cons 'a (cons b (cons 'c nil))) which when evaluated gives the desired
;; result. If the , were followed by an @ then the @ would build the form
;; (*splice* b). Then the , would get this form and the function _CB_ comma
;; builder would then make then pass the form unchanged. Next the backquote
;; builder _BQB_ would get the form (a (*splice* b) c) and build the form
;; (cons 'a (append b (cons 'c nil))) which will cause the value of b to be
;; spliced into the list rather than forming a sublist element as desired.
(defun _BQB_(Sexp)
(cond ((null Sexp) Sexp)
((atom Sexp) (list 'quote Sexp))
((eq (car Sexp) '*unquote*)
(cadr Sexp))
((and(listp (car Sexp)) (eq (caar Sexp) '*splice*))
(list 'append (cadar Sexp)
(_BQB_ (cdr Sexp))))
( t (list 'cons (_BQB_ (car Sexp))
(_BQB_ (cdr Sexp))))
)
)
(defun _CB_(Sexp)
(cond ((null Sexp) Sexp)
((atom Sexp) (list '*unquote* Sexp))
(t Sexp)
)
)
(setsyntax '|`| 'vmacro '(lambda()(_BQB_ (read))))
(setsyntax '|,| 'vmacro '(lambda()(_CB_ (read))))
(setsyntax '|@| 'vmacro '(lambda()(list '*splice* (read))))
;; macro : (let ((p1 v1)(p2 v2)...(pn vn)) e1 e2 ... en)
;; ~~~~~
;; Let macro introduces local variables. Much used in Franz code it
;; basically creates a lambda expression of the form:
;;
;; ((lambda(p1 p2 ... pn) e1 e2 ... en) v1 v2 ...vn)
;;
(defun let macro(x)
(cons (append (cons 'lambda ; ((lambda ..rest..
(list (mapcar 'car (cadr x)))) ; ((p1 p2...pn))
(cddr x)) ; (e1 e1...en)
(mapcar 'cadr (cadr x)) ; (v1 v2...vn)
)
)
;; macro defmacro
;; ~~~~~~~~~~~~~~
;; Like defun except that it declares a macro. This is more convenient
;; than using the defun name macro(l) because access to variables can be
;; named. It produces almost he same intermediate form as Franz except that
;; it uses the (nth N xxx) form rather than the (cadddr xxx) form for access
;; to the macro parameters.
;;
(defun defmacro fexpr(plist)
(putd (car plist)
(cons 'macro
(list '(defmacroarg)
(cons (cons 'lambda (cdr plist))
(prog (n res)
(setq n (length (cadr plist)))
DML: (cond ((zerop n) (return res)))
(setq res `((nth ,n defmacroarg) ,@res) n (1- n))
(go DML:)))))))