(* File: {PHYLUM}<DESRIVIERES>NLISP>BEAVER-SUPPORT *)

(* Last edited Dec. 14, 1983 by Jim des Rivieres. *)

(* Uses: {PHYLUM}<LISP>LIBRARY>CMLSPECIALFORMS.DCOM *)

(* Structural field:  Internal representations.
   
   Pair (a . b)       ("pair" a b)
   Handle  'a         ("quote" a)
   Numeral  100       100
   Boolean            T and NIL
   Rail [a b c]       (a b c !.)
   Atom foo           FOO (except T => T.; NIL => NIL.)
   Name @bar          ("name" @BAR)

This representation was chosen so that operations on rails
are efficient. 

*)

(constants *pair* *quote* *rail* *name* *closure* $t $f)

(globalvars nlisp-read-table)

(defun initialise-type-tags ()
   (prog () 
     (setq $t t)
     (setq $f nil)
     (setq *pair*   "pair")
     (setq *quote*  "quote")
     (setq *rail*   '!.)
     (setq *name*    "name")))

(initialise-type-tags)   (* These are all constants anyway. *)

(* Operations on pairs: pcons, pcar, pcdr, pair?. *)
(* No error checking is done. *)

(defun pair? (x) (and (listp x) (eq (car x) *pair*)))
(defun pcons (a b) (list *pair* a b))
(defun pcar (x) (cadr x))
(defun pcdr (x) (caddr x))

(* Operations on rails: rcons0, prep, first, 
   rest, empty?, rail? *)
(* No error checking is done. *)

(defmacro rail? (x) (and (listp x) (not (stringp (car x)))))
(defmacro rcons0 () (list *rail*))
(cldisable 'first)  (* Tell CLISP we want this word. *)
(defmacro first (x) (car x))
(defmacro second (x) (cadr x))
(defmacro third (x) (caddr x))
(defmacro rest  (x) (cdr x))
(defmacro empty? (x) (eq (car x) *rail*))
(defmacro prep (a b) (cons a b))
(defmacro rlength (x) (sub1 (length x)))

(defmacro rail-to-list (x)
   (for i on x join
     (if (empty? i) then (list) else (list (first i)))))

(defmacro list-to-rail (x)
   (append x (rcons0)))


(* Operations on handles: handle?, up, down. *)
(* No error checking is done. *)


(defmacro handle? (x) (and (listp x) (eq (car x) *quote*)))
(defmacro up (x) (list *quote* x))
(defmacro down (x) (cadr x))


(* Operations on closure skeletons: make-skeleton, 
   spread?, nexpected, start-address, reflective?,
   variables, comment, source-exp. *)
(* No error checking is done. *)

(defmacro make-skeleton (reflective spread nexpected
         variables start-address comment source-exp)
   (list reflective spread (if (not spread) then 1 else nexpected)
      variables start-address comment source-exp)) 
   
(defmacro reflective? (s) (car s))
(defmacro spread? (s) (cadr s))
(defmacro nexpected (s) (caddr s))
(defmacro variable-list (s) (cadddr s))
(defmacro start-address (s) (cadddr (cdr s)))
(defmacro comment (s) (cadddr (cddr s)))
(defmacro source-exp (s) (cadddr (cdddr s)))

(* Operations on atoms: atom?, acons, make-atom, extract-atom. 

   3-LISP atoms are represented by the correspondingly-named
   atoms of the underlying LISP.  Two exceptions are T and NIL;
   they represent $T and $F respectively.

   Note too that the scheme used here is not entirely
   correct since some 3-LISP atoms (e.g. 1.500) map to
   numerals (ATOMS but not LITATOMS).  This could be
   gotten around --- but doesn't seem worth the effort.
*) 

(defmacro atom? (x)
   (if (and (litatom x)
            (not (eq x nil)) 
            (not (eq x t))) then t else nil))

(defmacro acons () (gensym "?"))

(* make-atom converts a LISP literal atom to 3-LISP, 
   making allowance for t and nil.  extract-atom does
   the converse conversion.
*)
(defmacro make-atom (x)
   (if (eq x nil) then
       (quote %.nil)
    else
       (if (eq x t) then
           (quote %.t) 
        else
           x)))

(defmacro extract-atom (x)
   (if (eq x (quote %.nil)) then
       nil
    else
       (if (eq x (quote %.t)) then
           t
        else
           x)))

(* Operations on names: name?, ncons, make-name, extract-name. 
   3-LISP names are simply rigid designators of who knows what?
*) 

(defmacro name? (x)
   (and (listp x) (eq (car x) *name*)))

(defmacro ncons () (list *name* (gensym "@")))

(defmacro make-name (x)
   (list *name* x))

(defmacro extract-name (x)
   (cadr x))


(* Operations on numerals: numeral?, make-numeral,
   extract-numeral.

   3-LISP numerals are represented by the corresp.
   numeral (number) in the underlying LISP.
*)
(defmacro numeral? (x) 
   (if (numberp x) then t else nil))
(defmacro make-numeral (n) n)
(defmacro extract-numeral (x) x)


(* Operations on booleans: boolean?, make-boolean,
   extract-boolean.

   3-LISP boolean are represented by the atoms T and NIL
   in the underlying LISP.
*)
(defmacro boolean? (x)
   (if (or (eq x t) (eq x nil)) then t else nil))
(defmacro make-boolean (x)
   (if (eq x nil) then nil else t))
(defmacro extract-boolean (x) x)

(* Convenience features: the ability to convert from internal
   representation of a 3-LISP structure to a LISP s-expr in
   such a way that they are notationally similar. *)

(* Here are some examples of what EXPORT does:

   3-LISP notation              LISP Approximation
   ---------------              ------------------
   1000, -10                    1000, -10
   $T, $F                       $T, $F
   ABC, FOO, NIL                ABC, FOO, NIL
   [1 2 3], []                  (& 1 2 3), (&)
   (A . B), (A B C)             (A &. B), (A B C)
   '100                         (&Q 100)
   @FOO                         @FOO
   {closure}                    {????}

*)

(defun export (x)
   (* x is the internal rep. of a 3-lisp expression. 
      Result is a printable LISP expression that
      looks like the printable 3-LISP expression
      in so far as external notation is concerned. *) 
   (cond
      ((boolean? x)
       (if x then '$T else '$F))
      ((atom? x)
       (extract-atom x))
      ((name? x)
       (extract-name x))
      ((numeral? x)
       (extract-numeral x))
      ((pair? x)
       (if (rail? (pcdr x)) then
           (if (empty? (pcdr x)) then
               (list (export (pcar x)))
            else
               (cdr (export-rail (prep (pcar x) (pcdr x)))))
        else
            (list (export (pcar x)) '&. (export (pcdr x)))))
      ((rail? x)
       (export-rail x))
      ((handle?  x)
       (list '&q (export (down x)))) 
      (t (concat "{? " x " ?}")) ))

(defun export-rail (x)
   (cons '& (for e in x until (eq e *rail*) collect (export e))))

(defun import (x)
   (* IMPORT is the converse of EXPORT. *)
   (cond
     ((numberp x) (make-numeral x))
     ((eq x '$T) (make-boolean t))
     ((eq x '$F) (make-boolean nil))
     ((member x '(&q &%. &%] &%;)) (error "syntax error" x))
     ((litatom x) 
      (if (eq '@ (nthchar x 1)) then
          (make-name x)
       else
          (make-atom x)))
     ((listp x)
      (setq x (remove-commentary x))
      (cond ((eq (car x) '&)
             (import-rail (cdr x)))
            ((or (eq (car x) '&q) (eq (car x) '%'))
             (up (import (cadr x))))
            ((eq (cadr x) '&.)
             (pcons (import (car x)) 
                    (import (caddr x))))
            (t (pcons (import (car x))
                      (import-rail (cdr x))))))
     (t x)))

(defun remove-commentary (x)
   (if (some x (function (lambda (e) (eq (car e) '&%;)))) then
       (for e in x join 
          (if (and (listp e) (eq (car e) '&%;)) then
              nil
           else
              (list e)))
    else
       x))

(defun import-rail (x)
   (append (for e in x collect (import e)) (rcons0)))

(defun build-read-table ()
   (prog ()
      (setq nlisp-read-table
          (copyreadtable t))
      (* disable all characters *)
      (for i from 0 to 255 do
          (setsyntax i 'other nlisp-read-table))
      
      (* Make it just the way we want. *)
      (setsyntax (charcode "(") 'leftparen nlisp-read-table)
      (setsyntax (charcode ")") 'rightparen nlisp-read-table) 
      (setsyntax (charcode "[") 
          '(macro always nonimmediate noescquote read-open-bracket)
          nlisp-read-table) 
      (setsyntax (charcode "]") 
          '(macro always nonimmediate noescquote read-close-bracket)
          nlisp-read-table) 
      (setsyntax (charcode " ") 'seprchar nlisp-read-table) (* SP *)
      (setsyntax 9              'seprchar nlisp-read-table) (* TAB *)
      (setsyntax 10             'seprchar nlisp-read-table) (* LF *)
      (setsyntax 13             'seprchar nlisp-read-table) (* CR *)
      (setsyntax (charcode "'") 
         '(macro always nonimmediate noescquote read-quote)
          nlisp-read-table)
      (setsyntax (charcode ".") 
         '(macro alone nonimmediate noescquote read-dot)
          nlisp-read-table)
      (setsyntax (charcode ";") 
         '(macro always nonimmediate noescquote read-comment)
          nlisp-read-table)
      
      (return nil)))

(defun read-open-bracket (file read-table)
   (prog (exp result)
      (setq result
         (while (neq '&%] (setq exp (read file read-table))) 
            collect exp))
      (return (cons '& result))))

(defun read-close-bracket (file read-table) '&%])

(defun read-quote (file read-table)
   (prog (following-expression)
      (setq following-expression (read file read-table))
      (return (list '&q following-expression))))

(defun read-dot (file read-table) '&.)

(defun read-comment (file read-table)
   (prog (l)
     (setq l (cons nil nil))
     (while (neq (character 13) (peekc file read-table)) do
         (tconc l (readc file read-table)))
     (return (list '&%; (apply (function concat) (car l))))))


(build-read-table)  (* It does'nt change. *)

STOP