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