ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/PCLISP30.ZIP/PC-LISP.L

Text File | 1987-04-05 | 13.3 KB | 352 lines

;; PC-LISP.L  for PC-LISP.EXE V2.15
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;;     A small library of functions to help fill in the gap between PC and
;; Franz Lisp. These functions are not documented in the PC-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 one of your LISP_LIB directories. You could also strip
;; 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
;;                November 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'.

(setq displace-macros t)        ; override Franz default (faster do loops)

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

;; _SCL_ Spit Character Loop
;; ~~~~~~~~~~~~~~~~~~~~~~~~~
;; Prints 'char' 'n' times on port 'port', used by msg for (N) and (B)

(defun _SCL_(port char n)
       (prog nil
     nxt: (cond ((zerop n) (return)))
          (patom char port)
          (setq n (1- n))
          (go nxt:)
       )
)

;; (msg [B|N|D] [ (P pt) (B n) | (N n)] s*)
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Prints a message on standard output port 'poport'. Where N is a new
;; line, (N n) means n new lines. B is a blank, (B n) means n blanks
;; D means (Dran port) unsupported in PC-LISP. (P pt) means switch output
;; to port pt rather than poport. s, is any s expression which will be
;; evaluated and then printed on current output port.

(defun msg fexpr(l)
       (prog (s op)
         (setq op poport)
    nxt: (cond ((null l)(return)))
         (setq s (car l) l (cdr l))
         (cond ((eq s 'N) (patom "\n" op))
           ((eq s 'B) (patom " " op))
           ((eq s 'D) (patom "msg : Drain unsupported\n"))
           ((listp s)
               (cond ((eq (car s) 'P)(setq op (cadr s)))
                 ((eq (car s) 'B)(_SCL_ op " " (cadr s)))
                 ((eq (car s) 'N)(_SCL_ op "\n" (cadr s)))
                 (t (patom (eval s) op))
               )
           )
           (t (patom (eval s) op))
         )
         (go nxt:)
       )
)

;; (lineread [port])
;; ~~~~~~~~~~~~~~~~~
;; Very simple line read function. Takes atoms from the piport or port until
;; a new line is encountered. It returns these atoms or S-expressions as a
;; list 'ret.

(defun lineread fexpr(l)
       (prog (port ret)
         (setq port piport)
         (cond ((not (null l)) (setq port (eval (car l)))))
         (setq ret (list (read port)))
    nxt: (cond ((eq (readc port) '|\n|)(return ret)))
         (setq ret (append ret (list (read port))))
         (go nxt:)
       )
)

;; ----------- ASSORTED SMALL FUNCTIONS ------------

(defun tailp(l1 l2)(cond ((null l2) nil)((eq l1 l2) l1)(t(tailp l1(cdr l2]
(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) nil)
(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 (1- n) l))
(defun minus(n)(- 0 n))
(defun onep(n)(= 1 n))
(defun infile(f)(fileopen f 'r))
(defun pntlen(a) (flatsize a))
(defun probef(f &aux tmp)(setq tmp (fileopen f 'r))(and tmp (close tmp)))
(defun shell()(exec "COMMAND.COM"))     ; must have a COMMAND.COM on PATH!

(defun error n
       (cond ((= n 1) (patom (arg 1)) (terpri) (err nil))
         ((= n 2) (patom (arg 1)) (patom (arg 2)) (terpri) (err nil))
         (t (error "error bad args"))]

(defun signp(test exp)
       (cond ((eq test 'ge) (or (zerop exp)(plusp exp)))
         ((eq test 'g ) (plusp exp))
         ((eq test 'n ) (not (zerop exp)))
         ((eq test 'e ) (zerop exp))
         ((eq test 'le) (or (zerop exp)(minusp exp)))
         ((eq test 'l)  (minusp exp))
         (t (princ "-- error signp bad test ---\n"))))

;; ----------- ASSORTED SMALL MACROS --------------

(defun >&  macro(l) (cons '> (cdr l)))
(defun >=  macro(l) (cons 'not (list (cons '< (cdr l)))))
(defun >=& macro(l) (cons 'not (list (cons '< (cdr l)))))
(defun <&  macro(l) (cons '< (cdr l)))
(defun <=  macro(l) (cons 'not (list (cons '> (cdr l)))))
(defun <=& macro(l) (cons 'not (list (cons '> (cdr l)))))
(defun =&  macro(l) (cons '= (cdr l)))

(defun terpri macro(l)                      ; makes (terpri [port])
      (append (list 'princ "\n")(cdr l)))   ; into  (princ "\n" [port])
(defun tyo macro(l)                         ; makes (princ (asci f) [port])
      (cons 'princ (cons (cons 'ascii (list (cadr l))) (cddr l))))
(defun store macro(l)                       ; makes (store (x -dims-) exp)
      (cons (caadr l)                       ; into  (x exp -dims-)
        (append (cddr l) (cdadr l))))
(defun arraycall macro(l)                   ; makes (arraycall f a -n-)
      (cddr l))                             ; into  (a -n-)

;; 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))
         ((eq (car Sexp) '*splice*) Sexp)
         (t (list '*unquote* 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)
;; Note that (p1 v1) may be of the form p1 in which case the variable
;; is bound to nil.

(defun let macro(l)
    `((lambda ,(mapcar '_lvar (cadr l))
         ,@(cddr l)
      )
      ,@(mapcar '_lval (cadr l]

(defun _lvar (l)(cond ((atom l) l) (t (car l]

(defun _lval (l)(cond ((atom l) nil) (t (cadr l]

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

(defun defmacro fexpr(l)
    (putd (car l)
      (cons 'macro
         (list '(defmacroarg)
           `((lambda ,(__dmlats (cadr l))
                 ,@(cddr l))
             ,@(__dmal (cadr l))]

(defun defcmacro fexpr(l)         ; no such thing as compiler yet but
    (putd (car l)                 ; keeps interpreter happy
      (cons 'macro
         (list '(defmacroarg)
           `((lambda ,(__dmlats (cadr l))
                 ,@(cddr l))
             ,@(__dmal (cadr l))]

(defun __dma(l a)
      (cond ((null l) nil)
        ((atom l) (setq __dmalhold (cons a __dmalhold)))
        (t (__dma (car l) (cons 'car (list a)))
           (__dma (cdr l) (cons 'cdr (list a)))]

(defun __dmal(l &aux __dmalhold)
    (__dma l '(cdr defmacroarg))
    (reverse __dmalhold ]

(defun __dmlats(l)
    (cond ((null l) nil)
          ((atom l) (list l))
          ( t (append (__dmlats (car l)) (__dmlats (cdr l)))]

;;  (do "symbol" "exp1" "exp2" "test" -"exps"-)        ; case 1
;;  (do -"(symbol [exp1 [exp2]])"- "test" -"exps"-)    ; case 2
;;
(defun _do2a_(l) (cond ((cdr l)(cons (car l) (list(cadr l))))(t nil]
(defun _do2b_(l) (cond ((cddr l)(cons (car l) (list(caddr l))))(t nil]

(defun _do2_(l)                            ; complex do loop case, many locals
     `(prog ,(mapcar 'car (cadr l))
        (PAR-setq ,@(apply 'append (mapcar '_do2a_ (cadr l))))
     _dlab_
        (cond (,(caaddr l) (return ,@(cdaddr l)) ))
        ,@(cdddr l)
        (PAR-setq ,@(apply 'append (mapcar '_do2b_ (cadr l))))
        (go _dlab_)
      )
)

(defun _do1_(l)                            ; simple do loop case, one local
     `(prog (,(nth 1 l))
        (setq ,(nth 1 l) ,(nth 2 l))
     _dlab_ (cond (,(nth 4 l) (return)))
        ,@(cdddddr l)
        (setq ,(nth 1 l) ,(nth 3 l))
        (go _dlab_)
      )
)

(defun do macro(l)                        ; select simple/complex case.
       (cond ((atom (cadr l)) (_do1_ l))
         (t (_do2_ l))))

;; This macro allow the following forms:
;;      (if a then b)   ==>  (cond (a b))
;;      (if a thenret)  ==>  (cond (a))
;;      (if a then b else c) ==> (cond (a b) (t c))
;;      (if a then b b2              ==> (cond (a b b2) (c d d2) (t e))
;;       elseif c then d d2
;;       else e)
;;
;;  I stole this from the SLANG package and changed its name to 'if from
;; 'If.
;;
(defun if macro  (lis)
       (prog (majlis minlis revl)
         (do ((revl (reverse lis) (cdr revl)))
         ((null revl))
         (cond ((eq (car revl) 'else)
            (setq majlis `((t ,@minlis) ,@majlis)
                  minlis nil))
               ((or (eq (car revl) 'then) (eq (car revl) 'thenret))
            (setq revl (cdr revl)
                  majlis `((,(car revl) ,@minlis) ,@majlis)
                  minlis nil))
               ((eq (car revl) 'elseif))
               ((eq (car revl) 'if)
            (setq majlis `(cond ,@majlis)))
               (t (setq minlis `( ,(car revl) ,@minlis)))))
         ; we displace the previous macro, that is we actually replace
         ; the if list structure with the corresponding cond, meaning
         ; that the expansion is done only once
         (rplaca  lis (car majlis))
         (rplacd lis (cdr majlis))
         (return majlis)))

;; A couple of rareley used definitions but just to complete the chapter
;; on mapping functions, here they are:
;;
(defun mapcan macro(l) `(apply 'nconc (mapcar ,@(cdr l))))
(defun mapcon macro(l) `(apply 'nconc (maplist ,@(cdr l))))

;; The progS functions again to fill in some gaps
;;
(defun progn macro(l) `(prog nil ,@(cdr l)))
(defmacro prog1(a . b) `(prog (__p1ret) (setq __p1ret ,a) ,@b __p1ret))
(defmacro prog2(a b . c) `(prog (__p2ret) ,a (setq __p2ret ,b) ,@c __p2ret))