Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/18/84; site utcsri.UUCP
Path: utzoo!utcsri!petera
From: petera@utcsri.UUCP (Smith)
Newsgroups: net.micro
Subject: PC-LISP PACKAGE (article 8 of 13)
Message-ID: <2653@utcsri.UUCP>
Date: Sun, 27-Apr-86 14:41:53 EDT
Article-I.D.: utcsri.2653
Posted: Sun Apr 27 14:41:53 1986
Date-Received: Sun, 27-Apr-86 15:36:09 EDT
Distribution: net
Organization: CSRI, University of Toronto
Lines: 92

;; PC-LISP.L  for PC-LISP.EXE V2.10                                
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~                                                     
;;     A small library of functions to help fill in the gap between PC and      
;; Franz Lisp. These functions are for learning purposes only are not very
;; effectient or very robust. 
;;
;;    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 may also want to strip    
;; the comments out to make it load faster, especially off floppies.
;;      
;;              Peter Ashwood-Smith
;;                April 1986
;;

(setq poport  (fileopen 'con: 'w))               ; LISP standard output port
(setq piport  (fileopen 'con: 'r))               ; LISP standard input port
(setq errport (fileopen 'con: 'w))               ; LISP standard error port

;; 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.

(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|)
				(patom (ascii 10))
				(return nil)))
       SKIP  (pp-form expr port 0)
	     (cond ((not (equal port poport)) (close port)))
	     (return t)
       )
)
    
;; 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)
       )
)

;; ----------- 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))