[Gd-chatter] r10828 - in trunk/ltd: . code doc lib test
housel at gwydiondylan.org
housel at gwydiondylan.org
Tue Jul 25 22:13:21 CEST 2006
Author: housel
Date: Tue Jul 25 22:13:07 2006
New Revision: 10828
Added:
trunk/ltd/
trunk/ltd/code/
trunk/ltd/code/dpp.lisp (contents, props changed)
trunk/ltd/code/load.lisp (contents, props changed)
trunk/ltd/code/loop.lisp (contents, props changed)
trunk/ltd/code/ltd-table.lisp (contents, props changed)
trunk/ltd/code/ltd.lisp (contents, props changed)
trunk/ltd/code/misc.lisp (contents, props changed)
trunk/ltd/code/options.lisp (contents, props changed)
trunk/ltd/code/read.lisp (contents, props changed)
trunk/ltd/code/tables.lisp (contents, props changed)
trunk/ltd/doc/
trunk/ltd/doc/ltd.html (contents, props changed)
trunk/ltd/doc/problems.html (contents, props changed)
trunk/ltd/doc/tool.html (contents, props changed)
trunk/ltd/lib/
trunk/ltd/lib/cl-extra.dylan (contents, props changed)
trunk/ltd/lib/cl-plists.dylan (contents, props changed)
trunk/ltd/lib/cl-sequences.dylan (contents, props changed)
trunk/ltd/lib/cl-strings.dylan (contents, props changed)
trunk/ltd/lib/cl.lid (contents, props changed)
trunk/ltd/lib/macros.dylan (contents, props changed)
trunk/ltd/lib/module.dylan (contents, props changed)
trunk/ltd/test/
trunk/ltd/test/LINNEUS.dylan (contents, props changed)
trunk/ltd/test/LINNEUS.lisp (contents, props changed)
trunk/ltd/test/PROVER.dylan (contents, props changed)
trunk/ltd/test/PROVER.lisp (contents, props changed)
trunk/ltd/test/RAMER.dylan (contents, props changed)
trunk/ltd/test/RAMER.lisp (contents, props changed)
trunk/ltd/test/TEST.dylan (contents, props changed)
trunk/ltd/test/TEST.lisp (contents, props changed)
trunk/ltd/test/aima-dtp.dylan (contents, props changed)
trunk/ltd/test/aima-dtp.lisp (contents, props changed)
trunk/ltd/test/answers.dylan (contents, props changed)
trunk/ltd/test/answers.lisp (contents, props changed)
trunk/ltd/test/atms.dylan (contents, props changed)
trunk/ltd/test/atms.lisp (contents, props changed)
trunk/ltd/test/auxfns.dylan (contents, props changed)
trunk/ltd/test/auxfns.lisp (contents, props changed)
trunk/ltd/test/backprop.dylan (contents, props changed)
trunk/ltd/test/backprop.lisp (contents, props changed)
trunk/ltd/test/backtrack.dylan (contents, props changed)
trunk/ltd/test/backtrack.lisp (contents, props changed)
trunk/ltd/test/backward.dylan (contents, props changed)
trunk/ltd/test/backward.lisp (contents, props changed)
trunk/ltd/test/below.dylan (contents, props changed)
trunk/ltd/test/below.lisp (contents, props changed)
trunk/ltd/test/binding-dag.dylan (contents, props changed)
trunk/ltd/test/binding-dag.lisp (contents, props changed)
trunk/ltd/test/bindings.dylan (contents, props changed)
trunk/ltd/test/bindings.lisp (contents, props changed)
trunk/ltd/test/caching.dylan (contents, props changed)
trunk/ltd/test/caching.lisp (contents, props changed)
trunk/ltd/test/classes.dylan (contents, props changed)
trunk/ltd/test/classes.lisp (contents, props changed)
trunk/ltd/test/clauses.dylan (contents, props changed)
trunk/ltd/test/clauses.lisp (contents, props changed)
trunk/ltd/test/clos.dylan (contents, props changed)
trunk/ltd/test/clos.lisp (contents, props changed)
trunk/ltd/test/cmacsyma.dylan (contents, props changed)
trunk/ltd/test/cmacsyma.lisp (contents, props changed)
trunk/ltd/test/cnf.dylan (contents, props changed)
trunk/ltd/test/cnf.lisp (contents, props changed)
trunk/ltd/test/compile1.dylan (contents, props changed)
trunk/ltd/test/compile1.lisp (contents, props changed)
trunk/ltd/test/compile2.dylan (contents, props changed)
trunk/ltd/test/compile2.lisp (contents, props changed)
trunk/ltd/test/compile3.dylan (contents, props changed)
trunk/ltd/test/compile3.lisp (contents, props changed)
trunk/ltd/test/compopt.dylan (contents, props changed)
trunk/ltd/test/compopt.lisp (contents, props changed)
trunk/ltd/test/conjunct.dylan (contents, props changed)
trunk/ltd/test/conjunct.lisp (contents, props changed)
trunk/ltd/test/conjunctions.dylan (contents, props changed)
trunk/ltd/test/conjunctions.lisp (contents, props changed)
trunk/ltd/test/database.dylan (contents, props changed)
trunk/ltd/test/database.lisp (contents, props changed)
trunk/ltd/test/delta.dylan (contents, props changed)
trunk/ltd/test/delta.lisp (contents, props changed)
trunk/ltd/test/diffrat.dylan (contents, props changed)
trunk/ltd/test/diffrat.lisp (contents, props changed)
trunk/ltd/test/disp1.dylan (contents, props changed)
trunk/ltd/test/disp1.lisp (contents, props changed)
trunk/ltd/test/eliza-pm.dylan (contents, props changed)
trunk/ltd/test/eliza-pm.lisp (contents, props changed)
trunk/ltd/test/eliza.dylan (contents, props changed)
trunk/ltd/test/eliza.lisp (contents, props changed)
trunk/ltd/test/eliza1.dylan (contents, props changed)
trunk/ltd/test/eliza1.lisp (contents, props changed)
trunk/ltd/test/epikit-dtp.dylan (contents, props changed)
trunk/ltd/test/epikit-dtp.lisp (contents, props changed)
trunk/ltd/test/eval.dylan (contents, props changed)
trunk/ltd/test/eval.lisp (contents, props changed)
trunk/ltd/test/file.dylan (contents, props changed)
trunk/ltd/test/file.lisp (contents, props changed)
trunk/ltd/test/fork.dylan (contents, props changed)
trunk/ltd/test/fork.lisp (contents, props changed)
trunk/ltd/test/frules.dylan (contents, props changed)
trunk/ltd/test/frules.lisp (contents, props changed)
trunk/ltd/test/gps-srch.dylan (contents, props changed)
trunk/ltd/test/gps-srch.lisp (contents, props changed)
trunk/ltd/test/gps.dylan (contents, props changed)
trunk/ltd/test/gps.lisp (contents, props changed)
trunk/ltd/test/gps1.dylan (contents, props changed)
trunk/ltd/test/gps1.lisp (contents, props changed)
trunk/ltd/test/graph-unify.dylan (contents, props changed)
trunk/ltd/test/graph-unify.lisp (contents, props changed)
trunk/ltd/test/hierarchy.dylan (contents, props changed)
trunk/ltd/test/hierarchy.lisp (contents, props changed)
trunk/ltd/test/init.dylan (contents, props changed)
trunk/ltd/test/init.lisp (contents, props changed)
trunk/ltd/test/init2.dylan (contents, props changed)
trunk/ltd/test/init2.lisp (contents, props changed)
trunk/ltd/test/internals.dylan (contents, props changed)
trunk/ltd/test/internals.lisp (contents, props changed)
trunk/ltd/test/interp1.dylan (contents, props changed)
trunk/ltd/test/interp1.lisp (contents, props changed)
trunk/ltd/test/interp2.dylan (contents, props changed)
trunk/ltd/test/interp2.lisp (contents, props changed)
trunk/ltd/test/interp3.dylan (contents, props changed)
trunk/ltd/test/interp3.lisp (contents, props changed)
trunk/ltd/test/intro.dylan (contents, props changed)
trunk/ltd/test/intro.lisp (contents, props changed)
trunk/ltd/test/jsaint.dylan (contents, props changed)
trunk/ltd/test/jsaint.lisp (contents, props changed)
trunk/ltd/test/jtms.dylan (contents, props changed)
trunk/ltd/test/jtms.lisp (contents, props changed)
trunk/ltd/test/kd.dylan (contents, props changed)
trunk/ltd/test/kd.lisp (contents, props changed)
trunk/ltd/test/krep.dylan (contents, props changed)
trunk/ltd/test/krep.lisp (contents, props changed)
trunk/ltd/test/krep1.dylan (contents, props changed)
trunk/ltd/test/krep1.lisp (contents, props changed)
trunk/ltd/test/krep2.dylan (contents, props changed)
trunk/ltd/test/krep2.lisp (contents, props changed)
trunk/ltd/test/labels.dylan (contents, props changed)
trunk/ltd/test/labels.lisp (contents, props changed)
trunk/ltd/test/lcp.dylan (contents, props changed)
trunk/ltd/test/lcp.lisp (contents, props changed)
trunk/ltd/test/lexicon.dylan (contents, props changed)
trunk/ltd/test/lexicon.lisp (contents, props changed)
trunk/ltd/test/library.dylan (contents, props changed)
trunk/ltd/test/library.lisp (contents, props changed)
trunk/ltd/test/literals.dylan (contents, props changed)
trunk/ltd/test/literals.lisp (contents, props changed)
trunk/ltd/test/macsyma.dylan (contents, props changed)
trunk/ltd/test/macsyma.lisp (contents, props changed)
trunk/ltd/test/macsymar.dylan (contents, props changed)
trunk/ltd/test/macsymar.lisp (contents, props changed)
trunk/ltd/test/match.dylan (contents, props changed)
trunk/ltd/test/match.lisp (contents, props changed)
trunk/ltd/test/match16.dylan (contents, props changed)
trunk/ltd/test/match16.lisp (contents, props changed)
trunk/ltd/test/mcchef.dylan (contents, props changed)
trunk/ltd/test/mcchef.lisp (contents, props changed)
trunk/ltd/test/mcmops.dylan (contents, props changed)
trunk/ltd/test/mcmops.lisp (contents, props changed)
trunk/ltd/test/micro-tale-spin.dylan (contents, props changed)
trunk/ltd/test/micro-tale-spin.lisp (contents, props changed)
trunk/ltd/test/misc-inference.dylan (contents, props changed)
trunk/ltd/test/misc-inference.lisp (contents, props changed)
trunk/ltd/test/mma-match.dylan (contents, props changed)
trunk/ltd/test/mma-match.lisp (contents, props changed)
trunk/ltd/test/mma.dylan (contents, props changed)
trunk/ltd/test/mma.lisp (contents, props changed)
trunk/ltd/test/mycin.dylan (contents, props changed)
trunk/ltd/test/mycin.lisp (contents, props changed)
trunk/ltd/test/n-puzzle.dylan (contents, props changed)
trunk/ltd/test/n-puzzle.lisp (contents, props changed)
trunk/ltd/test/onlisp.dylan (contents, props changed)
trunk/ltd/test/onlisp.lisp (contents, props changed)
trunk/ltd/test/ordering.dylan (contents, props changed)
trunk/ltd/test/ordering.lisp (contents, props changed)
trunk/ltd/test/othello.dylan (contents, props changed)
trunk/ltd/test/othello.lisp (contents, props changed)
trunk/ltd/test/othello2.dylan (contents, props changed)
trunk/ltd/test/othello2.lisp (contents, props changed)
trunk/ltd/test/output.dylan (contents, props changed)
trunk/ltd/test/output.lisp (contents, props changed)
trunk/ltd/test/overview.dylan (contents, props changed)
trunk/ltd/test/overview.lisp (contents, props changed)
trunk/ltd/test/parser.dylan (contents, props changed)
trunk/ltd/test/parser.lisp (contents, props changed)
trunk/ltd/test/patmatch.dylan (contents, props changed)
trunk/ltd/test/patmatch.lisp (contents, props changed)
trunk/ltd/test/pf.dylan (contents, props changed)
trunk/ltd/test/pf.lisp (contents, props changed)
trunk/ltd/test/poly.dylan (contents, props changed)
trunk/ltd/test/poly.lisp (contents, props changed)
trunk/ltd/test/primeq.dylan (contents, props changed)
trunk/ltd/test/primeq.lisp (contents, props changed)
trunk/ltd/test/prover.dylan (contents, props changed)
trunk/ltd/test/prover.lisp (contents, props changed)
trunk/ltd/test/rat1.dylan (contents, props changed)
trunk/ltd/test/rat1.lisp (contents, props changed)
trunk/ltd/test/residue.dylan (contents, props changed)
trunk/ltd/test/residue.lisp (contents, props changed)
trunk/ltd/test/search.dylan (contents, props changed)
trunk/ltd/test/search.lisp (contents, props changed)
trunk/ltd/test/simp1.dylan (contents, props changed)
trunk/ltd/test/simp1.lisp (contents, props changed)
trunk/ltd/test/simple.dylan (contents, props changed)
trunk/ltd/test/simple.lisp (contents, props changed)
trunk/ltd/test/stack1.dylan (contents, props changed)
trunk/ltd/test/stack1.lisp (contents, props changed)
trunk/ltd/test/structures.dylan (contents, props changed)
trunk/ltd/test/structures.lisp (contents, props changed)
trunk/ltd/test/student.dylan (contents, props changed)
trunk/ltd/test/student.lisp (contents, props changed)
trunk/ltd/test/subgoals.dylan (contents, props changed)
trunk/ltd/test/subgoals.lisp (contents, props changed)
trunk/ltd/test/symbols.dylan (contents, props changed)
trunk/ltd/test/symbols.lisp (contents, props changed)
trunk/ltd/test/terms.dylan (contents, props changed)
trunk/ltd/test/terms.lisp (contents, props changed)
trunk/ltd/test/textify.dylan (contents, props changed)
trunk/ltd/test/textify.lisp (contents, props changed)
trunk/ltd/test/time.dylan (contents, props changed)
trunk/ltd/test/time.lisp (contents, props changed)
trunk/ltd/test/tptp.dylan (contents, props changed)
trunk/ltd/test/tptp.lisp (contents, props changed)
trunk/ltd/test/types.dylan (contents, props changed)
trunk/ltd/test/types.lisp (contents, props changed)
trunk/ltd/test/ucons1.dylan (contents, props changed)
trunk/ltd/test/ucons1.lisp (contents, props changed)
trunk/ltd/test/uconsalt.dylan (contents, props changed)
trunk/ltd/test/uconsalt.lisp (contents, props changed)
trunk/ltd/test/unifgram.dylan (contents, props changed)
trunk/ltd/test/unifgram.lisp (contents, props changed)
trunk/ltd/test/unify.dylan (contents, props changed)
trunk/ltd/test/unify.lisp (contents, props changed)
trunk/ltd/test/version.dylan (contents, props changed)
trunk/ltd/test/version.lisp (contents, props changed)
trunk/ltd/test/waltz.dylan (contents, props changed)
trunk/ltd/test/waltz.lisp (contents, props changed)
trunk/ltd/test/winston-clos.dylan (contents, props changed)
trunk/ltd/test/winston-clos.lisp (contents, props changed)
Log:
Bug: 7322
Pristine import of Peter Norvig's Lisp-To-Dylan translator, LTD.
Added: trunk/ltd/code/dpp.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/dpp.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,449 @@
+;;; -*- Mode: lisp; Syntax: common-lisp; -*- Author: Peter Norvig
+;;; File: dpp.lisp; Date: 29-Aug-95
+(in-package :cl-user)
+
+;;;; DPP: DYLAN PRETTY-PRINTER
+
+;;; Use (dpp-exp x) to write x as Dylan.
+;;; Example:
+;;; (dpp-exp '(define-method m (:args x y) (+ (^ x 2) (^ y 2)))
+;;; :right-margin 30 :miser-width 0)
+;;; =>
+;;; define method m (x,y)
+;;; x ^ 2 + y ^ 2;
+;;; end method m
+
+;;;; SPECIAL VARIABLES
+
+(defparameter *dylan-pp-dispatch* (copy-pprint-dispatch))
+(defparameter *precedence* 0 "Precedence of last operator.")
+(defparameter *in-literal* nil "Are we in the process of printing a literal?")
+(defparameter *dotted-functions* nil "Functions that print as object.fn")
+
+;;;; MAIN FUNCTION
+
+(defun dpp-exp (x &rest keys)
+ "Pretty print (as Dylan code) x, which is in prefix pseudo-Dylan."
+ (let ((*precedence* 0))
+ (apply #'write x :pretty t #+LispWorks :pprint
+ #-Lispworks :pprint-dispatch *dylan-pp-dispatch* keys)
+ (values)))
+
+;;;; MACRO FOR DEFINING PRETTY-PRINT DISPATCH ROUTINES
+
+(defmacro dpp (type code &key (priority 0))
+ "Define a dylan pretty-printer method for a given type."
+ ;; If TYPE is of the form 'type, define dispatcher for that type.
+ ;; If TYPE is of the form (symbol), define for cons starting with symbol.
+ ;; CODE can reference S (the stream) and X (the object to print),
+ ;; Or it can be a function that gets passed S and X.
+ (let ((value (if (starts-with code 'function) `',(second/ code)
+ `#'(lambda (s x) ,code))))
+ (if (and (starts-with type 'quote) (= (length type) 2))
+ `(set-pprint-dispatch ,type ,value ,priority *dylan-pp-dispatch*)
+ `(setf (get ',(first type) 'dpp) ,value))))
+
+
+;;;; PRETTY-PRINT DISPATCH TABLES
+
+(dpp 'cons #'dpp-cons)
+(dpp 'symbol #'dpp-symbol)
+(dpp 'com #'dpp-comment)
+(dpp 'atom #'dpp-literal :priority -1)
+
+(dpp (:args) (dpp-args s (rest/ x)))
+(dpp (:args-bare) (dpp-args s (rest/ x) "" ""))
+(dpp (:body) #'dpp-body)
+(dpp (:body-bare) (dpp-body s `(:body (nil) ,@(rest/ x)) nil))
+(dpp (:branch) #'dpp-branch)
+(dpp (:clause) #'dpp-clause)
+(dpp (:cleanup) #'dpp-unindented)
+(dpp (:else) #'dpp-unindented)
+(dpp (:elseif) #'dpp-unindented1)
+(dpp (:exception) #'dpp-unindented1)
+(dpp (:finally) #'dpp-unindented)
+(dpp (:for-clause) #'dpp-for-clause)
+(dpp (:keyword) (dpp-keyword-with-colon s (second/ x)))
+(dpp (:list) (dpp-list s (rest/ x)))
+(dpp (:list-bare) (dpp-list s (rest/ x) "" ""))
+(dpp (:local-method) #'dpp-local-method)
+(dpp (:return) #'dpp-return)
+(dpp (:slot) (format s "~@<slot ~W~:>" `(:args-bare ,@(rest/ x))))
+(dpp (:slot-keyword) #'dpp-slot-keyword)
+
+(dpp (aref) (format s "~W[~:I~{~W~^, ~_~}]" (second/ x) (nthcdr 2 x)))
+(dpp (begin) (format s "~@<begin~W~:>" `(:body (end) ,@(rest/ x))))
+(dpp (block) #'dpp-conditional)
+(dpp (case) (format s "~@<case~W~:>" `(:body (end case) ,@(rest/ x))))
+(dpp (define-class) (dpp-define-method s x "class"))
+(dpp (define-constant)(dpp-define-variable s x "constant"))
+(dpp (define-generic) #'dpp-define-generic)
+(dpp (define-method) #'dpp-define-method)
+(dpp (define-function)(dpp-define-method s x "function"))
+(dpp (define-variable)#'dpp-define-variable)
+(dpp (define-module) #'dpp-define-module)
+(dpp (element) #'dpp-element)
+(dpp (fluid-bind) #'dpp-conditional)
+(dpp (for) #'dpp-conditional)
+(dpp (if) #'dpp-conditional)
+(dpp (let) #'dpp-let)
+(dpp (method) #'dpp-method)
+(dpp (let-handler) (dpp-let s x "let handler"))
+(dpp (local) (format s "local~W" `(:body-bare ,@(rest/ x))))
+(dpp (quote) (dpp-literal s (second/ x)))
+(dpp (select) #'dpp-conditional)
+(dpp (unless) #'dpp-conditional)
+(dpp (until) #'dpp-conditional)
+(dpp (while) #'dpp-conditional)
+(dpp (with-open-file) #'dpp-conditional)
+
+;;;; PRETTY-PRINTERS FOR SYNTACTIC COMPONENTS
+
+;;; (Listed in roughly the order they appear in the table above.)
+
+(defun dpp-cons (s x)
+ "Pretty-print an x that is a cons of any kind."
+ (let* ((fn (first/ x))
+ (dispatch (if (symbolp fn) (get fn 'dpp))))
+ ;; There are 6 possibilities:
+ (cond (*in-literal* (dpp-literal s x)) ; e.g. #(1, 2)
+ (dispatch (funcall dispatch s x)) ; e.g. if (a) b; else c; end
+ ((unary? x) (dpp-unary s x)) ; e.g. - x
+ ((binary? x) (dpp-binary s x)) ; e.g. x + y
+ ((dot-notation-call? x) ; e.g. object.slot
+ (dpp-binary s `(|.| ,(second/ x) ,(first/ x))))
+ (t (dpp-call s x)) ; e.g. f(x, y)
+ )))
+
+(defun dpp-call (s x)
+ ;; Print a function call in normal notation, e.g., f(x, y)
+ (pprint-logical-block (s nil)
+ (destructuring-bind (fn . args) x
+ (write (if (consp (strip fn)) `(:list ,fn) fn) :stream s)
+ (if (get-option :space-in-call) (write-string " " s))
+ (dpp-args s args))))
+
+(defun dpp-symbol (s x)
+ ;; Symbols print as names, e.g. sym or \+, unless we are in a literal.
+ ;; They print as #"sym" in a literal.
+ ;; Keywords print as literal, e.g., #"key", except in dpp-keyword-with-colon.
+ (let ((str (dylan-symbol-string x)))
+ (cond ((null *print-escape*) (write-string str s))
+ ((or (keywordp x) *in-literal*) (dpp-literal s x))
+ ((operator? x) (write-char #\\ s) (write-string str s))
+ (t (write-string str s)))))
+
+(defun dylan-symbol-string (x)
+ ;; Decide whether to include package
+ (let* ((str (string-downcase (symbol-name x)))
+ (package (if (and (get-option ':print-package)
+ (not (operator? x))
+ (not (keywordp x)))
+ (string-downcase (package-shortest-name
+ (symbol-package x))))))
+ (if package (concatenate 'string package "/" str) str)))
+
+(defun dylan-name-string (x)
+ ;; Convert symbol x to a legal Dylan name
+ (if (member x '(|\#key| |\#rest| |\#all-keys|))
+ (symbol-name x)
+ (let ((str (nsubstitute-if-not #\% #'dylan-name-char?
+ (dylan-symbol-string x))))
+ (when (not (dylan-name-start-char? (char str 0)))
+ (setf (char str 0) #\%))
+ str)))
+
+(defun dylan-name-char? (ch)
+ ;; Can this char be in a Dylan name?
+ (or (dylan-name-start-char? ch) (find ch "~+-?/")))
+
+(defun dylan-name-start-char? (ch)
+ ;; Can this character start a Dylan name?
+ (or (alpha-char-p ch) (digit-char-p ch) (find ch "!&*<=>|^$%@")))
+
+(defun package-shortest-name (package)
+ (let ((name (package-name package)))
+ (dolist (nick (package-nicknames package))
+ (when (< (length nick) (length name))
+ (setf name nick)))
+ name))
+
+(defun dpp-literal (s x)
+ (typecase x
+ (null (write-string "#()" s))
+ (string (dpp-string s x))
+ (character (dpp-string s x #\'))
+ (com (let ((*in-literal* t)) (dpp-comment s x)))
+ (cons (write-char #\# s)
+ (let ((*in-literal* t)) (dpp-list s x)))
+ (vector (write-char #\# s)
+ (let ((*in-literal* t)) (dpp-list s (coerce x 'list) "[" "]")))
+ (symbol (write-char #\# s) (dpp-string s (dylan-symbol-string x)))
+ (complex (dpp-exp `(+ ,(realpart x) (* ,(imagpart x) $i)) :stream s))
+ ((and rational (not integer))
+ (write (if *in-literal* (float x) x) :stream s :pretty nil)) ; Avoid 2/3
+ (t (write x :stream s :pretty nil))))
+
+(defun dpp-string (s string &optional (quote-char #\"))
+ (setf string (string string)) ; Coerce it if it is a character
+ (cond ((null *print-escape*) (write-string string s)) ; For printing comments
+ (t (write-char quote-char s)
+ (dotimes (i (length string))
+ (let ((ch (char string i)))
+ (cond ((eql ch quote-char) (write-char #\\ s) (write-char ch s))
+ ((eql ch #\newline) (write-string "\\n" s))
+ ((eql ch #\tab) (write-string "\\t" s))
+ ((eql ch #\\) (write-string "\\\\" s))
+ ((graphic-char-p ch) (write-char ch s))
+ (t (write-string "\\0" s)
+ (write (char-code ch) :stream s)))))
+ (write-char quote-char s))))
+
+(defun dpp-args (s args &optional (prefix "(") (suffix ")"))
+ "Given ((+ 0 1) 2 :key 3), print (0 + 1, 2, key: 3)"
+ ;; We could use dpp-list if it weren't for keywords.
+ ;; The caller (e.g. dpp-call) should have set up the proper indentation.
+ (pprint-logical-block (s nil :prefix prefix :suffix suffix)
+ (loop while args do
+ (cond ((atom args) (dpp-exp args :stream s) (setq args nil)) ; ???
+ ((and (dylan-keyword? (first/ args)) (rest/ args))
+ (dpp-keyword-with-colon s (pop args))
+ (format s " ~W" (pop args)))
+ ((and (member (first/ args) '(|\#key| |\#rest| |\#all-keys|))
+ (rest/ args))
+ (format s "~A ~W" (pop args) (pop args)))
+ ((dylan-keyword? (first/ args))
+ (dpp-literal s (pop args)))
+ (t (write (pop args) :stream s)))
+ (when args (format s ", ~:_")) ; a fill-style newline
+ )))
+
+(defun dpp-body (s x &optional (newline-first? :linear))
+ "Print a body of exps, each followed by a semicolon, maybe terminated by end."
+ ;; This does NOT establish a block; it uses the caller's block.
+ ;; It DOES insert a conditional newline (or a space) before each exp.
+ ;; Use (:body-bare . exps) if you don't want the newline before the first exp.
+ ;; Example x = (:body (end method m-name) blah blah)
+ (destructuring-bind ((&optional (end t) construct name) &rest body)
+ (rest/ x)
+ (loop while (consp body) do
+ (let* ((exp (pop body))
+ (indent (indentation exp)))
+ (when indent (pprint-indent :block indent s))
+ (write-char #\space s)
+ (if newline-first?
+ (pprint-newline newline-first? s)
+ (setf newline-first? :linear))
+ (write exp :stream s)
+ (if body (write-string ";" s))))
+ (when end ;; Print some of '; end construct name', depending on options.
+ (format s "~A~0I ~_end"
+ (if (get-option :semicolon-before-end) ";" ""))
+ (when (and construct (member-of-option construct :end-construct))
+ (format s " ~A" construct)
+ (when (and name (get-option :end-name))
+ (format s " ~A" name))))))
+
+(defun dpp-branch (s x)
+ (format s "~@<~W~:>" (second/ x))
+ (format s "~VI~_ =>~@<~W~:>" (* 2 (get-option :tab-stop))
+ `(:body-bare ,@(nthcdr 2 x))))
+
+(defun dpp-comment (s x)
+ (ifd (com-comment x)
+ (ecase (get-option :comments)
+ (// (pprint-logical-block (s nil :per-line-prefix "// ")
+ (write-string (com-comment x) s))
+ (pprint-newline :mandatory s))
+ (/* (pprint-logical-block (s nil :prefix "/* " :suffix " */")
+ (write-string (com-comment x) s)))))
+ (write (com-code x) :stream s))
+
+(defun dpp-unindented (s x)
+ "Given (:else x y z), print the else at column 0, then a block, no end."
+ (format s "~A~W" (first/ x) `(:body (nil) ,@(rest/ x))))
+
+(defun dpp-unindented1 (s x)
+ "Given (:elseif p y), print elseif (p) at column 0, then a block, no end."
+ (format s "~A (~W)~W" (first/ x) (second/ x) `(:body (nil) ,@(nthcdr 2 x))))
+
+(defun dpp-for-clause (s x)
+ ;; The only hitch is to avoid making = print as \=
+ (pprint-logical-block (s (rest/ x))
+ (let ((args (rest/ x)))
+ (loop while args do
+ (let ((arg (pop args)))
+ (if (symbolp arg)
+ (write-string (dylan-name-string arg) s)
+ (write arg :stream s))
+ (if args (write-string " " s)))))))
+
+(defun dpp-keyword-with-colon (s x)
+ ;; Print a keyword in the form `key:'
+ (write-string (dylan-name-string x) s)
+ (if (keywordp x) (write-char #\: s)))
+
+(defun dpp-list (s x &optional (prefix "(") (suffix ")"))
+ "Print a list, filled, with optional prefix and suffix."
+ ;; Given ((+ 0 1) 2 :key 3), print (0 + 1, 2, #"key", 3)
+ (pprint-logical-block (s nil :prefix prefix :suffix suffix)
+ ;(format s "~{~W~^, ~:_~}" x)
+ (loop while (and (consp x) (consp (rest/ x))) do
+ (format s "~W, ~:_" (pop x)))
+ ;; If x is of form (exp) or (exp . dot), print exp
+ (when (consp x)
+ (format s "~W" (pop x)))
+ ;; Now x is an atom; print ` . x' if it is non-null
+ (when (not (null x))
+ (format s "~:_ . ~W" x))))
+
+(defun dpp-local-method (s x)
+ (destructuring-bind (name args . body) (rest/ x)
+ ;; The ~:I sets the tab stop at the start of the name; used by :return
+ (format s "~@<method ~:I~A ~W~W~:>"
+ name args `(:body (end method ,name) , at body))))
+
+(defun dpp-return (s x)
+ "Print the return argument/types."
+ (let ((args (rest/ x)))
+ (format s "=> ~W"
+ (if (and (length=1 args) (not (get-option :single-returns-wrapped)))
+ (first/ args)
+ `(:list , at args)))))
+
+(defun dpp-slot-keyword (s x)
+ "Print the 'keyword x:, init-value: #t' from a define class."
+ (destructuring-bind (name . args) (rest/ x)
+ (format s "~@<keyword ~W~@[, ~W~]~:>"
+ `(:keyword ,name) (if args `(:args-bare , at args)))))
+
+(defun dpp-conditional (s x)
+ "Print an if, unless, select, until, while, for, or block expression."
+ (destructuring-bind (construct test . body) x
+ (format s "~@<~A (~W)~W~:>" construct test
+ `(:body (end ,construct) , at body))))
+
+(defun dpp-define-method (s x &optional (keyword 'method))
+ ;; This is also used for define-class, since they have the same structure.
+ (destructuring-bind (name parms . body) (rest/ x)
+ ;; The ~:I sets the tab stop at the start of the name; used by :return
+ (format s "~@<define ~A ~:I~A ~W~W~:>"
+ keyword name parms `(:body (end ,keyword ,name) , at body))))
+
+(defun dpp-clause (s x)
+ "E.g. (:clause export a b c) prints export a, b, c"
+ (destructuring-bind (header . names) (rest/ x)
+ (format s "~@<~W~{ ~W~^,~}~:>" header names)))
+
+(defun dpp-define-variable (s x &optional (keyword "variable"))
+ "Used for define {variable,constant}."
+ (format s "~@<define ~A ~W =~VI ~_~W~:>"
+ keyword (second/ x) (get-option :tab-stop) (third x)))
+
+(defun dpp-define-module (s x)
+ (destructuring-bind (name . clauses) (rest/ x)
+ (format s "~@<define module ~W~W~:>"
+ name `(:body (end module ,name) , at clauses))))
+
+(defun dpp-define-generic (s x)
+ (format s "~@<define generic ~A ~W ~_~W~:>"
+ (second/ x) (third x) `(:args-bare ,@(nthcdr 3 x))))
+
+(defun dpp-element (s x)
+ (cond ((= (length x) 3) (format s "~W" `(aref ,@(rest/ x))))
+ (t (dpp-call s x))))
+
+(defun dpp-let (s x &optional (keywords "let"))
+ ;; Note that this is a let binding for a single val.
+ ;; It fits within an existing body.
+ (destructuring-bind (var val . body) (rest/ x)
+ (format s "~A ~<~W ~_= ~W;~:>~W"
+ keywords (list var val) `(:body (nil) , at body))))
+
+(defun dpp-method (s x)
+ "Print a method (x) ... expression."
+ (destructuring-bind (args . body) (rest/ x)
+ (format s "~@<method ~W~W~:>" args `(:body (end method) , at body))))
+
+;;;; HANDLING INFIX OPERATORS
+
+(defparameter *unary*
+ '((- 7) (~ 7))
+ "List of unary operators and their precedence.")
+
+(defparameter *binary*
+ '((|.| 8) (|::| 8)
+ (^ 6)
+ (* 5) (/ 5)
+ (+ 4) (- 4)
+ (= 3) (== 3) (~= 3) (< 3) (> 3) (<= 3) (>= 3)
+ (& 2) (\| 2)
+ (:= 1) (|:=| 1))
+ "List of binary operators and their precedence.")
+
+(defun unary? (x)
+ (and (consp x) (length=1 (args x)) (assoc (op x) *unary*)))
+
+(defun binary? (x)
+ (and (consp x) (consp (args x)) (length=1 (rest/ (args x))) (assoc (op x) *binary*)))
+
+(defun operator? (symbol)
+ (or (assoc symbol *unary*) (assoc symbol *binary*)))
+
+(defun dpp-unary (s list)
+ (let* ((prec (second/ (unary? list)))
+ (nest (<= prec *precedence*))
+ (*precedence* prec))
+ (format s "~A~A ~W~A"
+ (if nest "(" "") (first/ list) (second/ list) (if nest ")" ""))))
+
+(defun dpp-binary (s list)
+ (let* ((prec (second/ (binary? list)))
+ (nest (<= prec *precedence*)))
+ (destructuring-bind (op x y) list
+ (pprint-logical-block
+ (s nil
+ :prefix (if nest "(" "")
+ :suffix (if nest ")" ""))
+ (let ((*precedence* (- prec 1)))
+ (write x :stream s))
+ (format s (case op (|.| "~_.") (:= "~_ := ") (t "~_ ~A ")) op)
+ (let ((*precedence* prec))
+ (write y :stream s))))))
+
+;;;; AUXILLIARY FUNCTIONS
+
+(defun unindented? (x)
+ "Is this an expression that should be printed unindented?"
+ (and (consp x) (symbolp (first/ x))
+ (member (get (first/ x) 'dpp) '(dpp-unindented dpp-unindented1))))
+
+(defun indentation (exp)
+ (cond ((unindented? exp) 0)
+ ((starts-with exp ':local-method)
+ (+ #.(length "local ") (get-option :tab-stop)))
+ ((starts-with exp ':return) nil)
+ (t (get-option :tab-stop))))
+
+(defun dot-notation-call? (x)
+ "Is x of suitable form for dot notation, e.g. (SLOT VAR)."
+ (and (consp x) (symbolp (first/ x)) (length=1 (args x))
+ (dot-function? (first/ x))
+ (or (atom (second/ x)) (dot-notation-call? (second/ x)))))
+
+(defun dot-function? (fn-name)
+ ;; Should this function, when called, be printed in dot notation?
+ ;; Note that :prefer-dot-notation and :undotted-functions are relatively
+ ;; static user-defined options, while *dotted-functions* changes dynamically,
+ ;; based on defstructs and defclasses.
+ (if (get-option :prefer-dot-notation)
+ (not (member-of-option fn-name :undotted-functions))
+ (member fn-name *dotted-functions*)))
+
+(defun dylan-keyword? (symbol)
+ "True of keywords and #rest, #key, #next, #all-keys."
+ (or (keywordp symbol) (dylan-method-keyword? symbol)))
+
+(defun dylan-method-keyword? (symbol)
+ "True of #rest, #key, #next, #all-keys."
+ (member symbol '(|\#rest| |\#key| |\#next| |\#all-keys|)))
\ No newline at end of file
Added: trunk/ltd/code/load.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/load.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,24 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: load.lisp; Date: 11-Sep-95
+(in-package :cl-user)
+
+;;;; Common Lisp to Dylan Converter --- (Load-LTD) loads the system
+
+(defun load-ltd (&key (compile nil))
+ (mapc #'(lambda (file) (load (if compile (compile-file file) file)))
+ '("misc.lisp" "options.lisp" "read.lisp" "dpp.lisp"
+ "ltd.lisp" "ltd-table.lisp" "loop.lisp" "tables.lisp")))
+
+(defun test-ltd ()
+ (defpackage comp)
+ (defpackage dtp)
+ (defpackage mma)
+ (defpackage excl)
+ (ltd-files "../test/*.lisp"))
+
+#+LispWorks
+(defsystem ltd (:package user)
+ :members
+ ("misc" "options" "read" "dpp" "ltd" "ltd-table" "loop" "tables"))
+
+
Added: trunk/ltd/code/loop.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/loop.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,327 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: User; -*-
+(in-package :cl-user)
+
+;;;; CVT-LOOP and friends
+
+;;; Code taken from Norvig's PAIP, modified to generate Dylan instead of
+;;; Lisp, and augmented to handle more loop clauses, and to handle loop
+;;; symbols in different packages.
+
+(defstruct loops ;; LOOPS stands for LOOP Structure (can't use LOOP).
+ "A structure to hold parts of a loop as it is built."
+ (code nil) ;; The original complete Lisp code
+ (exps nil) ;; What remains to be parsed
+ (vars nil) ;; List of (var val), in Lisp (reversed)
+ (fors nil) ;; List of DYLAN code
+ (body nil) ;; List of Lisp code (reversed)
+ (prologue nil) ;; List of Lisp code (reversed)
+ (epilogue nil) ;; List of Lisp code (reversed)
+ (result nil) ;; The final result (Lisp)
+ (name nil) ;; Name for return-from
+ (conditionals nil)) ;; Stack of currently active when/unless's
+
+(defun cvt-loop (exp)
+ "Supports both ANSI and simple LOOP. Warning: Not all of LOOP is supported."
+ (if (listp (strip (first/ (args exp))))
+ ;; No keyword implies simple loop:
+ (handle-returns1 `(while |\#t| ,@(cvt-body (args exp))))
+ ;; otherwise process loop keywords:
+ (let ((l (make-loops :code exp :exps (args exp))))
+ (CATCH 'LOOP-ERROR
+ (loop (if (null (loops-exps l)) (RETURN))
+ (parse-clause l))
+ (fill-loop-template l)))))
+
+(defun parse-clause (l)
+ (let ((key (pop (loops-exps l))))
+ (funcall (get-loop-fn key) l key (pop (loops-exps l)))))
+
+(defun fill-loop-template (l)
+ "Use a loops-structure instance to fill the template."
+ (let ((code (handle-returns1
+ `(for (:list-bare ,@(nreverse (loops-fors l)))
+ ,@(cvt-exps (nreverse (loops-body l)))
+ ,@(if (or (loops-epilogue l) (loops-result l))
+ `((:finally ,@(cvt-exps (nreverse (loops-epilogue l)))
+ ,(cvt-exp (loops-result l))))))
+ (loops-name l))))
+ (loop for (var val) in (loops-vars l) do
+ (setf code `(let ,(cvt-exp var) ,(cvt-exp val) ,code)))
+ (when (loops-prologue l)
+ (setf code `(begin ,@(cvt-exps (nreverse (loops-prologue l))) ,code)))
+ (encapsulate-let code)))
+
+(defun loop-error (l key exp)
+ (cond ((get-option :macroexpand-hard-loops)
+ (let ((expanded (handle-loop-finish (safe-macroexpand (loops-code l)))))
+ (warn "Can't handle ~A ~A in loop; macroexpanding." key exp)
+ (THROW 'LOOP-ERROR (cvt-exp expanded))))
+ (t (push (cvt-erroneous (loops-code l) nil
+ "Can't handle ~A ~A in loop." key exp)
+ (loops-body l)))))
+
+
+(defvar *loop-fns* (make-hash-table :test #'equal))
+
+(defun get-loop-fn (key)
+ (let ((sym (strip key)))
+ (or (and (symbolp sym) (gethash (string sym) *loop-fns*))
+ 'loop-error)))
+
+(defmacro def-loop (keys (l next-exp &optional (key-var 'key)) &rest body)
+ "Define a new LOOP keyword or keywords."
+ `(setf ,@(mapcan
+ #'(lambda (key)
+ `((gethash ,(string key) *loop-fns*)
+ #'(lambda (,l ,key-var ,next-exp)
+ (declare (ignore ,key-var))
+ , at body)))
+ (mklist keys))))
+
+(defun add-var (l var init)
+ "Add a variable to the loop."
+ (unless (assoc/ (strip var) (loops-vars l))
+ (push (list var init) (loops-vars l))))
+
+(defun handle-loop-finish (exp)
+ (if (and (starts-with exp 'macrolet) (length=1 (second/ exp))
+ (eq 'loop-finish (first/ (first/ (second/ exp)))))
+ (subst (third (first/ (second/ exp))) '(loop-finish)
+ `(progn ,@(cddr exp))
+ :test #'equal)
+ exp))
+
+(defun parse-loop-key (l &rest keys)
+ "If the next exp in L is one of keys, pop it and return true."
+ (when (apply #'loop=? (first/ (loops-exps l)) keys)
+ (pop (loops-exps l))
+ t))
+
+(defun loop=? (exp &rest options)
+ ;; Is exp a symbol that is spelled the same as one of the options?
+ (and (symbolp (strip exp))
+ (member (strip exp) options :test #'string-equal)))
+
+;;;; Loop Clauses 26.6 (p 716 CLtL2) Iteration Control
+
+(def-loop (FOR AS) (l var)
+ (when (not (symbolp (strip var)))
+ (loop-error l 'for var))
+ (setq var (parse-var l var))
+ (cond
+ ((parse-loop-key l "IN" "ACROSS")
+ (push `(:for-clause ,var in ,(cvt-exp (pop (loops-exps l))))
+ (loops-fors l)))
+ ((parse-loop-key l "ON")
+ (let ((by (if (parse-loop-key l "BY")
+ (cvt-exp (pop (loops-exps l)))
+ 'tail)))
+ (push `(:for-clause ,var = ,(cvt-exp (pop (loops-exps l)))
+ then (,by ,var))
+ (loops-fors l))
+ (push `(:for-clause :until (empty? ,var)) (loops-fors l))))
+ ((parse-loop-key l "BEING")
+ (parse-loop-key l "EACH" "THE")
+ (cond ((parse-loop-key l "HASH-VALUE" "HASH-VALUES")
+ (push `(:for-clause ,var in ,(cvt-exp (pop (loops-exps l))))
+ (loops-fors l)))
+ ((parse-loop-key l "HASH-KEY" "HASH-KEYS")
+ (push `(:for-clause ,var in
+ (key-sequence ,(cvt-exp (pop (loops-exps l)))))
+ (loops-fors l)))
+ (t (loop-error l 'for var))))
+ ((parse-loop-key l "=")
+ (let* ((init (cvt-exp (pop (loops-exps l))))
+ (next (if (parse-loop-key l "THEN")
+ (cvt-exp (pop (loops-exps l)))
+ init)))
+ (push `(:for-clause ,var = ,init then ,next) (loops-fors l))))
+ (t (try-loop-for-arithmetic l var))))
+
+(defun try-loop-for-arithmetic (l var)
+ (let ((start 0)
+ (to nil)
+ (by nil)
+ (negative? nil))
+ (loop (let ((subkey (first/ (loops-exps l))))
+ (cond ((loop=? subkey "TO" "BELOW" "ABOVE")
+ (when (loop=? subkey "ABOVE") (setq negative? t))
+ (pop (loops-exps l))
+ (setf to (list subkey (cvt-exp (pop (loops-exps l))))))
+ ((loop=? subkey "UPTO" "DOWNTO") ;; Convert to TO
+ (when (loop=? subkey "DOWNTTO") (setq negative? t))
+ (pop (loops-exps l))
+ (push 'to (loops-exps l)))
+ ((loop=? subkey "FROM" "DOWNFROM" "UPFROM")
+ (when (loop=? subkey "DOWNFROM") (setq negative? t))
+ (pop (loops-exps l))
+ (setq start (cvt-exp (pop (loops-exps l)))))
+ ((loop=? subkey "BY")
+ (pop (loops-exps l))
+ (setf by (list subkey (cvt-exp (pop (loops-exps l))))))
+ (t (RETURN)))))
+ ;; A bit tricky here: Lisp's BY clause are always positive,
+ ;; Dylan's are negative for decrement. E.g., we want
+ ;; (loop for x downfrom 10 to 0 by 2) => for(x from 10 to 0 by -2)
+ ;; (loop for x downfrom 10 to 0) => for(x from 10 to 0 by -1)
+ ;; (loop for x downfrom 10 above 0) => for(x from 10 above 0)
+ (when negative?
+ (cond (by (setf (second by) `(-- ,(second by))))
+ ((null to) (setf by '(by -1)))
+ ((loop=? (first to) "ABOVE") 'ignore)
+ (t (setf by '(by -1)))))
+ (push `(:for-clause ,var from ,start , at to , at by) (loops-fors l))))
+
+(def-loop repeat (l times)
+ "(LOOP REPEAT n ...) does loop body n times"
+ (push `(:for-clause _ from 1 to ,(cvt-exp times)) (loops-fors l)))
+
+;;;; Loop Clauses 26.7 End-Test Control
+
+(def-loop while (l test)
+ (push `(:for-clause :while ,(cvt-exp test)) (loops-fors l)))
+
+(def-loop until (l test)
+ (push `(:for-clause :until ,(cvt-exp test)) (loops-fors l)))
+
+(def-loop always (l test)
+ (setf (loops-result l) 't)
+ (add-body l `(if (not ,test) (return 'nil))))
+
+(def-loop never (l test)
+ (setf (loops-result l) 't)
+ (add-body l `(if ,test (return 'nil))))
+
+(def-loop thereis (l test)
+ (setf (loops-result l) 'nil)
+ (add-var l '_ nil)
+ (add-body l `(if (setq _ ,test (return _)))))
+
+;;;; Loop Clauses 26.8 Value Accumulation
+
+(def-loop (collect collecting) (l exp)
+ (accumulate l exp '(make <deque>) '(push-last INTO VAL)))
+
+(def-loop (nconc nconcing) (l exp)
+ (accumulate l exp '|()| '(setq INTO (nconc INTO VAL))))
+(def-loop (append appending) (l exp)
+ (accumulate l exp '|()| '(setq INTO (append INTO VAL))))
+
+(def-loop (count counting) (l exp) (accumulate l exp 0 '(if VAL (incf INTO))))
+
+(def-loop (sum summing) (l exp) (accumulate l exp 0 '(incf INTO VAL)))
+
+(def-loop (maximize maximizing) (l exp)
+ (accumulate l exp 'nil '(setq INTO (if INTO (max INTO VAL) VAL))))
+(def-loop (minimize minimizing) (l exp)
+ (accumulate l exp 'nil '(setq INTO (if INTO (min INTO VAL) VAL))))
+
+(defun accumulate (l val init form)
+ (let ((into '_acc))
+ (when (parse-loop-key l "INTO")
+ (setq into (pop (loops-exps l))))
+ (when (null (loops-result l))
+ (setf (loops-result l) into))
+ (add-var l into init)
+ (add-body l (sublis `((INTO . ,into) (VAL . ,val)) form))))
+
+;;;; 26.9. Variable Initializations
+
+(def-loop with (l var)
+ (let ((vars nil) (vals nil))
+ (push var (loops-exps l))
+ (loop
+ (push (parse-var l) vars)
+ (push (if (parse-loop-key l "=") (pop (loops-exps l)) '|\#f|) vals)
+ (unless (parse-loop-key l "AND") (RETURN)))
+ (cond ((= (length vars) 1)
+ (add-var l (first/ vars) (first/ vals)))
+ (t (add-var l `(:args , at vars) `(values , at vals))))))
+
+(defun parse-var (l &optional given-var)
+ "Parse and return var [type-spec]" ; See CLtL2 p. 743
+ (let ((var (or given-var
+ (if (symbolp (first/ (loops-exps l))) (pop (loops-exps l))))))
+ (if (or (parse-loop-key l "OF-TYPE")
+ (every #'numeric-type? (mklist (first (loops-exps l)))))
+ `(|::| ,var ,(cvt-type (pop (loops-exps l))))
+ var)))
+
+(defun numeric-type? (x)
+ (member (strip x) '(fixnum float t nil)))
+
+;;;; 26.10 Conditional Execution
+
+;;; This is a little tricky. We keep a stack of conditionals in each
+;;; loop structure, and make sure that add-body puts code into these
+;;; when appropriate.
+
+(defun add-body (l exp)
+ (if (loops-conditionals l)
+ (let ((target (first (loops-conditionals l))))
+ ;; Target is of form (if ... (progn ...)),
+ ;; or (if ... (progn ...) (progn ...)) within an ELSE.
+ ;; So we NCONC onto the last (progn ...)
+ (nconc1 (last1 target) exp))
+ (push exp (loops-body l))))
+
+(def-loop (when if unless) (l test key)
+ ;; WHEN expr clauses [ELSE clauses] [END]
+ ;; clauses -> clause {AND clause}*
+ (let ((target (list 'if
+ (if (loop=? key "UNLESS") `(not ,test) test)
+ (list 'progn))))
+ (add-body l target)
+ (push target (loops-conditionals l))
+ (parse-clauses l)
+ (when (parse-loop-key l "ELSE")
+ (setf (first (loops-conditionals l))
+ (nconc1 (first (loops-conditionals l)) (list 'progn)))
+ (parse-clauses l))
+ (pop (loops-conditionals l))
+ (parse-loop-key l "END")))
+
+(defun parse-clauses (l)
+ ;; Conditional clauses are either:
+ ;; collect/append/sum/count/minimize/maximize do/return when/unless/else
+ ;; But we don't make that restriction; we parse any clause.
+ (parse-clause l)
+ (when (parse-loop-key l "AND") (parse-clauses l)))
+
+(defun maybe-set-it (test exps)
+ "Return value, but if the variable IT appears in exps,
+ then return code that sets IT to value."
+ (if (find-anywhere 'it exps)
+ `(setq it ,test)
+ test))
+
+;;;; 26.11 Unconditional Execution
+
+(def-loop (do doing) (l exp)
+ (add-body l exp)
+ (loop (if (symbolp (first/ (loops-exps l))) (RETURN))
+ (add-body l (pop (loops-exps l)))))
+
+(def-loop return (l exp)
+ (add-body l `(return ,exp)))
+
+;;;; 26.12 Miscellaneous Features
+
+(def-loop initially (l exp)
+ (push exp (loops-prologue l))
+ (loop (if (symbolp (first/ (loops-exps l))) (RETURN))
+ (push (pop (loops-exps l)) (loops-prologue l))))
+
+(def-loop finally (l exp)
+ (push exp (loops-epilogue l))
+ (loop (if (symbolp (first/ (loops-exps l))) (RETURN))
+ (push (pop (loops-exps l)) (loops-epilogue l))))
+
+(def-loop named (l exp) (setf (loops-name l) exp))
+
+
+
+
+
+
+
Added: trunk/ltd/code/ltd-table.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/ltd-table.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,891 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: ltd-table.lisp; Date: /95
+(in-package :cl-user)
+
+;;;; Functions called from the (ltd-fn ...) table in tables.lisp
+
+
+;;;; CLtL2 CH 2: DATA TYPES
+
+(defun cvt-type-exp (exp)
+ ;; Convert a CL type specification (with the quote!) to Dylan.
+ (if (starts-with (strip exp) 'quote)
+ (cvt-type (second/ exp))
+ (cvt-exp exp)))
+
+(defun cvt-type (spec)
+ ;; Convert a CL type specification (without the quote!) to Dylan.
+ ;; If the spec is a name that is known from a cvt-type declaration,
+ ;; then look it up. If it is an unknown name, just wrap <> around
+ ;; it. If the spec is an (or ...), do each branch. For example,
+ ;; (or standard-class my-class) converts to (type-union <class> <my-class>).
+ (cond ((null spec) nil)
+ ((starts-with spec 'or)
+ `(type-union ,@(mapcar #'cvt-type (args spec))))
+ ((starts-with spec 'integer)
+ `(limited <integer>
+ ;; Or is it :from and :to ??
+ ,@(when (second/ spec) `(:min ,(second/ spec)))
+ ,@(when (third spec) `(:max ,(third spec)))))
+ ((starts-with spec 'member)
+ `(one-of ,@(mapcar #'kwote (rest/ spec))))
+ ((not (symbolp spec))
+ (cvt-erroneous spec spec "Can't convert type specification."))
+ ((get-cvt-type spec))
+ ((starts-with spec #\$) spec)
+ (t (mksymbol '< spec '>))))
+
+;;;; CLtL2 CH 4: TYPE SPECIFIERS
+
+(defun cvt-deftype (exp)
+ ;; Converts parameterless types only
+ (safe-destructuring-bind (name arglist body1 . body) (args exp)
+ (if (and (false? arglist) (starts-with 'quote (strip body1)) (false? body))
+ `(define-constant ,(cvt-type name)
+ ,(cvt-type-exp (second/ (strip body1))))
+ (cvt-erroneous exp '|\#f| "Can't handle complex deftypes."))))
+
+;;;; CLtL2 CH 5: PROGRAM STRUCTURE
+
+(defun cvt-defun (exp)
+ "Convert a defun or basic defmethod into a define-method."
+ `(,(get-option :defun-as) ,(second/ exp)
+ ,@(cvt-parms-and-body (nthcdr 2 exp) (second/ exp))))
+
+(defun cvt-lambda (exp &optional)
+ `(method ,@(cvt-parms-and-body (rest/ exp))))
+
+(defun cvt-parms-and-body (parms-and-body &optional name)
+ (safe-destructuring-bind (parms . body) parms-and-body
+ (let* ((declarations (extract-just-declarations body))
+ (vals (extract-values-declaration declarations)))
+ `(,(cvt-parms parms :declarations declarations)
+ ,@(ifd vals (list vals))
+ ,@(cvt-body body :name name)))))
+
+(defun cvt-parms (lambda-list &key body
+ (declarations (extract-just-declarations body)))
+ ;; Convert &*** words, handle specializers and defaults, add in declarations
+ ;; Return &aux bindings as second argument.
+ (when (eq (strip lambda-list) '|()|) (setq lambda-list '()))
+ (let ((key? nil) ; have we seen a &key (or &optional) yet?
+ (aux? nil) ; have we seen an &aux yet?
+ (auxs nil))
+ (labels ; arg is one of var, (var val), ((key var) val), (var type)
+ ((key (arg) (cond ((atom arg) nil)
+ ((atom (first/ arg)) nil)
+ (t (first/ (first/ arg)))))
+ (var (arg) (cond ((atom arg) arg)
+ ((atom (first/ arg)) (first/ arg))
+ (t (second/ (first/ arg)))))
+ (val (arg) (if (and (consp arg) key?) (cvt-exp (second/ arg)) nil))
+ (var-and-typ (arg) (if (and (not key?) (consp arg))
+ `(|::| ,(var arg) ,(cvt-type (second/ arg)))
+ (add-type-declaration (var arg) declarations)))
+ (var-and-typ-and-val (arg) (if (val arg)
+ `(= ,(var-and-typ arg) ,(val arg))
+ (var-and-typ arg)))
+ (cvt-arg (arg)
+ (cond (aux? (push (list (var arg) (val arg)) auxs) nil)
+ ((member arg '(&body &whole &environment))
+ (cvt-erroneous lambda-list arg "Can't handle macros."))
+ ((eq arg '&aux) (setq aux? t) nil)
+ ((eq arg '&optional) (setq key? t) '|\#key|)
+ ((eq arg '&rest) ' |\#rest|)
+ ((eq arg '&key) (if key? NIL (progn (setq key? t) '|\#key|)))
+ ((eq arg '&allow-other-keys) '|\#all-keys|)
+ ((key arg) `(:args-bare ,(key arg) ,(var-and-typ-and-val arg)))
+ (t (var-and-typ-and-val arg))))
+ (cvt-args (args)
+ (cond ((atom args) args)
+ (t (let* ((one (cvt-arg (first/ args)))
+ (two (cvt-args (rest/ args))))
+ (if one (cons one two) two))))))
+ (values `(:args ,@(cvt-args lambda-list))
+ (nreverse auxs)))))
+
+;;;; CLtL2 CH 6: PREDICATES
+
+(defun cvt-to-binary (exp)
+ "Convert (+ a b c d) to (+ (+ (+ a b) c) d)."
+ (if (not (call? exp))
+ (if (get-option :only-binary-arithmetic-ops)
+ (second/ exp) ; E.g. #'+ => +
+ (let ((id (case (second/ exp) ((+ -) 0) ((* /) 1))))
+ `(method (:args |\#rest| args)
+ (reduce ,id (second/ op) args))))
+ (let ((args (cvt-exps (args exp))))
+ (case (length args)
+ (0 (ecase (op exp)
+ ((+) 0)
+ ((*) 1)
+ ((- /) (cvt-erroneous exp 0 "Missing arguments to ~A."
+ (op exp)))
+ ((and &) '|\#t|)
+ ((or \|) '|\#f|)))
+ (1 (case (op exp)
+ ((-) (if (numberp (first/ args)) (eval exp) exp))
+ ((/) `(/ 1 ,(first args)))
+ (t (first/ args))))
+ (2 (cons (op exp) args))
+ (otherwise
+ (let ((result (list (op exp) (first/ args) (second/ args))))
+ (dolist (arg (nthcdr 2 args))
+ (setf result (list (op exp) result arg)))
+ result))))))
+
+;;;; CLtL2 CH 7: CONTROL STRUCTURE
+
+(defun cvt-fn (exp)
+ "Convert a CL expression, interpreted as a function, to Dylan."
+ ;; If the exp is of the form 'fn or #'fn, use the cvt-fn tables.
+ ;; Otherwise, just convert as a regular expression.
+ (cond ((and (or (starts-with exp 'function) (starts-with exp 'quote))
+ (consp exp) (length=1 (args exp)))
+ (let ((fn (second/ exp)))
+ (cond ((starts-with fn 'setf) (mksymbol (second/ fn) '-setter))
+ ((starts-with fn 'lambda) (cvt-lambda fn))
+ ((not (symbolp fn)) (cvt-exp fn))
+ ((get-cvt-fn fn) (funcall (get-cvt-fn fn) exp))
+ (t fn))))
+ (t (cvt-exp exp))))
+
+(defun cvt-setf (exp)
+ (maybe-begin (loop for (var val) on (args exp) by 'cddr
+ collect `(:= ,(cvt-exp var) ,(cvt-exp val)))))
+
+(defun binding-var (binding) (if (consp binding) (first/ binding) binding))
+(defun binding-val (binding) (if (consp binding) (second/ binding) '|\#f|))
+
+(defun cvt-let (exp)
+ (safe-destructuring-bind (bindings . body) (args exp)
+ (when (eq bindings '|()|) (setq bindings '()))
+ (let ((declarations (extract-just-declarations body)))
+ (if (let-can-use-serial-binding? bindings)
+ (cvt-let* exp)
+ `(begin
+ (let (:list ,@(mapcar
+ #'(lambda (b)
+ (add-type-declaration
+ (binding-var b) declarations))
+ bindings))
+ (values ,@(mapcar #'(lambda (b) (cvt-exp (binding-val b)))
+ bindings))
+ ,@(cvt-body body)))))))
+
+(defun cvt-compiler-let (exp)
+ (cvt-erroneous exp (cvt-let exp) "COMPILER-LET converted to LET"))
+
+(defun cvt-let* (exp)
+ "Convert let* to nested lets."
+ (safe-destructuring-bind (vars . body) (rest/ exp)
+ (move-comment
+ vars
+ (let ((code (cvt-body body))
+ (declarations (extract-just-declarations body)))
+ (when (eq vars '|()|) (setq vars '()))
+ (if (null vars)
+ (maybe-begin code)
+ `(begin
+ ,(dolist (binding (reverse vars) (first/ code))
+ (move-comment
+ binding
+ (let* ((var (binding-var binding))
+ (val (cvt-exp (binding-val binding)))
+ (special? (bracketed-with (string var) #\*)))
+ (setf code
+ (if special?
+ `((fluid-bind
+ (= ,(add-type-declaration var declarations)
+ ,val) , at code))
+ `((let ,(add-type-declaration var declarations)
+ ,val , at code)))))))))))))
+
+
+(defun let-can-use-serial-binding? (bindings)
+ ;; If the code is using LET (i.e., parallel binding) and none of the bindings
+ ;; depend on the result of a previous binding, then we can convert it to use
+ ;; serial binding. This makes the resulting Dylan code look a lot nicer.
+ ;; This suggests that Dick Waters is right in using let* for the default.
+ (let ((vars-so-far nil))
+ (loop for binding in bindings
+ as var = (binding-var binding)
+ as val = (binding-val binding)
+ do (if (some #'(lambda (v) (find-anywhere v val))
+ vars-so-far)
+ (RETURN-FROM let-can-use-serial-binding? nil)
+ (push var vars-so-far))))
+ t)
+
+(defun cvt-flet (exp)
+ (safe-destructuring-bind (bindings . body) (args exp)
+ ;; Convert (f (args) body) to (f (lambda (args) body)); then use let
+ (flet ((fix-fn (b) `(,(binding-var b) (lambda ,@(rest/ b)))))
+ (cvt-exp `(let* ,(mapcar #'fix-fn bindings) , at body)))))
+
+(defun cvt-labels (exp)
+ (safe-destructuring-bind (bindings . body) (args exp)
+ `(local (:list-bare
+ ,@(mapcar #'(lambda (b)
+ (move-comment
+ b `(:local-method ,(first/ b)
+ ,@(cvt-parms-and-body (rest/ b) (first/ b)))))
+ (strip bindings)))
+ ,@(cvt-body body))))
+
+(defun cvt-symbol-macrolet (exp)
+ ;; This is important, because with-slots macroexpands into symbol-macrolet.
+ ;; Unfortunately, symbol-macrolet is a special form, not a macro, so we have
+ ;; to expand it ourselves. We do a half-way job ??, converting ALL symbols,
+ ;; even ones that are not in an evaluation context. So you lose on things
+ ;; like (symbol-macrolet ((x 1)) (list 'x (let ((x 2)) x))), but do fine on
+ ;; e.g. (symbol-macrolet ((x (slot-value y 'x))) (setf x (* x 2)))
+ (safe-destructuring-bind (bindings . body) (args exp)
+ (maybe-begin
+ (cvt-exps (nsublis (mapcar #'(lambda (b) (cons (first/ b) (second/ b)))
+ bindings)
+ body)))))
+
+(defun cvt-if (exp)
+ (destructuring-bind (pred conseq &optional (else nil else?)) (args exp)
+ (let ((then (cvt-exp conseq)))
+ `(if ,(cvt-exp pred)
+ ,@(if (starts-with then 'begin) (args then) (list then))
+ ,@(cvt-else else else?)))))
+
+(defun cvt-else (else else?)
+ ;; ELSE is a LISP expression. Return a list of (:else[if] ...) clauses
+ (cond ((null else?) nil)
+ ((starts-with else 'if)
+ (destructuring-bind (p then &optional (else2 nil else2?)) (args else)
+ `((:elseif ,(cvt-exp p) ,(cvt-exp then))
+ ,@(cvt-else else2 else2?))))
+ (t (let ((dylan-else (cvt-exp else)))
+ (if (starts-with dylan-else 'begin)
+ `((:else ,@(args dylan-else)))
+ `((:else ,dylan-else)))))))
+
+(defun cvt-cond (exp)
+ ;; Convert cond to either IF or CASE. Worry about (cond ((test))).
+ (cond ((null (args exp)) '|\#f|)
+ ((some #'length=1 (mapcar #'strip (butlast (args exp)))) ; E.g. ((test))
+ `(begin (let _that |\#f|
+ ,(cvt-cond `(cond
+ ,@(mapcar
+ #'(lambda (c)
+ (if (length=1 (strip c))
+ `((setq _that ,(first/ c)) _that)
+ c))
+ (args exp)))))))
+ ((eq (get-option :cond-as) 'if)
+ `(if ,(cvt-exp (first/ (first/ (args exp))))
+ ,@(cvt-exps (rest/ (first/ (args exp))))
+ ,@(mapcar #'(lambda (clause)
+ (move-comment
+ clause
+ `(:elseif ,@(cvt-exps clause))))
+ (butlast (rest/ (args exp))))
+ ,(let ((final (last1 (rest/ (args exp)))))
+ (move-comment
+ final
+ (cond ((length=1 final) `(:else ,(cvt-exp (first/ final))))
+ ((eq t (first/ final)) `(:else ,@(cvt-exps (rest/ final))))
+ (t `(:elseif ,@(cvt-exps final))))))))
+
+ (t `(case ,@(mapcar
+ #'(lambda (clause)
+ `(:branch ,@(cvt-exps clause)))
+ (args exp))))))
+
+(defmacro must-be-call (result)
+ `(if (call? exp) ,result (second/ exp)))
+
+(defun kwote (x) (list 'quote x))
+
+(defun cvt-case (exp)
+ (cvt-ecase
+ (if (member (first/ (first/ (last exp))) '(t otherwise))
+ exp
+ (append exp '((otherwise nil))))))
+
+(defun cvt-ecase (exp)
+ (must-be-call
+ (safe-destructuring-bind (keyform . clauses) (args exp)
+ `(select ,keyform ,@(mapcar 'cvt-case-clause clauses)))))
+
+(defun cvt-case-clause (clause)
+ `(:branch ,(cond
+ ((member (move-comment clause (first/ clause))
+ '(otherwise t))
+ 'otherwise)
+ ((atom (first/ clause))
+ (kwote (first/ clause)))
+ (t (cons :list (mapcar #'kwote (first/ clause)))))
+ ,@(cvt-body (rest/ clause))))
+
+(defun cvt-typecase (exp)
+ (must-be-call
+ (destructuring-bind (x . clauses) (args exp)
+ `(select (:for-clause ,(cvt-exp x) by instance?)
+ ,@(mapcar #'(lambda (c)
+ (move-comment
+ c `(:branch ,(cvt-exp (first/ c))
+ ,@(cvt-exps (rest/ c)))))
+ clauses)))))
+
+(defun cvt-return-from (exp)
+ (let ((result (cvt-exp (third exp))))
+ `(,(mksymbol 'return-from- (second/ exp))
+ ,@(if (starts-with result 'values) (args result) (list result)))))
+
+(defun handle-returns (body &optional name)
+ ;; Wrap a BLOCK around body if it uses a return or return-from-name.
+ ;; Returns a list of forms
+ (let ((return-from-name (mksymbol 'return-from- name)))
+ (if (or (find-return return-from-name body 'return))
+ `((block ,(if name return-from-name 'return) , at body))
+ body)))
+
+(defun handle-returns1 (exp &optional name)
+ ;; Like handle-returns, but for a single expression, not a list of them
+ (first/ (handle-returns (list exp) name)))
+
+(defun handle-return-froms (body name)
+ ;; Wrap a BLOCK around body if it uses a (return-from name)
+ ;; Returns a list of forms
+ (let ((return-from-name (mksymbol 'return-from- name)))
+ (if (find-return return-from-name body)
+ `((block ,(if name return-from-name 'return) , at body))
+ body)))
+
+(defun find-return (name body &optional name2)
+ (setq body (strip body))
+ (flet ((match (x) (or (eq x name) (and name2 (eq x name2)))))
+ (cond ((atom body) nil)
+ ((match (first/ body)) t)
+ ((and (starts-with body 'block) (match (second/ body)))
+ nil)
+ (t (or (find-return name (first/ body) name2)
+ (find-return name (rest/ body) name2))))))
+
+(defun cvt-do (exp)
+ ;; Need to fix this for do*
+ (safe-destructuring-bind (vars endtest-and-values . body) (args exp)
+ (setq vars (if (eq vars '|()|) '() (mapcar #'mklist vars)))
+ (if (eq endtest-and-values '|()|) (setf endtest-and-values '()))
+ (let* ((endtest (cvt-exp (move-comment endtest-and-values
+ (first/ endtest-and-values))))
+ (values (cvt-exps (rest/ endtest-and-values)))
+ (bindings (mapcar #'(lambda (binding)
+ (move-comment binding (first/ binding))
+ (let* ((var (pop binding))
+ (init (pop binding))
+ (then (if binding (pop binding) init)))
+ `(:for-clause ,var = ,init then ,then)))
+ vars)))
+ (handle-returns1
+ `(for (:list-bare , at bindings
+ ,@(when endtest-and-values `((:for-clause :until ,endtest))))
+ ,@(cvt-body body)
+ ,@(when values
+ (if (= (length values) 1)
+ `((:finally , at values))
+ `((:finally (values , at values))))))))))
+
+(defun cvt-dolist (exp)
+ (destructuring-bind ((name list &optional result) . body) (args exp)
+ (handle-returns1 `(for (:for-clause ,name in ,(cvt-exp list))
+ ,@(cvt-body body)
+ ,@(ifd result `((:finally ,(cvt-exp result))))))))
+
+(defun cvt-dotimes (exp)
+ (destructuring-bind ((name count &optional result) . body) (args exp)
+ (handle-returns1 `(for (:for-clause ,name from 0 below ,(cvt-exp count))
+ ,@(cvt-body body)
+ ,@(ifd result `((:finally ,(cvt-exp result))))))))
+
+(defun cvt-tagbody (exp)
+ ;; Make these a set of mutually recursive local methods.
+ ;; This way (GO label) translates as (label).
+ ;; I.e. (tagbody ... A *** B ---) translates as
+ ;; (labels ((A () *** (B)) (B () ---)) ... (A))
+ (if (notany #'symbolp (args exp))
+ (maybe-begin (cvt-exps (args exp)))
+ (let ((args (args exp)))
+ (flet ((chunk () ; eat a chunk up to next label
+ (let ((p (position-if #'symbolp args)))
+ (if p
+ (prog1
+ (nconc (subseq args 0 p)
+ (list (list (mksymbol 'go- (elt args p)))))
+ (setf args (subseq args p)))
+ (prog1 args (setf args nil))))))
+ (let ((fns nil)
+ (body (chunk)))
+ (loop while args
+ do (push `(,(mksymbol 'go- (pop args)) () ,@(chunk)) fns))
+ (cvt-exp `(labels ,fns , at body)))))))
+
+(defun cvt-multiple-value-call (exp)
+ (cvt-exp `(apply ,(first/ (args exp))
+ (nconc ,@(loop for arg in (rest/ (args exp))
+ collect `(multiple-value-list ,arg))))))
+
+(defun cvt-multiple-value-bind (exp)
+ (safe-destructuring-bind (vars form . body) (args exp)
+ `(let ,(cvt-parms vars :body body) ,(cvt-exp form) ,@(cvt-body body))))
+
+(defun cvt-multiple-value-setq (exp)
+ ;; I can't believe "(a, b, c) := values(1, 2, 3)" isn't in the language!
+ (let* ((temps (loop for var in (second/ exp) collect (mksymbol '_ var)))
+ (sets (loop for var in (second/ exp)
+ for temp in temps
+ collect `(:= ,var ,temp))))
+ `(begin (let (:args |\#rest| , at temps) ,(cvt-exp (third exp))
+ , at sets))))
+
+(defun cvt-tag (tag)
+ (cond ((starts-with tag 'quote) (second/ tag))
+ ((constantp tag) tag)
+ (t (cvt-erroneous tag (cvt-exp tag)
+ "Can't convert a run-time catch tag."))))
+
+;;;; CLtL2 CH 8: MACROS
+
+(defun cvt-macro (exp)
+ ;; Macroexpand and convert
+ ;; We use this for lots of things: rotatef, psetf, ...
+ ;; If there is no macro,
+ (let ((expansion (safe-macroexpand exp)))
+ (cond ((eq expansion exp) (mapcar #'cvt-exp (strip exp)))
+ (t (cvt-exp expansion)))))
+
+(defun safe-macroexpand (exp) (macroexpand (to-normal-lisp exp)))
+
+(defun to-normal-lisp (exp)
+ "Convert back to normal lisp: eliminate comments and |()|."
+ (cond ((comment? exp) (to-normal-lisp (com-code exp)))
+ ((eq exp '|()|) '())
+ ((consp exp) (recons (to-normal-lisp (car exp))
+ (to-normal-lisp (cdr exp))
+ exp))
+ ((stringp exp) exp)
+ ((vectorp exp) (coerce (map-into exp #'to-normal-lisp exp) 'vector))
+ (t exp)))
+
+(defun recons (x y x-y)
+ "Cons x and y, but reuse x-y if it would be the same."
+ (if (and (eql x (car x-y)) (eql y (cdr x-y)))
+ x-y
+ (cons x y)))
+
+;;;; CLtL2 CH 11: PACKAGES
+
+(defun cvt-in-package (exp)
+ (when (get-option :obey-in-package)
+ (eval exp)
+ (format nil "~(~A~)" exp)))
+
+(defun cvt-export (exp)
+ (must-be-call
+ (safe-destructuring-bind (symbols &opt package) (rest/ exp)
+ (if (and (constantp (strip symbols)) (constantp package))
+ `(define-module ,(or (eval package) (intern (package-name *package*)))
+ (:clause export ,@(mklist (eval symbols))))
+ (cvt-erroneous exp exp "Can't handle dynamic EXPORT")))))
+
+(defun cvt-defpackage (exp)
+ (must-be-call
+ (safe-destructuring-bind (name . options) (rest/ exp)
+ `(define-module ,name
+ ,@(loop for option in options
+ when (starts-with option ':use)
+ collect `(:clause use ,@(rest/ option))
+ when (starts-with option ':export)
+ collect `(:clause export ,@(rest/ option)))))))
+
+;;;; CLtL2 CH 12: NUMBERS
+
+(defun cvt-to-binary-compares (exp)
+ "Convert (< a b c d) to (& (& (< a b) (< b c)) (< c d))."
+ (if (not (call? exp))
+ (if (get-option :only-binary-arithmetic-ops)
+ (second/ exp) ; I.e., #'< => <
+ `(cl-reduce-compares ,(second/ exp)))
+ (let ((op (op exp))
+ (args (cvt-exps (args exp))))
+ (case (length args)
+ ((0 1) '|\#t|)
+ ((2) (cons op args))
+ (otherwise
+ ;; Need to bind non-atomic elements of args
+ (let ((bindings nil))
+ (flet ((maybe-bind (x) (cond ((consp (strip x))
+ (let ((var (gensym)))
+ (push (list var x) bindings)
+ var))
+ (t x))))
+ (let* ((args `(,(first/ args)
+ ,@(mapcar #'maybe-bind (butlast (rest/ args)))
+ ,(first/ (last args))))
+ (result (list (op exp) (first/ args) (second/ args))))
+ (pop args) ; Get rid of first/ arg
+ (loop while (length>1 args) do
+ (setf result `(& ,result ,(list (op exp) (first/ args)
+ (second/ args))))
+ (pop args))
+ (wrap-bindings bindings result)))))))))
+
+(defun wrap-bindings (bindings code)
+ ;; Wrap code with LETs for the (var val) pairs in bindings.
+ (loop for (var val) in bindings
+ do (setf code `(let ,var ,val ,code)))
+ (if bindings
+ `(begin ,code)
+ code))
+
+(defun cvt-division (exp)
+ ;; Translate, e.g., (floor m &optional n) to (floor/ m n) or (floor m)
+ (case (length (args exp))
+ (2 `(,(mksymbol (op exp) '/) ,@(cvt-exps (args exp))))
+ (t `(,(op exp) ,@(cvt-exps (args exp))))))
+
+;;;; CLtL2 CH 14: SEQUENCES
+
+(defun cvt-reduce (exp)
+ (destructuring-bind (f s . keys)
+ (args exp)
+ (let ((function (mkpred keys (cvt-fn f)))
+ (sequence (mkseq (cvt-exp s) keys)))
+ (if (member :initial-value keys)
+ `(reduce ,function ,(getf keys :initial-value) ,sequence)
+ `(reduce1 ,function ,sequence)))))
+
+(defun cvt-if-not (exp)
+ ;; Invert the test in a sequence-function-IF-NOT
+ (if (call? exp)
+ (let ((name (string (first/ exp)))
+ (pos (case (op exp)
+ ((subst-if-not nsubst-if-not substitutue-if-not
+ nsubstitute-if-not)
+ 2)
+ (otherwise 1))))
+ (setf exp (copy-list exp))
+ (setf (elt exp pos) `(complement ,(elt exp pos)))
+ (setf (first exp) (mksymbol (subseq name 0 (- (length name) 7))))
+ (cvt-exp exp))
+ `(method (:args x y |\#rest| r)
+ (apply ,@(cvt-if-not `(,(second/ exp) x y)) r))))
+
+(defun cvt-keys (keys)
+ ;; Leave the key/value pair alone, except
+ ;; replace :test-not f with :test (complement f)
+ (loop for sublist on keys by 'cddr
+ do (when (and (eq (first/ sublist) ':test-not) (length>1 sublist))
+ (setf (first sublist) ':test)
+ (setf (second sublist) `(complement ,(second/ sublist)))))
+ keys)
+
+(defun cl? (exp dylan &optional bad-keys (cl-fn-name (mksymbol 'cl- (op dylan))))
+ ;; Return DYLAN unless:
+ ;; (1) If exp is of the form #'f, then use cl-fn-name
+ ;; (2) If one of the bad-keys is used, use cl-fn-name applied to args
+ (cond ((not (call? exp)) cl-fn-name)
+ ((or (dotted? exp) (intersection bad-keys (args exp)))
+ (cons cl-fn-name (cvt-exps (args exp))))
+ (t dylan)))
+
+(defun mktest (keys &optional pred binary?)
+ ;; Return `:test test' or (), given a list of Lisp keyword/value pairs,
+ ;; which may contain :test and :key (:test-not is already converted).
+ ;; If binary? is true, apply TEST to key of two args
+ ;; If PRED is given, there can be no :test, but maybe a key.
+ ;; First, handle case where KEYS is not a list
+ (when (listp keys)
+ (let* ((test (or pred (getf keys :test '==)))
+ (key (getf keys :key))
+ (code
+ (cvt-exp
+ (cond ((and binary? key)
+ `(lambda (x y)
+ (funcall ,test (funcall ,key x) (funcall ,key y))))
+ (binary? test)
+ (key `(lambda (x y) (funcall ,test x (funcall ,key y))))
+ (t test)))))
+ (if (eq code '==) nil `(:test ,code)))))
+
+(defun mkpred (keys pred)
+ ;; Make a binary comparison predicate, possibly using :key argument from keys
+ ;; pred is already converted to Dylan; keys are not.
+ (when (listp keys)
+ (let ((key (getf keys :key)))
+ (if key `(compose ,pred ,(cvt-fn key)) pred))))
+
+(defun mkseq (sequence keys &optional (start :start) (end :end))
+ ;; Take a sequence (in Dylan) and a list of key/values (in Lisp)
+ ;; and extract :start and :end if provided.
+ (when (listp keys)
+ (let ((starts (if (getf keys start) `(:start ,(cvt-exp (getf keys start)))))
+ (ends (if (getf keys end) `(:end ,(cvt-exp (getf keys end))))))
+ (if (or starts ends)
+ `(copy-subsequence ,sequence , at starts , at ends)
+ sequence))))
+
+(defun mkcount (keys)
+ ;; If there is a :count keyword, get it.
+ (when (listp keys)
+ (if (getf keys :count) `(:count ,(cvt-exp (getf keys :count))))))
+
+(defun mkeof (eofs)
+ ;; Eofs is of the form (&optional eof-errorp eof-value recursive-p)
+ ;; If eof-errorp is non-nil, we return nothing; otherwise
+ ;; we extract eof-value
+ (if (and (consp eofs) (not (null (first/ eofs))))
+ `(:on-end-of-stream ,(cvt-exp (second/ eofs)))
+ nil))
+
+;;;; CLtL2 CH 16: HASH TABLES
+
+(defun cvt-make-hash-table (exp)
+ (destructuring-bind (&key test size rehash-size rehash-threshold) (args exp)
+ (declare (ignore rehash-size rehash-threshold))
+ (let ((type (cond ((member test '('equal '#'equal) :test #'equal) '<equal-table>)
+ ((member test '('eq 'eql '#'eq '#'eql) :test #'equal) '<object-table>)
+ (t '<table>))))
+ `(make ,type ,@(ifd test `(:test ,(cvt-fn test)))
+ ,@(ifd size `(:size ,(cvt-exp size)))))))
+
+;;;; CLtL2 CH 17: ARRAYS
+
+(defun cvt-make-array (exp)
+ (safe-destructuring-bind (dimensions . keys) (args exp)
+ (let* ((element-type (cvt-type-exp (getf keys :element-type)))
+ (type (cond ((or (integerp dimensions)
+ (starts-with dimensions 'length)
+ (and (starts-with dimensions 'quote)
+ (length=1 (second/ dimensions))))
+ (cond ((eq element-type '<character>)
+ '<string>)
+ ((getf keys :adjustable)
+ '<stretchy-vector>)
+ (t '<vector>)))
+ (t '<array>)))
+ (code `(make ,type
+ ,@(if (eql type '<array>)
+ `(:dimensions ,(cvt-exp dimensions))
+ `(:size ,(cvt-exp dimensions))))))
+ (when (getf keys :fill)
+ (setf code `(fill! ,code ,(cvt-exp (getf keys :fill)))))
+ (when (getf keys :fill-pointer)
+ (setf code `(begin (let _vector ,code
+ (:= (size _vector)
+ ,(cvt-exp (getf keys :fill-pointer))) _vector))))
+ code)))
+
+;;;; CLtL2 CH 19: STRUCTURES
+
+(defun cvt-defstruct (exp)
+ ;; See also cvt-defclass
+ (safe-destructuring-bind (name-and-options . slots) (args exp)
+ (let* ((name (first-atom (strip name-and-options)))
+ (options (if (listp (strip name-and-options))
+ (rest/ (strip name-and-options))))
+ (supers (mapcar #'cvt-type (rest/ (assoc/ :include options))))
+ (comment nil))
+ (when (eq slots '|()|)
+ (setq slots '()))
+ (when (stringp (first/ slots))
+ (setq comment (pop slots)))
+ (let ((code `(define-class ,(cvt-type name)
+ (:list ,@(or supers '(<object>)))
+ ,@(cvt-defstruct-slots slots name options))))
+ (if comment
+ (make-com :comment comment :code code)
+ code)))))
+
+
+(defun cvt-defstruct-slots (slots struct-name options)
+ ;; Converts a set of defstruct slot definitions to a set of Dylan slots
+ ;; See also cvt-defclass-slots
+ (let* ((option (assoc/ :conc-name options))
+ (conc-name (if (consp (strip option)) (second/ option)
+ (mksymbol struct-name '-))))
+ (flet ((convert-defstruct-slot
+ (slot)
+ (move-comment
+ slot
+ (let* ((name (if (listp slot) (first/ slot) slot))
+ (new-name (mksymbol conc-name name))
+ (exp new-name)
+ (type (if (listp slot) (getf (cddr slot) :type))))
+ (when type
+ (setf exp `(|::| ,exp ,(cvt-type type))))
+ (when (and (consp slot) (>= (length slot) 2))
+ (setf exp `(= ,exp ,(cvt-exp (second/ slot)))))
+ (push new-name *dotted-functions*)
+ `(:slot ,exp :init-keyword
+ ,(intern (symbol-name new-name) :keyword))))))
+ (mapcar #'convert-defstruct-slot (strip-nil slots)))))
+
+;;;; CLtL2 CH 22: INPUT/OUTPUT
+
+(defun cvt-format (exp)
+ (must-be-call
+ (destructuring-bind (stream string . args) (args exp)
+ (let ((str (cvt-format-string string)))
+ (cond ((and (stringp str) (eq (strip stream) 't))
+ `(format-out ,str ,@(cvt-exps args)))
+ ((stringp str)
+ `(,(op exp) ,(cvt-exp stream) ,str ,@(cvt-exps args)))
+ (t `(,str ,(cvt-exp stream) ,@(cvt-exps args))))))))
+
+
+(defun cvt-format-string (control)
+ ;; Handle ~X => %X; ~% => newline; % => %%
+ ;; Notice that #\newline and #\tab are printed as \n and \t (by dpp-string).
+ (if (not (stringp control))
+ (cvt-exp control)
+ (let* ((length (length control))
+ (i 0)
+ (unhandled nil)
+ (result (make-array length :element-type 'string-char
+ :adjustable t :fill-pointer 0)))
+ (flet ((emit (ch) (vector-push-extend ch result))
+ (consume () (if (< i length) (prog1 (aref control i) (incf i)))))
+ (loop for ch = (consume) while ch do
+ (case ch
+ (#\% (emit #\%) (emit #\%))
+ (#\~ (let ((ch2 (consume)))
+ (if (null ch2)
+ (emit #\~)
+ (case (char-upcase ch2)
+ ((#\D #\B #\O #\X #\C) (emit #\%) (emit ch2))
+ ((#\A) (emit #\%) (emit #\S))
+ ((#\S) (emit #\%) (emit #\=))
+ ((#\~) (emit #\~))
+ ((#\& #\%) (emit #\newline))
+ (otherwise (pushnew ch2 unhandled))))))
+ (otherwise (emit ch)))))
+ (cond ((null unhandled) result)
+ ((get-option :macroexpand-hard-format-strings)
+ (cvt-exp (macroexpand `(formatter ,control))))
+ (t (cvt-erroneous control result
+ "Unhandled format characters: ~{~~~C~^,~}"
+ (nreverse unhandled)))))))
+
+(defun extract-stream (keys &optional (default '*standard-output*))
+ "Return the STREAM arg from the list of Dylan key/vals, followed by the keys."
+ ;; I.e. (extract-stream '(:pretty t :stream s)) => (s :pretty t)
+ (cons (or (getf (mapcar #'strip keys) :stream) default)
+ (let ((n (position :stream keys :key #'strip)))
+ (if n
+ (append (subseq keys 0 n) (subseq keys (+ n 2)))
+ keys))))
+
+
+;;;; CLtL2 CH 23: FILE SYSTEM INTERFACE
+
+(defun cvt-with-open-file (exp)
+ (must-be-call
+ (destructuring-bind ((var file . options) . body) (args exp)
+ `(with-open-file (= ,(cvt-exp var) (:args ,(cvt-exp file)
+ ,@(cvt-exps options)))
+ ,@(cvt-body body)))))
+
+;;;; CLtL2 CH 28: COMMON LISP OBJECT SYSTEM
+
+(defun cvt-compute-applicable-methods (exp)
+ (converting-bind (f . arg*) (args exp)
+ `(begin (let (:list _a _b)
+ (apply sorted-applicable-methods ,f . ,arg*)
+ (concatenate _a _b)))))
+
+(defun cvt-defclass (exp)
+ (safe-destructuring-bind (name supers slots . options) (args exp)
+ (when (null/ supers)
+ (setf supers (ecase (op exp)
+ (defclass '(t))
+ (define-condition '(condition)))))
+ `(define-class ,(cvt-type name)
+ (:list ,@(mapcar #'cvt-type (or supers '(t))))
+ ,@(cvt-defclass-slots slots options))))
+
+(defun cvt-defclass-slots (slots options)
+ ;; Converts a set of CLOS slot definitions to a set of Dylan slot definitions
+ (let ((default-initargs (rest/ (assoc/ :default-initargs options))))
+ (flet ((convert-slot (slot)
+ (move-comment
+ slot
+ (if (symbolp slot)
+ slot
+ (destructuring-bind (name &key reader writer accessor
+ type allocation initarg documentation
+ (initform nil initform-p)
+ (initvalue nil initvalue-p))
+ slot
+ (let ((getter (or reader accessor
+ name)) ; norvig change to swm's code
+ (setter writer)
+ (default-initarg (getf default-initargs initarg)))
+ (when default-initarg
+ (setq initvalue default-initarg))
+ (when type
+ (setf getter `(|::| ,getter ,(cvt-type type))))
+ (when initform-p
+ (setf getter `(= ,getter ,(cvt-exp initform))))
+ (push getter *dotted-functions*)
+ (add-comment documentation
+ `(:slot ,getter ,@(and setter `(:setter ,setter))
+ ,@(and initarg `(:init-keyword ,initarg))
+ ,@(and initvalue-p `(:init-value ,initvalue))
+ ,@(and allocation `(:allocation ,allocation))))))))))
+ (mapcar #'convert-slot (strip-nil slots)))))
+
+(defun cvt-defgeneric (exp)
+ (safe-destructuring-bind (name parms . options) (args exp)
+ ;; Silently ignores options other than :documentation
+ (add-comment
+ (second/ (find :documentation options :key #'first-atom))
+ `(define-generic ,name ,(cvt-parms parms)))))
+
+(defun cvt-defmethod (exp)
+ "Just like cvt-defun, but handle make-instance, initialize-instance."
+ ;; Just give up on method qualifiers.
+ (safe-destructuring-bind (name parms . body) (args exp)
+ (cond ((typep parms '(and symbol (not null)))
+ (cvt-erroneous exp
+ (cvt-defmethod `(defmethod ,name ,@(rest/ body)))
+ "Defmethod qualifier ~A ignored." name))
+ ((eq name 'make-instance)
+ (cvt-defmethod `(defmethod make ,parms , at body)))
+ ((eq name 'initialize-instance)
+ (cvt-defmethod `(defmethod initialize ,parms , at body)))
+ (t (cvt-defun exp)))))
+
+(defun cvt-with-slots (exp)
+ ;; Just expand macro, except if the argument is atomic, avoid local var.
+ (if (atom (strip (third exp)))
+ (cvt-exp `(symbol-macrolet
+ ,(mapcar #'(lambda (v)
+ `(,v (slot-value ,(strip (third exp)) ',v)))
+ (strip (second/ exp)))
+ ,@(cdddr exp)))
+ (cvt-macro exp)))
+
+;;;; CLtL2 CH 29: CONDITIONS
+
+(defun cvt-condition-function (exp)
+ ;; Convert a function like error or signal. There are three cases for args:
+ ;; (1) condition-object &rest args
+ ;; (2) format-string &rest args
+ ;; (3) condition-class-name &rest args
+ ;; Dylan supports the first two. We don't always handle the third.
+ (if (not (call? exp))
+ (second/ exp) ; Close, but doesn't handle (3). ??
+ (let* ((arg1 (first/ (args exp)))
+ (class-name? (and (starts-with arg1 'quote)
+ (symbolp (second/ arg1))))
+ (arg1-val (cond ((stringp arg1) (cvt-format-string arg1))
+ (class-name? (cvt-type arg1))
+ (t (cvt-exp arg1)))))
+ `(,(op exp) ,arg1-val ,@(cvt-exps (rest/ (args exp)))))))
Added: trunk/ltd/code/ltd.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/ltd.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,251 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: convert.lisp; Date: 28-Aug-95
+(in-package :cl-user)
+
+;;;; LTD: CONVERT FROM COMMON LISP TO DYLAN - TOP-LEVEL FUNCTION
+
+(defun ltd-files (files &key (width 79) (output (make-pathname :type "dylan")))
+ "Convert a list of Common Lisp files to Dylan."
+ (let ((*print-right-margin* width)
+ (*package* *package*))
+ (dolist (file (expand-files files))
+ (with-open-file (out (merge-pathnames output file) :direction :output
+ :if-exists :supersede)
+ (with-open-file (in file :direction :input)
+ (format t "Converting ~A~%" file)
+ (restart-case
+ (loop until (eq *eof* (ltd-exp in out)))
+ (nil () :report (lambda (s) (format s "Skip file ~A" file)))))))
+ (report-unimplemented-functions)))
+
+(defun ltd-exp (in out)
+ "Read a Lisp expression from stream IN and write Dylan to stream OUT."
+ (restart-case
+ (let ((exp (ltd-read in)))
+ (unless (eq exp *eof*)
+ (dpp-exp (cvt-exp exp) :stream out)
+ (format out ";~%~%")
+ (clrhash *file-position-table*))
+ exp)
+ (nil () :report "Skip to the next expression in this file."
+ '|Input expression skipped due to translation error.|)))
+
+;;;; MACROS FOR DEFINING TRANSLATION TABLES
+
+;;; We support three tables, keyed on Lisp symbols, whose values are
+;;; the equivalents in Dylan (or a function to compute the equivalent).
+
+(defun get-cvt-constant (cl) (when (symbolp cl) (get cl 'cvt-constant)))
+(defun get-cvt-fn (cl) (when (symbolp cl) (get cl 'cvt-fn)))
+(defun get-cvt-type (cl) (when (symbolp cl) (get cl 'cvt-type)))
+
+(defmacro ltd-constant (cl dylan)
+ ;; Define a translation between a Lisp and Dylan constant
+ (assert (symbolp cl))
+ `(setf (get ',cl 'cvt-constant)
+ ,(if (symbolp dylan) `',dylan `#'(lambda () ,dylan))))
+
+(defmacro ltd-type (cl dylan)
+ ;; Define a translation from a Lisp to a Dylan type
+ (assert (symbolp cl))
+ `(setf (get ',cl 'cvt-type) ',dylan))
+
+(defmacro ltd-fn (cl dylan)
+ "Store, under the function symbol in Lisp, a function to convert to Dylan."
+ ;; The function will be passed EXP, the complete expression to be converted.
+ ;; This is either of the form (f x y z) or #'f
+ (if (symbolp cl) (setf cl `(,cl . args))) ; Coerce to canonical form
+ `(progn
+ (setf (get ',(op cl) 'cvt-fn)
+ #'(lambda (exp)
+ ,(cond
+ ((symbolp dylan)
+ `(if (call? exp)
+ (cons ',dylan (cvt-exps (args exp)))
+ ',dylan))
+ ((starts-with dylan 'function)
+ `(,(second/ dylan) exp))
+ ((starts-with dylan 'cl?)
+ `(encapsulate-let
+ (converting-bind ,(args cl) (args exp) ,dylan)))
+ (t `(cond
+ ((call? exp)
+ (encapsulate-let
+ (converting-bind ,(args cl) (args exp)
+ ,@(when (find-anywhere 'ignore (args cl))
+ '((declare (ignore ignore))))
+ ,dylan)))
+ ,@(if (or (dotted? cl) (find-anywhere '&opt cl))
+ `((t (cvt-erroneous ; ??? could do better
+ exp (second/ exp)
+ "Can't convert complex function ~A."
+ (second/ exp))))
+ `((t (let ((dylan-args '(:args ,@(args cl)))
+ (dylan-body (cvt-exp ',cl)))
+ (list 'method dylan-args dylan-body))))))))))
+ ',(first-atom cl)))
+
+(defmacro ltd-unimplemented-functions (&rest fns)
+ "These functions are not yet implemented."
+ `(map nil #'(lambda (fn)
+ (case (get-cvt-fn fn)
+ ((nil) (setf (get fn 'cvt-fn) 'not-yet-implemented))
+ ((not-yet-implemented))
+ (t (warn "~A is already implemented!" fn))))
+ ',fns))
+
+(defmacro ltd-unimplemented-types (&rest types)
+ "These types are not yet implemented."
+ `(map nil #'(lambda (type)
+ (setf (get type 'cvt-type)
+ (add-comment (format nil "Type ~A unimplemented" type)
+ '<object>)))
+ ',types))
+
+(defvar *unimplemented* (make-hash-table :test #'eq))
+
+(defun incf-unimplemented (fn) (incf (gethash fn *unimplemented* 0)))
+
+(defun not-yet-implemented (exp)
+ ;; Warn, then just convert each arg and make a function call
+ (let ((fn (if (call? exp) (op exp) (second/ exp))))
+ (incf-unimplemented fn)
+ (if (call? exp)
+ `(,(cvt-erroneous exp fn "Function ~A not yet implemented." fn)
+ ,@(cvt-exps (args exp)))
+ (cvt-erroneous exp fn "Function ~A not yet implemented." fn))))
+
+(defun report-unimplemented-functions ()
+ (let ((result nil))
+ (maphash #'(lambda (k v) (push (list v k) result))
+ *unimplemented*)
+ (format t "~%Counts of unimplmented functions:~%")
+ (loop for (n fn) in (sort result #'> :key #'first)
+ do (format t "~4D ~A~%" n fn))
+ (clrhash *unimplemented*)))
+
+;;;; CONVERTING BASIC EXPRESSIONS
+
+(defun cvt-exp (exp)
+ "Convert a CL expression to Dylan."
+ (cond ((and (symbolp exp) (not (keywordp exp))
+ (or (get-cvt-constant exp) (constantp exp)))
+ (cvt-constant exp))
+ ((comment? exp) (setf (com-code exp) (cvt-exp (com-code exp))) exp)
+ ((atom exp) exp)
+ ((get-cvt-fn (op exp))
+ (funcall (get-cvt-fn (op exp)) exp))
+ ((and (symbolp (op exp)) (macro-function (op exp)))
+ (cvt-macro exp))
+ (t `(,(cvt-fn `(function ,(op exp)))
+ ,@(cvt-exps (args exp))))))
+
+(defun cvt-exps (exps)
+ "Like (mapcar #'cvt-exp exps), but handles dotted lists."
+ (if (atom exps)
+ exps
+ (cons (cvt-exp (first exps)) (cvt-exps (rest/ exps)))))
+
+(defun cvt-constant (var)
+ "Convert a constant's name from CL to Dylan."
+ ;; Use the entries from the cvt-constant table.
+ ;; If it is of the form *xxx* or +xxx+, strip the ** or ++.
+ ;; Otherwise, just tack a $ at the beginning.
+ (let ((str (symbol-name var))
+ (con (get-cvt-constant var)))
+ (cond ((and con (symbolp con)) con)
+ ((and con (functionp con)) (funcall con))
+ ((starts-with str #\$) var)
+ ((bracketed-with str #\*)
+ (mksymbol '$ (subseq str 1 (- (length str)))))
+ ((bracketed-with str #\+)
+ (mksymbol '$ (subseq str 1 (- (length str)))))
+ (t (mksymbol '$ var)))))
+
+(defun extract-declarations (body)
+ "Return three values: doc string, list of (declare)s, body."
+ (let ((doc nil)
+ (declarations nil))
+ (loop (cond ((starts-with (first/ body) 'declare)
+ (push (pop body) declarations))
+ ((and (null doc) (length>1 body) (stringp (first/ body)))
+ (setf doc (pop body)))
+ (t (RETURN))))
+ (values doc (nreverse declarations) body)))
+
+(defun extract-just-declarations (body)
+ (multiple-value-bind (doc declares bod) (extract-declarations body)
+ (declare (ignore doc bod))
+ declares))
+
+(defun extract-values-declaration (declarations)
+ "Some programs use (declare (values type1 type2)). Get it if there."
+ (dolist (declaration declarations)
+ (dolist (decl (rest/ declaration))
+ (when (starts-with decl 'values)
+ (return-from extract-values-declaration
+ `(:return ,@(rest/ decl)))))))
+
+(defun cvt-body (body &key (name nil))
+ "Convert a body. Handle doc, declares, return-from. Returns a list of forms."
+ (labels ((strip-begin (exp)
+ (if (and (starts-with exp 'begin) (= (length (strip exp)) 2))
+ (strip-begin (second/ exp))
+ exp)))
+ (multiple-value-bind (doc decls body) (extract-declarations body)
+ (declare (ignore decls))
+ (let ((forms (handle-return-froms
+ (mapcar #'(lambda (exp) (strip-begin (cvt-exp exp)))
+ (or body '(|\#f|)))
+ name)))
+ (if doc
+ (cons (add-comment doc (first/ forms)) (rest/ forms))
+ forms)))))
+
+(defun encapsulate-let (exp)
+ ;; In Dylan, a LET can appear only at the top level of a body.
+ ;; So wrap a LET in a BEGIN, and strip the BEGIN from wihin cvt-body
+ (if (starts-with exp 'let)
+ `(begin ,exp)
+ exp))
+
+;;;; MISC
+
+(defun add-type-declaration (variable declarations)
+ (let ((decl (get-type-declaration variable declarations)))
+ (if decl `(|::| ,variable ,decl) variable)))
+
+(defun get-type-declaration (variable declarations)
+ "If there is a type declaration for variable, get it."
+ (dolist (declaration declarations)
+ (dolist (decl (rest/ declaration))
+ ;; Handle (type fixnum ... variable ...)
+ (when (and (starts-with decl 'type) (member variable (cddr decl)))
+ (RETURN-FROM get-type-declaration (cvt-type (second/ decl))))
+ ;; Handle (fixnum ... variable ...))
+ (when (and (consp decl) (get-cvt-type (first/ decl))
+ (member variable (rest/ decl)))
+ (RETURN-FROM get-type-declaration (cvt-type (first/ decl)))))))
+
+(defun cvt-erroneous (exp replacement &rest format-args)
+ "Can't convert exp; just return replacement, but print warnings."
+ (let ((*print-length* 3)
+ (*print-level* 2))
+ (safe-destructuring-bind (start . end)
+ (or (gethash exp *file-position-table*) '(? . ?))
+ (apply #'warn format-args)
+ (warn " at ~D to ~D in ~A.~%" start end exp))
+ (if (get-option :errors-inline)
+ (add-comment
+ (concatenate 'string "LTD: " (apply #'format nil format-args))
+ replacement)
+ replacement)))
+
+(defun false? (x)
+ ;; Is X a Lisp or Dylan expression for EMPTY LIST or FALSE?
+ (member (strip x) '(nil |\#f| |()|)))
+
+(defun call? (exp)
+ "Is this a function call, e.g. (f x), as opposed to #'f or 'f?"
+ (and (consp (strip exp))
+ (not (member (first/ (strip exp)) '(quote function)))))
Added: trunk/ltd/code/misc.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/misc.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,156 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: misc.lisp; Date: 8-Sep-95
+(in-package :cl-user)
+
+;;;; MISC. FUNCTIONS: UTILITY FUNCTIONS
+
+;;;; DYLAN-SPECIFIC UTILITY FUNCTIONS
+
+;;; The following functions with a / are like their slash-less counterparts,
+;;; except they work for arguments with comments and for |()|.
+
+(defun first/ (exp) (first (strip-nil exp)))
+(defun rest/ (exp) (rest (strip-nil exp)))
+(defun second/ (exp) (second (strip-nil exp)))
+(defun null/ (exp) (null (strip-nil exp)))
+(defun assoc/ (item a-list)
+ (find (strip item) (strip a-list)
+ :key #'(lambda (x) (first-atom (strip x)))))
+
+(defun strip-nil (exp)
+ "Strip comment, and convert |()| to ()."
+ (if (eq (strip exp) '|()|) '() (strip exp)))
+
+(defun strip (exp)
+ "Strip off the comment."
+ (if (comment? exp) (com-code exp) exp))
+
+(defmacro ifd (pred then &optional else)
+ ;; Dylan if: false for nil or #f
+ `(if (not (false? ,pred)) ,then ,else))
+
+(defmacro once (var &body body)
+ ;; Called once-only on Lisp Machines, return (Dylan) code built by body,
+ ;; binding (in Dylan) any variables if they have non-trivial values
+ (assert (symbolp var))
+ (let ((temp (gensym (string var))))
+ `(if (or (constantp ,var) (atom ,var))
+ (progn , at body)
+ (list 'let ',temp ,var
+ (let ((,var ',temp)) , at body)))))
+
+(defun maybe-begin (args)
+ "Take a list of args (a body) and wrap a BEGIN around it if necessary."
+ (case (length args)
+ (0 '|\#f|)
+ (1 (if (starts-with (first/ args) 'let) `(begin , at args) (first/ args)))
+ (t `(begin , at args))))
+
+;;;; GENERAL LISP UTILITY FUNCTIONS
+
+(defun op (exp) (first/ exp))
+(defun args (exp) (rest/ exp))
+
+(defun last1 (x) (first (last x)))
+
+(defun nconc1 (list element) (nconc list (list element)))
+
+(defun mklist (x)
+ "Return x if is a list, otherwise (list x)."
+ (if (listp x) x (list x)))
+
+(defun mksymbol (&rest parts)
+ "Concatenate the parts and intern as a symbol."
+ (intern (format nil "~{~A~}" parts)))
+
+(defun first-atom (x)
+ "The first (leftmost) atom in a nested list."
+ (if (atom x) x (first-atom (first/ x))))
+
+(defun length=1 (x)
+ "Is this a list of length 1?"
+ (and (consp x) (null (rest/ x))))
+
+(defun length>1 (x)
+ "Is this a list of length greater than 1?"
+ (and (consp x) (rest/ x)))
+
+(defun dotted? (exp)
+ ;; Is this a dotted list -- one with a non-null last tail?
+ (and (consp exp) (not (null (rest/ (last exp))))))
+
+(defun starts-with (sequence item)
+ "Is the first argument a sequence that starts with this item?"
+ (setq sequence (strip sequence))
+ (and (typecase sequence
+ (list (not (null sequence)))
+ (vector (> (length sequence) 0)))
+ (eql (elt sequence 0) item)))
+
+(defun ends-with (sequence item)
+ "Is the first argument a sequence that ends with this item?"
+ (and (typecase sequence
+ (list (not (null sequence)))
+ (vector (> (length sequence) 0)))
+ (eql (elt sequence (- (length sequence) 1)) item)))
+
+(defun bracketed-with (sequence item)
+ "Is the first argument a sequence that starts and ends with this item?"
+ (and (starts-with sequence item)
+ (ends-with sequence item)))
+
+(defun expand-files (files)
+ "Return a list of files matching the specification."
+ (mapcan #'directory (mklist files)))
+
+(defun find-anywhere (item tree)
+ "Does item appear anywhere in tree?"
+ (or (equal item tree)
+ (and (consp tree)
+ (or (find-anywhere item (car tree))
+ (find-anywhere item (cdr tree))))))
+
+;;;; DESTRUCTURING BIND, AND VARIANTS
+
+(defmacro safe-destructuring-bind (form exp &body body)
+ ;; This is similar to destructuring-bind, except
+ ;; (1) Missing args are silently ignored
+ ;; (2) No & keywords, except &optional (abbreviated &opt). Dot at end ok.
+ (*ing-bind-fn form exp body #'(lambda (x) (declare (ignore x)) 'identity)))
+
+(defmacro converting-bind (form exp &body body)
+ ;; Like safe-destructuring-bind, except
+ ;; (3) variables in FORM are converted according to their name
+ (*ing-bind-fn
+ form exp body
+ #'(lambda (arg)
+ (case arg
+ ((f pred) 'cvt-fn)
+ ((name ignore asis) 'identity)
+ ((body) 'cvt-body)
+ ((type class) 'cvt-type-exp)
+ ((keys) 'cvt-keys) ; Which does NOT convert; just handles :test-not
+ ((stdin) '(lambda (x)
+ (if (null/ x) '*standard-input* (cvt-exp x))))
+ ((stdout) '(lambda (x)
+ (if (null/ x) '*standard-output* (cvt-exp x))))
+ (otherwise
+ (if (ends-with (string arg) #\*)
+ 'cvt-exps
+ 'cvt-exp))))))
+
+(defun *ing-bind-fn (form exp body converter)
+ (let ((var (gensym))
+ (vars nil))
+ (loop (let ((v (if (atom form) form (first form))))
+ (cond ((null/ form) (RETURN))
+ ((member v '(&opt &optional)) nil)
+ ((or (not (symbolp v)) (member v lambda-list-keywords))
+ (error "Don't support ~A" v))
+ ((and (atom form) (not (null form)))
+ (push `(,v (,(funcall converter v) ,var)) vars))
+ (t (push `(,v (,(funcall converter v) (pop ,var))) vars)))
+ (if (atom form) (RETURN) (pop form))))
+ `(let* ((,var ,exp) ,@(nreverse vars)) , at body)))
+
+
Added: trunk/ltd/code/options.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/options.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,158 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: options.lisp; Date: 2/Feb/95
+(in-package :cl-user)
+
+;;;; OPTIONS: FACILITY FOR DEFINING, SETTING. AND QUERYING OPTIONS
+
+;;; There are better mechanisms for this in CLIM and in LispWorks,
+;;; but I wanted something portable to bare CL. The public interface is:
+
+;;; (get-option name) Fetch the value for this option name.
+;;; (set-option name value) Set the value.
+;;; (new-options :name val...) Define a new set of options.
+;;; (member-of-option item name) Is item in name's option value?
+;;; *options* The currently used set of options.
+;;; *default-options* Holds default values for options.
+
+;;; Here is the implementation:
+
+(defstruct (option (:type list))
+ name value type doc)
+
+(deftype boolean () '(member t nil))
+
+(defparameter *default-options*
+ `(
+ ;; Options for the conversion from Lisp to Dylan
+ (:empty-as |\#()| (member |\#()| |\#f|)
+ "Should () translate as #() or #f")
+ (:nil-as |\#f| (member |\#()| |\#f|)
+ "Should NIL translate as #() or #f")
+ (:when-as if (member if when)
+ "Should WHEN translate to IF or to WHEN")
+ (:unless-as if (member if unless)
+ "Should UNLESS translate to IF or to UNLESS")
+ (:cond-as if (member if case)
+ "Should COND translate to IF or to CASE")
+ (:defun-as define-method (member define-function define-method)
+ "Should DEFUN translate to DEFINE METHOD or to DEFINE FUNCTION")
+ (:convert-slot-value t boolean
+ "Should (slot-value x slot) become 'x.slot'")
+ (:use-cl-sequence-functions nil boolean
+ "Should CL Library sequence functions be used when there is a Dylan function")
+ (:class-name-arguments-to-condition-functions t boolean
+ "Should, e.g., #'signal worry about calls like (signal 'condition ...)")
+ (:macroexpand-hard-loops t boolean
+ "If we can't convert a LOOP, should we macroexpand it")
+ (:macroexpand-hard-format-strings t boolean
+ "If we can't convert a format string, should we use FORMATTER")
+ (:only-binary-arithmetic-ops t boolean
+ "Should we assume that, e.g., #'+ will only be applied to two arguments")
+ (:obey-in-package t boolean
+ "Should we switch packages when encountering an IN-PACKAGE")
+ (:errors-inline t boolean
+ "Should warnings appear as comments in the Dylan code")
+
+ ;; Options for pretty-printing style (indenting, etc.)
+ (:print-package nil boolean
+ "Should the package of a symbol be printed [rather than ignored]")
+ (:tab-stop 2 (integer 1 8)
+ "Number of spaces to indent for each block")
+ (:single-returns-wrapped t boolean
+ "Should one-element return lists print as '=> (x)' [rather than '=> x']")
+ (:prefer-dot-notation nil boolean
+ "Should we print most everything as 'x.f' [rather than 'f(x)']")
+ (:undotted-functions
+ (make singleton signal error warning assert open close)
+ (or (member t) list)
+ "A list of functions that never get printed in dot notation")
+ (:semicolon-before-end t boolean
+ "Should we print the semicolon in 'x; end' [rather than 'x end']")
+ (:space-in-call nil boolean
+ "Should we print a function call as 'f (x)' [rather than 'f(x)']")
+ (:comments // (member // /*)
+ "Should comments print with '//' or '/*'")
+ (:end-name t (or t nil)
+ "Should we print 'end method f' [rather than just 'end method']")
+ (:end-construct t (or (member t) list)
+ "A list of constructs, e.g. (block class), for which we print 'end block'
+[rather than just 'end'], or T to cover every construct")
+ ))
+
+(defparameter *options* (copy-tree *default-options*))
+
+(defun new-options (&rest inits &key (default *default-options*) (? nil)
+ &allow-other-keys)
+ ;; Build and install a new options list. You can:
+ ;; (1) specify a default with, e.g., :default *old-options*
+ ;; (2) override values with, e.g., :unless-as 'if :tab-stop 4
+ ;; (3) set all values to "ask user" with :? t
+ (setf *options* (copy-tree default))
+ (when ?
+ (dolist (option *options*)
+ (setf (option-value option) :?)))
+ (loop for (key val) on inits by 'cddr do
+ (unless (member key '(:? :default))
+ (set-option key val)))
+ *options*)
+
+(defun set-option (name value &optional (ask? t))
+ "Set an option name to a value, if legal. Returns t if legal."
+ (let ((option (find-option name)))
+ (cond ((null option) (warn "No such option name as ~A; ignored." name)
+ nil)
+ ((legal-option-value? name value)
+ (setf (option-value option) value)
+ t)
+ (ask?
+ (format *query-io* "~&The legal values are ~A"
+ (type->string (option-type option)))
+ (get-option name t))
+ (t nil))))
+
+(defun get-option (name &optional (ask? t))
+ "Get the value of the named option, asking if necessary."
+ (let* ((option (find-option name))
+ (value (if option (option-value option))))
+ (cond ((null option) (warn "No such option name as ~A; ignored." name))
+ ((and (eq value :?) ask?)
+ (format *query-io*
+ "~&(Type a one-time answer like ~S, or type ALWAYS ~:*~S ~%~
+ to avoid this question in the future.)~%"
+ (let ((*options* *default-options*))
+ (get-option name)))
+ (format *query-io* "~A? " (option-doc option))
+ (let* ((value (read *query-io*)))
+ (cond ((eq value 'always) (set-option name (read *query-io*)))
+ ((legal-option-value? name value) value)
+ (t (set-option name value t)))))
+ (t value))))
+
+(defun find-option (name) (assoc name *options*))
+
+(defun legal-option-value? (name value)
+ (or (eq value :?)
+ (typep value (option-type (find-option name)))))
+
+(defun member-of-option (item name)
+ "Is ITEM a member of (OPTION NAME), or is (OPTION NAME) equal to t?"
+ (or (eq (get-option name) t) (member item (get-option name))))
+
+(defun type->string (type)
+ (cond ((eq type 'boolean)
+ "T or NIL (for yes or no, respectively)")
+ ((equal type '(or (member t) list))
+ "either a list of names, or T to indicate any name")
+ ((atom type)
+ (format nil "a ~A" type))
+ ((eq (first type) 'integer)
+ (format nil "an integer from ~D to ~D" (second type) (third type)))
+ ((and (starts-with type 'member) (= (length type) 2))
+ (format nil "~S" (second type)))
+ ((starts-with type 'member)
+ (format nil "one of the set {~{~S~^, ~}}" (rest type)))
+ ((starts-with type 'and)
+ (format nil "~{~A~^ and ~}" (mapcar #'type->string (rest type))))
+ ((starts-with type 'or)
+ (format nil "~{~A~^ or ~}" (mapcar #'type->string (rest type))))))
+
Added: trunk/ltd/code/read.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/read.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,130 @@
+;;;; LTD-READ: PRESERVES COMMENTS AND REMEMBERS FILE POSITIONS
+(in-package :cl-user)
+
+(defvar *eof* "eof")
+(defvar *file-position-table* (make-hash-table :test #'eq))
+(defvar *read-list* (get-macro-character #\())
+(defvar *lisp-array* (get-dispatch-macro-character #\# #\A))
+(defvar *lisp-readtable* *readtable*)
+(defvar *buffer*
+ (make-array 200 :element-type 'character :fill-pointer 0 :adjustable t))
+
+
+(defparameter *ltd-readtable*
+ (let ((table (copy-readtable *readtable*)))
+ (set-macro-character #\; 'collect-comments nil table)
+ (set-macro-character #\( 'ltd-read-list nil table)
+ (set-dispatch-macro-character #\# #\| 'collect-comments table)
+ (set-dispatch-macro-character #\# #\A 'read-array table)
+ (set-dispatch-macro-character #\# #\a 'read-array table)
+ table))
+
+(defstruct (com (:predicate comment?))
+ ;; We spell it COM because LispWorks has a class called comment
+ (comment "") (code nil))
+
+(defun add-comment (comment code)
+ "Precede the code with a comment, or just return code if comment is null."
+ (if comment (make-com :comment comment :code code) code))
+
+(defmacro move-comment (place exp)
+ ;; Strip the comment off of place, then eval exp and put comment there.
+ (let ((comment (gensym)))
+ `(let ((,comment (get-comment ,place)))
+ (setf ,place (strip ,place))
+ (add-comment ,comment ,exp))))
+
+(defun get-comment (exp)
+ (if (comment? exp) (com-comment exp) nil))
+
+(defmacro record-file-positions (stream exp)
+ ;; Caution: not hygienic
+ `(let* ((start (file-position ,stream))
+ (value ,exp)
+ (end (file-position ,stream)))
+ (when (or (consp value) (stringp value))
+ (setf (gethash value *file-position-table*) (cons start end)))
+ value))
+
+(defun ltd-read-list (stream char)
+ ;; Check for () and record positions
+ (declare (ignore char))
+ (case (peek-char t stream nil)
+ (#\) (read-char stream) '|()|)
+ (otherwise (record-file-positions
+ stream (funcall *read-list* stream char)))))
+
+(defun read-array (stream char &optional arg)
+ "Read an array using the native lisp array reader."
+ (let ((*readtable* *lisp-readtable*))
+ (funcall *lisp-array* stream char arg)))
+
+(defun collect-comments (stream char &optional arg comment-so-far)
+ ;; Gather up comments, then either attach to following exp
+ ;; or return no values (thus silently ignoring the comments).
+ (declare (ignore arg))
+ (let* ((comment
+ (case char
+ (#\; (loop while (read-char-if stream #\;)) ; Flush leading ;s
+ (read-line stream nil ""))
+ (#\| (ltd-read-hash-comment stream))
+ (t "")))
+ (comments (if comment-so-far
+ (format nil "~A~%~A" comment-so-far comment)
+ comment)))
+ (case (peek-char t stream nil)
+ ((#\. #\)) (values));; Ignore the comment
+ ((#\;) (collect-comments stream #\; nil comments))
+ ((#\#)
+ ;; Deal with #|, #+, #-
+ (read-char stream)
+ (case (peek-char nil stream nil)
+ ((#\|) (read-char stream)
+ (collect-comments stream #\| nil comments))
+ ((#\+ #\-) (add-comments-to-conditional stream comments))
+ (t (unread-char #\# stream)
+ (add-comment comments (ltd-read stream)))))
+ (otherwise (add-comment comments (ltd-read stream))))))
+
+(defun add-comments-to-conditional (stream comments)
+ ;; We've read # and peeked at + or -
+ ;; Add comments to next expression, if it is in,
+ ;; or else ignore it and pass comments back to collect-comments
+ (let* ((fn (ecase (read-char stream) (#\+ 'identity) (#\- 'not)))
+ (*package* (find-package :keyword))
+ (feature (read stream)))
+ (if (funcall fn (member feature *features*)) ;; should handle and/or/not
+ (add-comment comments (ltd-read stream))
+ (let ((*read-suppress* t))
+ (read stream nil nil) ;; Ignore the next exp
+ (collect-comments stream nil 0 comments)))))
+
+
+(defun ltd-read-hash-comment (stream)
+ (setf (fill-pointer *buffer*) 0)
+ (let ((level 1))
+ (loop
+ (let ((char (read-char stream nil :eof t)))
+ (case char
+ (:eof (warn "EOF during #| ... |# comment") (RETURN))
+ (#\# (cond ((read-char-if stream #\|)
+ (incf level))
+ (t (vector-push-extend #\# *buffer*))))
+ (#\| (cond ((read-char-if stream #\#)
+ (decf level)
+ (when (eql level 0)
+ (RETURN)))
+ (t (vector-push-extend #\| *buffer*))))
+ (otherwise (vector-push-extend char *buffer*))))))
+ (coerce *buffer* 'string))
+
+
+(defun ltd-read (&optional (stream *standard-input*))
+ "Read a Lisp expression, preserving comments and file positions."
+ (let* ((*readtable* *ltd-readtable*))
+ (record-file-positions stream (read stream nil *eof*))))
+
+(defun read-char-if (stream char)
+ (if (eql (peek-char nil stream nil nil) char)
+ (read-char stream)
+ nil))
Added: trunk/ltd/code/tables.lisp
==============================================================================
--- (empty file)
+++ trunk/ltd/code/tables.lisp Tue Jul 25 22:13:07 2006
@@ -0,0 +1,728 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*- Author: Peter Norvig
+;;; File: tables.lisp; Date: 31-Aug-95
+(in-package :cl-user)
+
+;;;; CLtL2 CONSTANTS
+
+(ltd-constant |()| (get-option :empty-as))
+(ltd-constant nil (get-option :nil-as))
+(ltd-constant |\#f| |\#f|)
+(ltd-constant t |\#t|)
+
+;;;; CLtL2 CH 2: DATA TYPES
+
+(ltd-type adustable-array <stretchy-vector>)
+(ltd-type array <array>)
+(ltd-type atom <atom>)
+(ltd-type base-char <character>)
+(ltd-type base-string <string>)
+(ltd-type bignum <integer>)
+(ltd-type bit (limited <integer> :from 0 :to 1))
+(ltd-type built-in-class <class>)
+(ltd-type character <character>)
+(ltd-type class <class>)
+(ltd-type compiled-function <function>)
+(ltd-type complex <complex>)
+(ltd-type condition <condition>)
+(ltd-type cons <pair>)
+(ltd-type double-float <double-float>)
+(ltd-type end-of-file <end-of-stream-error>)
+(ltd-type extended-char <character>)
+(ltd-type error <error>)
+(ltd-type fixnum <integer>)
+(ltd-type file-error <file-error>)
+(ltd-type float <float>)
+(ltd-type function <function>)
+(ltd-type generic-function <function>)
+(ltd-type hash-table <table>)
+(ltd-type integer <integer>)
+(ltd-type keyword <symbol>)
+(ltd-type lambda-expression <function>)
+(ltd-type list <list>)
+(ltd-type long-float <double-float>)
+(ltd-type method <method>)
+(ltd-type null (singleton |\#f|))
+(ltd-type number <number>)
+(ltd-type rational <rational>)
+(ltd-type real <real>)
+(ltd-type sequence <sequence>)
+(ltd-type serious-condition <serious-condition>)
+(ltd-type short-float <short-float>)
+(ltd-type simple-error <simple-error>)
+(ltd-type simple-string <simple-string>)
+(ltd-type simple-vector <simple-vector>)
+(ltd-type simple-warning <simple-warning>)
+(ltd-type single-float <short-float>)
+(ltd-type standard-class <class>)
+(ltd-type standard-generic-function <generic-function>)
+(ltd-type standard-method <method>)
+(ltd-type standard-object <object>)
+(ltd-type stream <stream>)
+(ltd-type file-stream <file-stream>)
+(ltd-type string-stream <string-stream>)
+(ltd-type string <string>)
+(ltd-type symbol <symbol>)
+(ltd-type t <object>)
+(ltd-type type-error <type-error>)
+(ltd-type vector <vector>)
+(ltd-type warning <warning>)
+
+(ltd-unimplemented-types
+ bit-vector package pathname random-state ratio readtable structure)
+
+;;;; CLtL2 CH 4: TYPE SPECIFIERS
+
+(ltd-fn deftype #'cvt-deftype)
+(ltd-fn (coerce x type) `(as ,type ,x))
+(ltd-fn type-of object-class)
+
+;;;; CLtL2 CH 5: PROGRAM STRUCTURE
+
+(ltd-fn defun #'cvt-defun)
+(ltd-fn lambda #'cvt-lambda)
+(ltd-fn (defvar name &opt x d) (add-comment d `(define-variable ,name ,x)))
+(ltd-fn (defparameter name &opt x d) (add-comment d `(define-variable ,name ,x)))
+(ltd-fn (defconstant name &opt x d) (add-comment d `(define-constant ,name ,x)))
+(ltd-fn (eval-when ignore . body) (maybe-begin body))
+
+;;;; CLtL2 CH 6: PREDICATES
+
+(ltd-fn (typep x type) `(instance? ,x ,type))
+(ltd-fn (subtypep type class) `(subclass? ,type ,class))
+(ltd-fn null empty?)
+(ltd-fn (symbolp x) `(instance? ,x <symbol>))
+(ltd-fn (atom x) `(not (instance? ,x <list>)))
+(ltd-fn (consp x) `(instance? ,x <pair>))
+(ltd-fn (listp x) `(instance? ,x <list>))
+(ltd-fn (numberp x) `(instance? ,x <number>))
+(ltd-fn (integerp x) `(instance? ,x <integer>))
+(ltd-fn (rationalp x) `(instance? ,x <rational>))
+(ltd-fn (floatp x) `(instance? ,x <float>))
+(ltd-fn (realp x) `(instance? ,x <real>))
+(ltd-fn (complexp x) `(instance? ,x <complex>))
+(ltd-fn (characterp x) `(instance? ,x <character>))
+(ltd-fn (stringp x) `(instance? ,x <string>))
+(ltd-fn (vectorp x) `(instance? ,x <vector>))
+(ltd-fn (simple-vectorp x) `(instance? ,x <simple-vector>))
+(ltd-fn (simple-stringp x) `(instance? ,x <simple-string>))
+(ltd-fn (arrayp x) `(instance? ,x <array>))
+(ltd-fn (functionp x) `(instance? ,x <function>))
+(ltd-fn (adjustable-array-p x) `(instance? ,x <stretchy-vector>))
+(ltd-fn (compiled-function-p x) `(instance? ,x <function>))
+(ltd-fn (hash-table-p x) `(instance? ,x <table>))
+(ltd-fn (sequencep x) `(instance? ,x <sequence>))
+(ltd-fn eq ==)
+(ltd-fn eql ==)
+(ltd-fn equal =)
+(ltd-fn equalp =) ; ?? not quite right
+(ltd-fn not ~)
+(ltd-fn (and . asis) (cvt-to-binary `(& , at asis)))
+(ltd-fn (or . asis) (cvt-to-binary `(\| , at asis)))
+
+;;;; CLtL2 CH 7: CONTROL STRUCTURE
+
+(ltd-fn quote #'identity)
+(ltd-fn function #'cvt-fn)
+(ltd-fn (symbol-value x) (identity x)) ;; Not quite right
+(ltd-fn (symbol-function f) (identity f)) ;; Not quite right
+(ltd-fn setq #'cvt-setf)
+(ltd-fn psetq #'cvt-macro)
+(ltd-fn setf #'cvt-setf)
+(ltd-fn psetf #'cvt-macro)
+(ltd-fn shiftf #'cvt-macro)
+(ltd-fn rotatef #'cvt-macro)
+(ltd-fn (apply f . arg*) `(apply ,f . ,arg*))
+(ltd-fn (funcall f . arg*) `(,f . ,arg*))
+(ltd-fn (progn . body) `(begin . ,body))
+(ltd-fn (prog1 x . x*) `(begin (let _ ,x , at x* _)))
+(ltd-fn (prog2 x y . x*) `(begin ,x (let _ ,y , at x* _)))
+(ltd-fn let #'cvt-let)
+(ltd-fn let* #'cvt-let*)
+(ltd-fn compiler-let #'cvt-compiler-let)
+(ltd-fn flet #'cvt-flet)
+(ltd-fn labels #'cvt-labels)
+(ltd-fn symbol-macrolet #'cvt-symbol-macrolet)
+(ltd-fn if #'cvt-if)
+(ltd-fn (when x . body) `(,(get-option :when-as) ,x , at body))
+(ltd-fn (unless x . body) (if (eq (get-option :unless-as) 'if)
+ `(if (~ ,x) , at body) `(unless ,x . ,body)))
+(ltd-fn cond #'cvt-cond)
+(ltd-fn case #'cvt-case)
+(ltd-fn typecase #'cvt-typecase)
+(ltd-fn (block name . body) (handle-returns1 (maybe-begin body) name))
+(ltd-fn return-from #'cvt-return-from)
+(ltd-fn (return &opt x) (if (starts-with x 'values) `(return ,@(rest/ x))
+ `(return ,x)))
+(ltd-fn loop #'cvt-loop)
+(ltd-fn do #'cvt-do)
+(ltd-fn do* #'cvt-do)
+(ltd-fn dolist #'cvt-dolist)
+(ltd-fn dotimes #'cvt-dotimes)
+(ltd-fn (mapcar f list . list*) `(map ,f ,list . ,list*))
+(ltd-fn (mapc f list . list*) (once list `(begin (do ,f ,list . ,list*)
+ ,(strip list))))
+(ltd-fn (mapcan f . list*) `(apply concatenate! (map ,f . ,list*)))
+(ltd-fn (mapcon . asis) `(apply concatenate! ,(cvt-exp `(maplist . ,asis))))
+(ltd-fn tagbody #'cvt-tagbody)
+(ltd-fn prog #'cvt-macro)
+(ltd-fn prog* #'cvt-macro)
+(ltd-fn (go name) `(,(mksymbol 'go- name)))
+(ltd-fn values values)
+(ltd-fn (values-list v) `(apply values ,v))
+(ltd-fn (multiple-value-list x) `(let (:args |\#rest| _) ,x _))
+(ltd-fn multiple-value-call #'cvt-multiple-value-call)
+(ltd-fn (multiple-value-prog1 x . x*) `(let (:args |\#rest| _) ,x , at x*
+ (apply values _)))
+(ltd-fn multiple-value-bind #'cvt-multiple-value-bind)
+(ltd-fn multiple-value-setq #'cvt-multiple-value-setq)
+(ltd-fn (nth-value n x) `(element (begin (let (:args |\#rest| _) ,x _)) ,n))
+(ltd-fn (catch name . body) `(block ,(cvt-tag name) . ,body))
+(ltd-fn (unwind-protect x . body) `(block nil ,x (:cleanup , at body)))
+(ltd-fn (throw name x) `(,(cvt-tag name) ,x))
+
+;;;; CLtL2 CH 8: MACROS
+
+(ltd-fn (defmacro name . ignore) (progn (incf-unimplemented 'defmacro)
+ (cvt-erroneous exp `',name "No macros.")))
+(ltd-fn (defsetf name . ignore) (progn (incf-unimplemented 'defsetf)
+ (cvt-erroneous exp `',name "No setf macros.")))
+(ltd-fn destructuring-bind #'cvt-macro) ; Note no &optional in Dylan
+
+;;;; CLtL2 CH 9: DECLARATIONS
+
+(ltd-fn declare '|\#f|)
+(ltd-fn (locally . body) (maybe-begin body))
+(ltd-fn proclaim '|\#f|)
+(ltd-fn declaim '|\#f|)
+(ltd-fn (the type x) (progn type x))
+
+;;;; CLtL2 CH 10: SYMBOLS
+
+(ltd-fn get symbol-get-property)
+(ltd-fn symbol-plist symbol-plist)
+(ltd-fn remprop symbol-remove-property)
+(ltd-fn (getf p i &opt d) `(get-property! ,p ,i ,@(ifd d `(:default ,d))))
+(ltd-fn remf remove-property!)
+(ltd-fn (symbol-name s) `(as <string> ,s))
+(ltd-fn (make-symbol str) `(as <symbol> ,str))
+(ltd-fn (gensym &opt x) `(generate-symbol ,@(ifd x `((:string ,x)))))
+(ltd-fn (gentemp &opt x ignore) `(generate-symbol ,@(ifd x `((:string ,x)))))
+(ltd-fn (keywordp x) `(instance? ,x <symbol>)) ; ??? not right
+(ltd-fn (intern s) `(as <symbol> ,s))
+
+;;;; CLtL2 CH 11: PACKAGES
+
+(ltd-fn in-package #'cvt-in-package)
+(ltd-fn export #'cvt-export)
+(ltd-fn defpackage #'cvt-defpackage)
+
+;;;; CLtL2 CH 12: NUMBERS
+
+(ltd-fn zerop zero?)
+(ltd-fn plusp positive?)
+(ltd-fn minusp negative?)
+(ltd-fn oddp odd?)
+(ltd-fn evenp even?)
+(ltd-fn = #'cvt-to-binary-compares)
+(ltd-fn (/= . arg*) (cvt-to-binary-compares `(~= . ,arg*)))
+(ltd-fn < #'cvt-to-binary-compares)
+(ltd-fn > #'cvt-to-binary-compares)
+(ltd-fn <= #'cvt-to-binary-compares)
+(ltd-fn >= #'cvt-to-binary-compares)
+(ltd-fn max max)
+(ltd-fn min min)
+(ltd-fn + #'cvt-to-binary)
+(ltd-fn - #'cvt-to-binary)
+(ltd-fn * #'cvt-to-binary)
+(ltd-fn / #'cvt-to-binary)
+(ltd-fn (1+ x) `(+ ,x 1))
+(ltd-fn (1- x) `(- ,x 1))
+(ltd-fn incf inc!)
+(ltd-fn decf dec!)
+(ltd-fn gcd gcd)
+(ltd-fn lcm lcm)
+(ltd-fn exp exp)
+(ltd-fn expt ^)
+(ltd-fn log log)
+(ltd-fn sqrt sqrt)
+(ltd-fn (isqrt x) `(truncate (sqrt ,x)))
+(ltd-fn abs abs)
+(ltd-fn (signum x) (once x `(if (> ,x 0) 1 (:elseif (< ,x 0) -1)
+ (:else 0))))
+(ltd-fn sin sin)
+(ltd-fn cos cos)
+(ltd-fn tan tan)
+(ltd-fn asin asin)
+(ltd-fn acos acos)
+(ltd-fn atan atan)
+(ltd-fn sinh sinh)
+(ltd-fn cosh cosh)
+(ltd-fn tanh tanh)
+(ltd-fn asinh asinh)
+(ltd-fn acosh acosh)
+(ltd-fn atanh atanh)
+(ltd-fn (float x &opt y) `(as ,x ,(ifd y `(class-of ,y) '<float>)))
+(ltd-fn (rational x) `(as <rational> ,x))
+(ltd-fn rationalize rationalize)
+(ltd-fn numerator numerator)
+(ltd-fn denominator denominator)
+(ltd-fn floor #'cvt-division)
+(ltd-fn ceiling #'cvt-division)
+(ltd-fn truncate #'cvt-division)
+(ltd-fn round #'cvt-division)
+(ltd-fn mod modulo)
+(ltd-fn rem remainder)
+(ltd-fn (ffloor . asis)