├── history ├── cliiscm-aliases.lisp ├── README.adoc ├── cliiscm.lisp └── cliiscm-translators.lisp /history: -------------------------------------------------------------------------------- 1 | 2016 Dec 27 2 | 3 | Start. 4 | -------------------------------------------------------------------------------- /cliiscm-aliases.lisp: -------------------------------------------------------------------------------- 1 | ;name conversions 2 | 3 | ;last change 2022-07-04 4 | 5 | (defvar *cliiscm-read-aliases-list* 6 | '( 7 | 8 | *standard-input* (current-input-port) 9 | *standard-output* (current-output-port) 10 | 1+ add1 11 | 1- sub1 12 | ;floor quotient 13 | alpha-char-p char-alphabetic? 14 | char string-ref 15 | char-code char->integer 16 | char-equal char-ci=? 17 | char-greaterp char-ci>? 18 | char-int char->integer 19 | char-lessp char-ci=? 22 | char< char char>? 26 | char>= char>=? 27 | characterp char? 28 | code-char integer->char 29 | complexp complex? 30 | consp pair? 31 | digit-char-p char-numeric? 32 | dribble transcript-off 33 | dribble transcript-on 34 | elt list-ref 35 | eq eq? 36 | eql eqv? 37 | equal equal? 38 | eval eval1 39 | evenp even? 40 | every andmap 41 | file-write-date file-or-directory-modify-seconds 42 | force-output flush-output 43 | functionp procedure? 44 | get-output-stream-string get-output-string 45 | get-universal-time current-seconds 46 | integerp integer? 47 | lower-case-p char-lower-case? 48 | make-string-input-stream open-input-string 49 | make-string-output-stream open-output-string 50 | mapc for-each 51 | mapcar map 52 | minusp negative? 53 | mod modulo 54 | null null? 55 | numberp number? 56 | oddp odd? 57 | plusp positive? 58 | prin1 write 59 | princ display 60 | probe-file file-exists? 61 | progn begin 62 | realp real? 63 | rplaca set-car! 64 | rplacd set-cdr! 65 | some ormap 66 | sort sort! 67 | string-equal string-ci=? 68 | string-greaterp string-ci>? 69 | string-lessp string-ci=? 72 | string< string string>? 76 | string>= string>=? 77 | stringp string? 78 | subseq substring 79 | svref vector-ref 80 | t true 81 | terpri newline 82 | upper-case-p char-upper-case? 83 | values list 84 | vectorp vector? 85 | zerop zero? 86 | 87 | ;quasiquote 88 | 89 | #+(or ecl mkcl) si:quasiquote 90 | #+(or ecl mkcl) quasiquote 91 | 92 | ;unquote 93 | 94 | #+(or ecl mkcl) si:unquote 95 | #+(or ecl mkcl) unquote 96 | 97 | ;unquote-splice 98 | 99 | #+(or ecl mkcl) si:unquote-splice 100 | #+(or ecl mkcl) unquote-splicing 101 | 102 | ;getenv 103 | 104 | #+allegro system::getenv 105 | #+allegro getenv 106 | 107 | #+ecl si:getenv 108 | #+ecl getenv 109 | 110 | #+mkcl mkcl:getenv 111 | #+mkcl getenv 112 | 113 | #+(or abcl clasp clisp) ext:getenv 114 | #+(or abcl clasp clisp) getenv 115 | 116 | #+sbcl sb-ext:posix-getenv 117 | #+sbcl getenv 118 | 119 | #+clozure ccl::getenv 120 | #+clozure getenv 121 | 122 | ;system 123 | 124 | #+(and unix (or allegro clisp)) shell 125 | #+(and unix (or allegro clisp)) system 126 | 127 | #+(and unix clozure) ccl::os-command 128 | #+(and unix clozure) system 129 | 130 | #+(and (or unix darwin) ecl) si:system 131 | #+(and (or unix darwin) ecl) system 132 | 133 | #+clasp ext:system 134 | #+clasp system 135 | 136 | #+abcl ext:run-shell-command 137 | #+abcl system 138 | 139 | #+mkcl mkcl:system 140 | #+mkcl system 141 | 142 | )) 143 | 144 | (defvar *cliiscm-read-aliases* '()) 145 | 146 | (let ((ll *cliiscm-read-aliases-list*)) 147 | (loop 148 | (when (null ll) (return)) 149 | (push (cons (car ll) (cadr ll)) *cliiscm-read-aliases*) 150 | (pop ll) 151 | (pop ll))) 152 | 153 | (defvar *cliiscm-write-pre-aliases-list* 154 | '( 155 | 156 | #+ecl si:quasiquote 157 | #+ecl quasiquote 158 | 159 | #+ecl si:unquote 160 | #+ecl unquote 161 | 162 | #+ecl si:unquote-splice 163 | #+ecl unquote-splicing 164 | 165 | )) 166 | 167 | (defvar *cliiscm-write-pre-aliases* '()) 168 | 169 | (let ((ll *cliiscm-write-pre-aliases-list*)) 170 | (loop 171 | (when (null ll) (return)) 172 | (push (cons (car ll) (cadr ll)) *cliiscm-write-pre-aliases*) 173 | (pop ll) 174 | (pop ll))) 175 | -------------------------------------------------------------------------------- /README.adoc: -------------------------------------------------------------------------------- 1 | = CLiiScm 2 | 3 | CLiiScm ports select Common Lisp files in the working 4 | directory to Racket. 5 | 6 | Currently, it is used to create the Racket version of the Common 7 | Lisp source for 8 | https://github.com/ds26gte/tex2page[TeX2page], to avoid the 9 | tedium of maintaining two sources (each about 11 kLoC). The Racket 10 | version can be further converted to other Scheme dialects using 11 | https://github.com/ds26gte/scmxlate[Scmxlate]. 12 | 13 | CLiiScm isn't a completely general-purpose translator. 14 | Specifically, it requires uses of the Common Lisp `loop` macro to 15 | be such that any `return` expressions occur only in a tail call 16 | position of an immediate subform of the `loop`. A more general 17 | translation of `loop` would have made the more common uses 18 | unnecessarily inefficient. 19 | 20 | It also doesn't have `setf` and `setq` return the set value, or 21 | `when` and `unless` return false as an implicit `else`. 22 | These are not common enough uses, and accommodating such behavior, 23 | although truer to the Common Lisp source, 24 | would make every translation of these expressions verbose. 25 | 26 | == Usage 27 | 28 | Specify the files to be ported in the file 29 | `cliiscm-files-to-be-ported.lisp` in the working directory. This 30 | is a Lisp-readable file, with each ported file being specified as 31 | a Lisp symbol or string, and you can use comments and spacing to 32 | taste. Essentially the filenames are separated by space (newline 33 | for maintainability). If a filename itself has spaces or 34 | upper-case characters in it, specify it as a string. If a 35 | filename isn't a string, it is automatically lower-cased. 36 | 37 | In the following, assume `jobname.lisp` is a file that is to be ported. 38 | 39 | Create the file `cliiscm-files-to-be-ported.lisp` containing the 40 | Lisp symbol `jobname.lisp` or string `"jobname.lisp"`. 41 | 42 | Start Common Lisp and then load the file `cliiscm.lisp` (using the 43 | appropriate relative or full pathname). When CLiiScm is done, it 44 | will generally leave for each `jobname.lisp` the ported 45 | equivalent `my-jobmame.lisp`. (You can use CLiiScm directives to 46 | change the name of the output file(s).) 47 | 48 | For each file `jobname.lisp` to be ported, a user override file 49 | `cliiscm-jobname.lisp` can be provided in the working directory. 50 | 51 | === Example 52 | 53 | For a working example, see the TeX2page distribution. Here, the 54 | only CL file to be translated is `tex2page.lisp`, so there is a 55 | file `clliscm-files-to-be-ported.lisp` that contains 56 | `tex2page.lisp` as its sole entry. 57 | 58 | This file has an override file, which is called 59 | `clliscm-tex2page.lisp`. When loading `cliiscm.scm` into CL, it 60 | finds `cliiscm-files-to-be-ported.lisp`, determines 61 | `tex2page.lisp` is the only file to be translated, checks the 62 | corresponding user-override file `cliiscm-tex2page.lisp` and 63 | proceeds with the translation. 64 | 65 | While the output file is by default `my-tex2page.lisp`, we use 66 | the CLiiScm directive, `cliiscm-postprocess`, described below, to 67 | give it a more Scheme-y name. 68 | 69 | == Directives in the user override file 70 | 71 | In the user override file, the following directives can be used 72 | to guide the porting process: 73 | 74 | - `+(cliiscm-ignoredef name1 ...)+` will ignore the 75 | definitions for `+name1 ...+`. 76 | 77 | - `+(cliiscm-rename (old1 new1) ...)+` will change all 78 | occurrences of `+old1 ...+` to `+new1 ...+`. 79 | 80 | - `+(cliiscm-ignoredef-rename (old1 new1) ...)+` will ignore the 81 | definitions for `+old1 ...+` in `jobname.lisp` and will change all 82 | other occurrences of them to `+new1 ...+`. 83 | 84 | - `+(cliiscm-uncall name1 ...)+` will ignore all top-level calls 85 | to `+name1 ...+`. 86 | 87 | - `+(cliiscm-defsetf (getter1 setter1) ...)+` will associate 88 | `+setter1 ...+` as the setter procedures for `+getter1 ...+`. 89 | 90 | - `+(cliiscm-insert x ...)+` will insert `+x ...+` at the head of 91 | the output file. 92 | 93 | - `(cliiscm-postamble)` will position the contents of the 94 | source file at that point, so any subsequent directives will go 95 | after that. 96 | 97 | - `+(cliiscm-postprocess x ...)+` will perform the actions `+x 98 | ...+` after the output file has been created. (This can be used 99 | to rename or change the permissions of the output file.) 100 | 101 | - Any definitions in the user override file will 102 | automatically cause definitions of the same names in the source 103 | file to be ignored. 104 | 105 | // Last modified 2022-12-30 106 | -------------------------------------------------------------------------------- /cliiscm.lisp: -------------------------------------------------------------------------------- 1 | ":"; if test -z "$LISP"; then export LISP=ecl; fi 2 | ":"; if test "$LISP" = abcl; then exec abcl --load $0 --batch 3 | ":"; elif test "$LISP" = clasp; then exec clasp --script $0 2>/dev/null 4 | ":"; elif test "$LISP" = clisp; then exec clisp $0 -q 5 | ":"; elif test "$LISP" = clozure; then exec ccl -l $0 -b 6 | ":"; elif test "$LISP" = ecl; then exec ecl -shell $0 7 | ":"; elif test "$LISP" = mkcl; then exec mkcl -shell $0 8 | ":"; else test "$LISP" = sbcl; exec sbcl --script $0 9 | ":"; fi 10 | 11 | #+sbcl 12 | (declaim (sb-ext:muffle-conditions style-warning)) 13 | 14 | (setq *print-case* :downcase) 15 | 16 | (defvar *cliiscm-version* "20221226") ;last change 17 | 18 | (defvar *reading-source-file-p*) 19 | (defvar *disallowed-calls*) 20 | (defvar *source-file*) 21 | (defvar *source-file-translated-p*) 22 | (defvar *postprocessing*) 23 | 24 | (defvar *defs-to-ignore*) 25 | 26 | (defvar *setf-setters* (make-hash-table)) 27 | 28 | #+sbcl 29 | (sb-alien:define-alien-routine system sb-alien:int (command sb-alien:c-string)) 30 | 31 | #+sbcl 32 | (defun cliiscm-system (cmd) (system cmd)) 33 | 34 | #-sbcl 35 | (defun cliiscm-system (cmd) 36 | #+abcl (ext:run-shell-command cmd) 37 | #+allegro (excl:shell cmd) 38 | #+clasp (ext:system cmd) 39 | #+clisp (ext:shell cmd) 40 | #+clozure (ccl::os-command cmd) 41 | #+cmucl (ext:run-program "sh" (list "-c" cmd) :output t) 42 | #+ecl (si:system cmd) 43 | #+mkcl (mkcl:system cmd)) 44 | 45 | (load (merge-pathnames "cliiscm-aliases" *load-pathname*)) 46 | 47 | (load (merge-pathnames "cliiscm-translators" *load-pathname*)) 48 | 49 | (defvar *files-to-be-ported* 50 | (with-open-file (i "cliiscm-files-to-be-ported.lisp" :direction :input) 51 | (let (s) 52 | (loop 53 | (let ((f (read i nil :eof-object))) 54 | (when (eq f :eof-object) (return)) 55 | (when (symbolp f) 56 | (setq f (string-downcase (symbol-name f)))) 57 | (push f s))) 58 | s))) 59 | 60 | (defun translate-toplevel-source-exp-to-port (e o) 61 | (let ((res e)) 62 | (when *reading-source-file-p* 63 | (setq res (translate-exp (nsublis *cliiscm-read-aliases* e)))) 64 | (when (consp res) 65 | (pprint (nsublis *cliiscm-write-pre-aliases* res) o) 66 | (terpri o)))) 67 | 68 | (defun translate-port-to-port (i o) 69 | (loop 70 | (let ((x (read i nil :eof-object))) 71 | (when (eq x :eof-object) (return)) 72 | (translate-toplevel-exp-to-port x o)))) 73 | 74 | (defun translate-file-to-port (f o) 75 | (with-open-file (i f :direction :input) 76 | (translate-port-to-port i o))) 77 | 78 | (defun translate-source-file (o) 79 | (unless *source-file-translated-p* 80 | (setq *source-file-translated-p* t) 81 | (let ((*reading-source-file-p* t)) 82 | (format o "~%;Translated from Common Lisp source ~a by CLiiScm v. ~a, ~a.~%~%" 83 | *source-file* *cliiscm-version* 84 | #+abcl :abcl 85 | #+clasp :clasp 86 | #+clisp :clisp 87 | #+clozure :clozure 88 | #+cmucl :cmucl 89 | #+ecl :ecl 90 | #+mkcl :mkcl 91 | #+sbcl :sbcl 92 | ) 93 | (translate-file-to-port *source-file* o)))) 94 | 95 | (defun defmacro-to-define-syntax (e) 96 | (destructuring-bind (mname params &rest body) (cdr e) 97 | `(define-syntax ,mname 98 | (lambda (%so) 99 | (datum->syntax %so 100 | (let ((%so-d (syntax->datum %so))) 101 | (apply (lambda ,params ,@body) (cdr %so-d)))))))) 102 | 103 | (defun note-down-defs (x) 104 | (when (consp x) 105 | (case (car x) 106 | ((define define-syntax defmacro) 107 | (let ((ad (cadr x))) 108 | (when (consp ad) (setq ad (car ad))) 109 | (push ad *defs-to-ignore*))) 110 | (begin 111 | (mapc #'node-down-defs (cdr x)))))) 112 | 113 | ;(trace note-down-defs) 114 | 115 | (defun translate-toplevel-exp-to-port (x o) 116 | (when (consp x) 117 | (let ((a (car x))) 118 | ;(format t "toplevel a = ~s~%" a) 119 | (cond (*reading-source-file-p* 120 | (cond ((eq a 'defmacro) 121 | (let ((name (cadr x))) 122 | (unless (and (symbolp name) 123 | (member (nsublis *cliiscm-read-aliases* name) *defs-to-ignore*)) 124 | (translate-toplevel-source-exp-to-port (translate-exp x) o)))) 125 | ((member a *disallowed-calls*) nil) 126 | (t (translate-toplevel-source-exp-to-port x o)))) 127 | (t (case a 128 | (cliiscm-rename 129 | (dolist (y (cdr x)) 130 | (push (cons (car y) (cadr y)) *cliiscm-read-aliases*))) 131 | ((cliiscm-ignoredef-rename cliiscm-rename-def) 132 | (dolist (y (cdr x)) 133 | (let ((new-name (cadr y))) 134 | (push (cons (car y) new-name) *cliiscm-read-aliases*) 135 | (push new-name *defs-to-ignore*))) ) 136 | ((cliiscm-ignoredef cliiscm-ignore-def) 137 | (dolist (name (cdr x)) 138 | (push name *defs-to-ignore*))) 139 | (cliiscm-uncall 140 | (dolist (proc-name (cdr x)) 141 | (push proc-name *disallowed-calls*))) 142 | (cliiscm-defsetf 143 | (dolist (y (cdr x)) 144 | (setf (gethash (car y) *setf-setters*) (cadr y)))) 145 | (cliiscm-insert 146 | (dolist (y (cdr x)) 147 | (princ y o))) 148 | (cliiscm-postamble 149 | (translate-source-file o)) 150 | (cliiscm-postprocess 151 | (setq *postprocessing* 152 | (append *postprocessing* (cdr x)))) 153 | (t (note-down-defs x) 154 | (when (eq a 'defmacro) 155 | (setq x (defmacro-to-define-syntax x))) 156 | (pprint (nsublis *cliiscm-write-pre-aliases* x) o) 157 | (terpri o)))))))) 158 | 159 | ;(trace translate-toplevel-exp-to-port) 160 | 161 | (dolist (file-to-be-ported *files-to-be-ported*) 162 | (let ((*source-file* file-to-be-ported) 163 | (*postprocessing* nil) 164 | (*reading-source-file-p* nil) 165 | (*source-file-translated-p* nil) 166 | (user-override-file 167 | (let ((f (concatenate 'string "cliiscm-" file-to-be-ported))) 168 | (and (probe-file f) f))) 169 | (target-file 170 | (concatenate 'string "my-" file-to-be-ported))) 171 | (format t "Porting ~s to ~s...~%" file-to-be-ported target-file) 172 | (with-open-file (o target-file :direction :output :if-exists :supersede) 173 | (let ((*disallowed-calls* '()) 174 | (*defs-to-ignore* '())) 175 | (when user-override-file 176 | (translate-file-to-port user-override-file o)) 177 | ;(format t "defs-to-ignore = ~s~%" *defs-to-ignore*) 178 | (translate-source-file o))) 179 | (cliiscm-system (concatenate 'string "sed -i -e 's/\\/()/g' " target-file)) 180 | (cliiscm-system (concatenate 'string "sed -i -e 's/#\\\\Newline/#\\\\newline/g' " target-file)) 181 | (cliiscm-system (concatenate 'string "sed -i -e 's/#\\\\Return/#\\\\return/g' " target-file)) 182 | (cliiscm-system (concatenate 'string "sed -i -e 's/#\\\\Tab/#\\\\tab/g' " target-file)) 183 | (cliiscm-system (concatenate 'string "sed -i -e 's/#\\\\$/#\\\\ /' " target-file)) 184 | ;(format t "postproc= ~s~%" *postprocessing*) 185 | (dolist (p *postprocessing*) 186 | (eval p)))) 187 | 188 | (quit) 189 | -------------------------------------------------------------------------------- /cliiscm-translators.lisp: -------------------------------------------------------------------------------- 1 | ;last modified 2023-01-03 2 | 3 | (defvar *cliiscm-translators* (make-hash-table)) 4 | 5 | (defvar *it*) 6 | 7 | (defvar *inside-quote-p* nil) 8 | 9 | (defmacro def-cliiscm-translator (name params &rest body) 10 | `(setf (gethash ',name *cliiscm-translators*) 11 | (lambda ,params ,@body))) 12 | 13 | (defun tree-member (x tr) 14 | (if (consp tr) (or (tree-member x (car tr)) 15 | (tree-member x (cdr tr))) 16 | (eq x tr))) 17 | 18 | #-clisp 19 | (defun proper-list-p (s) 20 | (let ((s s)) 21 | (loop 22 | (cond ((null s) (return t)) 23 | ((atom s) (return nil)) 24 | (t (pop s)))))) 25 | 26 | (defun translate-exp (e) 27 | (cond ((consp e) 28 | (cond ((and (not *inside-quote-p*) (eq (car e) 'quote) (null (cadr e))) 29 | 'null) 30 | ((setq *it* (gethash (car e) *cliiscm-translators*)) 31 | (apply *it* (cdr e))) 32 | ((proper-list-p e) (mapcar #'translate-exp e)) 33 | (t (cons (translate-exp (car e)) (translate-exp (cdr e)))))) 34 | ((and (keywordp e) (not *inside-quote-p*)) 35 | (list 'quote e)) 36 | ((and (null e) (not *inside-quote-p*)) 37 | 'false) 38 | ;((null e) 'null) 39 | ((null e) 40 | '()) 41 | (t e))) 42 | 43 | (defun prune-begins (translated-progn-body &optional internalp) 44 | (let (res (n (length translated-progn-body))) 45 | (dotimes (i n) 46 | (let ((e-i (elt translated-progn-body i))) 47 | (cond ((atom e-i) 48 | (unless (or internalp (< i (1- n))) 49 | (setq res (append res (list e-i))))) 50 | ((eq (car e-i) 'begin) 51 | (setq res (append res 52 | (prune-begins (cdr e-i) 53 | (or internalp (< i (1- n))))))) 54 | (t 55 | (setq res (append res (list e-i))))))) 56 | res)) 57 | 58 | (defun translate-implicit-progn (ee) 59 | (prune-begins (mapcar #'translate-exp ee))) 60 | 61 | (defun translate-progn (ee) 62 | (let ((ee-i (translate-implicit-progn ee))) 63 | (case (length ee-i) 64 | (0 `false) 65 | (1 (car ee-i)) 66 | (t `(begin ,@ee-i))))) 67 | 68 | (def-cliiscm-translator quote (x) 69 | (let ((*inside-quote-p* t)) 70 | `(quote ,(translate-exp x)))) 71 | 72 | (def-cliiscm-translator funcall (&rest funkall) 73 | (mapcar #'translate-exp funkall)) 74 | 75 | (def-cliiscm-translator defstruct (name &rest fields) 76 | `(defstruct ,name 77 | ,@(mapcar (lambda (fld) 78 | (if (consp fld) `(,(let ((*inside-quote-p* t)) (translate-exp (car fld))) 79 | ,(translate-exp (cadr fld))) 80 | (let ((*inside-quote-p* t)) (translate-exp fld)))) 81 | fields))) 82 | 83 | (def-cliiscm-translator defmacro (name params &rest body) 84 | (unless (member name *defs-to-ignore*) 85 | `(define-syntax ,name 86 | (lambda (%so) 87 | (datum->syntax %so 88 | (let ((%so-d (syntax->datum %so))) 89 | (apply 90 | ,(translate-exp `(lambda ,params ,@body)) 91 | (cdr %so-d)))))))) 92 | 93 | (def-cliiscm-translator lambda (params &rest body) 94 | (let* ((i (1- (list-length params))) 95 | (new-params '()) 96 | (opts nil) 97 | (keys nil)) 98 | (loop 99 | (when (< i 0) (return)) 100 | (let ((param (elt params i))) 101 | (case param 102 | (&optional (setq opts new-params) 103 | (setq new-params '(&rest %lambda-rest-arg))) 104 | (&key (setq keys new-params) 105 | (setq new-params '(&rest %lambda-rest-arg))) 106 | (&rest (unless (= (list-length new-params) 1) (error 'lambda "")) 107 | (push param new-params)) 108 | (t (push param new-params))) 109 | (decf i))) 110 | (let ((last-i (- (list-length new-params) 1))) 111 | (when (and (> last-i 0) (eq (elt new-params (1- last-i)) '&rest)) 112 | (if (= last-i 1) 113 | (setq new-params (elt new-params last-i)) 114 | (let ((new-new-params (butlast new-params 2))) 115 | (setf (cdr (nthcdr (- last-i 2) new-new-params)) (elt new-params last-i)) 116 | (setq new-params new-new-params))))) 117 | (cond (opts 118 | (let ((opts-len (list-length opts))) 119 | `(lambda ,new-params 120 | (let ((%lambda-rest-arg-len (length %lambda-rest-arg)) 121 | ,@(mapcar (lambda (opt) 122 | (if (consp opt) 123 | `(,(car opt) ,(translate-exp (cadr opt))) 124 | `(,opt false))) 125 | opts)) 126 | ,@(let (s 127 | (opts (mapcar (lambda (opt) 128 | (if (consp opt) (car opt) opt)) opts))) 129 | (dotimes (i opts-len) 130 | (setq s 131 | (append s 132 | (list `(when (< ,i %lambda-rest-arg-len) 133 | (set! ,(elt opts i) 134 | (list-ref %lambda-rest-arg ,i))))))) 135 | s) 136 | ,@(translate-implicit-progn body))))) 137 | (keys 138 | `(lambda ,new-params 139 | (let ,(mapcar (lambda (key) 140 | (if (consp key) key 141 | `(,key false))) 142 | keys) 143 | ,@(let (s 144 | (keys (mapcar (lambda (key) 145 | (if (consp key) (car key) key)) keys))) 146 | (dolist (key keys) 147 | (let ((key-word (intern (symbol-name key) :keyword))) 148 | (setq s 149 | (append s 150 | (list `(let ((%key-found (member ',key-word 151 | %lambda-rest-arg))) 152 | (when %key-found 153 | (set! ,key (cadr %key-found))))))))) 154 | s) 155 | ,@(translate-implicit-progn body)))) 156 | (t `(lambda ,new-params 157 | ,@(translate-implicit-progn body)))))) 158 | 159 | (def-cliiscm-translator destructuring-bind (vars exp &rest body) 160 | (translate-exp `(apply (lambda ,vars ,@body) ,exp))) 161 | 162 | (def-cliiscm-translator multiple-value-bind (vars exp &rest body) 163 | (let* ((params '%mvb-rest-arg) 164 | (i (1- (list-length vars)))) 165 | (loop 166 | (when (< i 0) (return)) 167 | (setq params (cons (elt vars i) params)) 168 | (decf i)) 169 | `(apply (lambda ,params ,@(translate-implicit-progn body)) 170 | ,(translate-exp exp)))) 171 | 172 | (defvar *fluid-vars* '()) 173 | 174 | (defun special-var-p (x) 175 | (let* ((x-s (symbol-name x)) 176 | (n (length x-s))) 177 | (and (char= (char x-s 0) #\*) 178 | (char= (char x-s (- n 1)) #\*)))) 179 | 180 | (defun translate-let-binding (x &optional e) 181 | (let ((v (translate-exp e))) 182 | `(,x ,v))) 183 | 184 | (defun translate-let-binding-check-fluid (x &optional e) 185 | (let ((v (translate-exp e))) 186 | (cond ((special-var-p x) 187 | (push x *fluid-vars*) 188 | (let ((x-prime (intern (concatenate 'string "%FLUID-VAR-" (symbol-name x))))) 189 | `(,x-prime ,v))) 190 | (t `(,x ,v))))) 191 | 192 | (def-cliiscm-translator let (vars &rest body) 193 | (if (and (= (length body) 1) 194 | (consp (car body)) (eq (car (car body)) 'defun)) 195 | `(define ,(cadr (car body)) 196 | ,(translate-exp `(let ,vars 197 | (lambda ,(caddr (car body)) 198 | ,@(cdddr (car body)))))) 199 | (if (every #'special-var-p (mapcar (lambda (x) (if (consp x) (car x) x)) vars)) 200 | `(fluid-let ,(mapcar (lambda (x) 201 | (if (consp x) 202 | (translate-let-binding (car x) (cadr x)) 203 | (translate-let-binding x))) 204 | vars) 205 | ,@(translate-implicit-progn body)) 206 | (let ((*fluid-vars* '())) 207 | `(let ,(mapcar 208 | (lambda (x) 209 | (if (consp x) 210 | (translate-let-binding-check-fluid (car x) (cadr x)) 211 | (translate-let-binding-check-fluid x))) 212 | vars) 213 | ,@(if *fluid-vars* 214 | (list 215 | `(fluid-let ,(mapcar (lambda (x) 216 | `(,x ,(intern (concatenate 'string "%FLUID-VAR-" 217 | (symbol-name x))))) 218 | (reverse *fluid-vars*)) 219 | ,@(translate-implicit-progn body))) 220 | (translate-implicit-progn body))))))) 221 | 222 | (def-cliiscm-translator let* (vars &rest body) 223 | (if vars (translate-exp `(let (,(car vars)) (let* ,(cdr vars) ,@body))) 224 | (translate-progn body))) 225 | 226 | (def-cliiscm-translator flet (vars &rest body) 227 | `(let ,(mapcar (lambda (x) 228 | `(,(car x) ,(translate-exp `(lambda ,(cadr x) ,@(cddr x))))) 229 | vars) 230 | ,@(translate-implicit-progn body))) 231 | 232 | (def-cliiscm-translator labels (vars &rest body) 233 | `(letrec ,(mapcar (lambda (x) 234 | `(,(car x) ,(translate-exp `(lambda ,(cadr x) ,@(cddr x))))) 235 | vars) 236 | ,@(translate-implicit-progn body))) 237 | 238 | (def-cliiscm-translator defun (fname params &rest body) 239 | (unless (member fname *defs-to-ignore*) 240 | (let ((lambda-exp (translate-exp `(lambda ,params ,@body)))) 241 | `(define ,(cons fname (cadr lambda-exp)) ,@(cddr lambda-exp))))) 242 | 243 | (def-cliiscm-translator setq (&rest ee) 244 | (let ((assignments ee) s) 245 | (let ((n (length assignments))) 246 | (loop 247 | (when (null assignments) 248 | (return (if (<= n 2) 249 | (car s) 250 | `(begin ,@s)))) 251 | (setq s (append s (list `(set! ,(car assignments) ,(translate-exp (cadr assignments)))))) 252 | (pop assignments) 253 | (pop assignments))))) 254 | 255 | (def-cliiscm-translator progn (&rest ee) 256 | (translate-progn ee)) 257 | 258 | (def-cliiscm-translator function (x) 259 | x) 260 | 261 | ; make a single call to string-append or append? 262 | 263 | (def-cliiscm-translator concatenate (tipe &rest ee) 264 | `(let ((%type ,tipe) 265 | (%ee (list ,@(mapcar #'translate-exp ee)))) 266 | (let ((%res (if (eq? %type 'string) "" null))) 267 | (let %concatenate-loop ((%ee %ee)) 268 | (if (null? %ee) %res 269 | (let ((%a (car %ee))) 270 | (unless (not %a) 271 | (set! %res 272 | (if (eq? %type 'string) 273 | (string-append %res (if (string? %a) %a (list->string %a))) 274 | (append %res (if (string? %a) (string->list %a) %a))))) 275 | (%concatenate-loop (cdr %ee))))) 276 | %res))) 277 | 278 | (def-cliiscm-translator eval-when (&rest ee) 279 | (declare (ignore ee)) 280 | `false) 281 | 282 | (def-cliiscm-translator declaim (&rest ee) 283 | (declare (ignore ee)) 284 | `false) 285 | 286 | (def-cliiscm-translator declare (&rest ee) 287 | (declare (ignore ee)) 288 | `false) 289 | 290 | (def-cliiscm-translator the (tipe val) 291 | (declare (ignore tipe)) 292 | val) 293 | 294 | (def-cliiscm-translator prog1 (e &rest ee) 295 | `(let ((%prog1-first-value ,(translate-exp e))) 296 | ,@(translate-implicit-progn ee) 297 | %prog1-first-value)) 298 | 299 | (def-cliiscm-translator loop (&rest ee) 300 | `(let* ((%loop-returned false) 301 | (%loop-result 0) 302 | (return (lambda %args 303 | (set! %loop-returned true) 304 | (set! %loop-result (and (pair? %args) (car %args)))))) 305 | (let %loop () 306 | ;(set! %loop-result (+ %loop-result 1)) 307 | ;(when (> %loop-result 10000) (error "inf loop?" ',ee)) 308 | ,@(prune-begins 309 | (let (res (n (length ee)) return-found-p) 310 | (dotimes (i n) 311 | (setq res 312 | (append 313 | res 314 | (list 315 | (let ((e (elt ee i))) 316 | (cond (return-found-p 317 | (translate-exp `(unless %loop-returned ,e))) 318 | (t 319 | (when (tree-member 'return e) 320 | (setq return-found-p t)) 321 | (translate-exp e)))))))) 322 | res)) 323 | (if %loop-returned %loop-result (%loop))))) 324 | 325 | (def-cliiscm-translator dotimes (i-n &rest ee) 326 | (let ((i (translate-exp (car i-n))) 327 | (res (caddr i-n))) 328 | `(let ((%dotimes-n ,(translate-exp (cadr i-n))) 329 | (,i 0)) 330 | ,(translate-exp `(loop 331 | (if (>= ,i %dotimes-n) 332 | ,(if (null res) `(return) 333 | `(return ,(translate-exp res)))) 334 | ,@ee 335 | (set! ,i (+ ,i 1))))))) 336 | 337 | (def-cliiscm-translator dolist (x-l &rest ee) 338 | (let ((x (car x-l))) 339 | `(let ((%dolist-l ,(translate-exp (cadr x-l))) 340 | (,x false)) 341 | ,(translate-exp `(loop 342 | (if (null? %dolist-l) (return)) 343 | (set! ,x (car %dolist-l)) 344 | (set! %dolist-l (cdr %dolist-l)) 345 | ,@ee))))) 346 | 347 | (def-cliiscm-translator defparameter (x v) 348 | (unless (member x *defs-to-ignore*) 349 | `(define ,x ,(translate-exp v)))) 350 | 351 | (def-cliiscm-translator defvar (x &optional v) 352 | (unless (member x *defs-to-ignore*) 353 | (if (null v) 354 | `(define ,x false) 355 | `(define ,x ,(translate-exp v))))) 356 | 357 | (def-cliiscm-translator incf (x &optional v) 358 | (translate-exp `(setf ,x (+ ,(translate-exp x) ,(translate-exp (or v 1)))))) 359 | 360 | (def-cliiscm-translator decf (x &optional v) 361 | (translate-exp `(setf ,x (- ,(translate-exp x) ,(translate-exp (or v 1)))))) 362 | 363 | (def-cliiscm-translator setf (&rest ee) 364 | (let* ((assignments ee) 365 | s (n (length assignments))) 366 | (loop 367 | (when (null assignments) 368 | (return (if (<= n 2) 369 | (car s) 370 | `(begin ,@s)))) 371 | (setq s (append s 372 | (list 373 | (let ((lhs (car assignments)) (rhs (cadr assignments))) 374 | (cond ((consp lhs) 375 | (let* ((getter (car lhs)) 376 | (setter (gethash getter *setf-setters*))) 377 | (unless setter 378 | (format t "missing setter for ~s~%" getter)) 379 | `(,setter ,@(mapcar #'translate-exp (cdr lhs)) 380 | ,(translate-exp rhs)))) 381 | (t `(set! ,(translate-exp lhs) ,(translate-exp rhs)))))))) 382 | (pop assignments) 383 | (pop assignments)))) 384 | 385 | (defun translate-case-tags (tags) 386 | (if (consp tags) tags 387 | (list tags))) 388 | 389 | (def-cliiscm-translator cond (&rest clauses) 390 | `(cond ,@(let (output-clauses 391 | (n (length clauses))) 392 | (dotimes (i n) 393 | (let* ((clause (elt clauses i)) 394 | (clause-test (car clause)) 395 | output-clause) 396 | (cond ((and (= i (1- n)) (eq clause-test 'true)) 397 | (setq output-clause 398 | `(else ,@(translate-implicit-progn 399 | (cdr clause))))) 400 | ((and (consp clause-test) (= (length clause-test) 3) 401 | (eq (car clause-test) 'setq)) 402 | (setq output-clause 403 | `((begin ,(translate-exp clause-test) ,(cadr clause-test)) 404 | ,@(translate-implicit-progn (cdr clause))))) 405 | (t 406 | (setq output-clause 407 | `(,(translate-exp clause-test) 408 | ,@(translate-implicit-progn (cdr clause)))))) 409 | (setq output-clauses (append output-clauses (list output-clause))))) 410 | output-clauses))) 411 | 412 | (def-cliiscm-translator if (test then-branch &optional else-branch) 413 | `(if ,(translate-exp test) 414 | ,(translate-exp then-branch) 415 | ,(translate-exp else-branch))) 416 | 417 | (def-cliiscm-translator when (test &rest clauses) 418 | `(when ,(translate-exp test) 419 | ,@(translate-implicit-progn clauses))) 420 | 421 | (def-cliiscm-translator unless (test &rest clauses) 422 | `(unless ,(translate-exp test) 423 | ,@(translate-implicit-progn clauses))) 424 | 425 | (def-cliiscm-translator case (tag &rest clauses) 426 | `(case ,(translate-exp tag) 427 | ,@(let (output-clauses 428 | (n (length clauses))) 429 | (dotimes (i n) 430 | (let* ((clause (elt clauses i)) 431 | (clause-tag (car clause)) 432 | (clause-action (cdr clause)) 433 | output-clause) 434 | (cond ((and (= i (- n 1)) (eq clause-tag 'true)) 435 | (setq output-clause 436 | `(else ,@(translate-implicit-progn clause-action)))) 437 | (t 438 | (setq output-clause 439 | `(,(translate-case-tags clause-tag) 440 | ,@(translate-implicit-progn clause-action))))) 441 | (setq output-clauses (append output-clauses (list output-clause))))) 442 | output-clauses))) 443 | 444 | (def-cliiscm-translator ecase (tag &rest clauses) 445 | (let ((clauses-plus (append clauses (list `(true (error 'ecase "0xdeadc0de")))))) 446 | (translate-exp `(case ,tag ,@clauses-plus)))) 447 | 448 | (defun translate-typecase-tag (tipe) 449 | (case tipe 450 | (character `(char? %tag)) 451 | (number `(number? %tag)) 452 | (string `(string? %tag)) 453 | (else `true))) 454 | 455 | (def-cliiscm-translator typecase (tag &rest clauses) 456 | `(let ((%tag ,(translate-exp tag))) 457 | (cond ,@(let (output-clauses 458 | (n (length clauses))) 459 | (dotimes (i n) 460 | (let* ((clause (elt clauses i)) 461 | (clause-tag (car clause)) 462 | (clause-action (cdr clause)) 463 | output-clause) 464 | (cond ((and (= i (- n 1)) (eq clause-tag 'true)) 465 | (setq output-clause 466 | `(else ,@(translate-implicit-progn 467 | clause-action)))) 468 | (t 469 | (setq output-clause 470 | `(,(translate-typecase-tag clause-tag) 471 | ,@(translate-implicit-progn clause-action))))) 472 | (setq output-clauses (append output-clauses (list output-clause))))) 473 | output-clauses)))) 474 | 475 | (def-cliiscm-translator atom (x) 476 | `(not (pair? ,(translate-exp x)))) 477 | 478 | (def-cliiscm-translator format (where how &rest whats) 479 | (cond ((not where) `(format ,(translate-exp how) ,@(mapcar #'translate-exp whats))) 480 | ((eq where 'true) `(printf ,(translate-exp how) ,@(mapcar #'translate-exp whats))) 481 | (t `(let ((%where ,(translate-exp where))) 482 | (cond ((or (eqv? %where false) (null? %where)) 483 | (format ,(translate-exp how) ,@(mapcar #'translate-exp whats))) 484 | ((eqv? %where true) 485 | (printf ,(translate-exp how) ,@(mapcar #'translate-exp whats))) 486 | (else 487 | (fprintf %where ,(translate-exp how) ,@(mapcar #'translate-exp whats)))))))) 488 | 489 | (def-cliiscm-translator load (f &rest ee) 490 | (if (null ee) 491 | `(load ,(translate-exp f)) 492 | `(let* ((%f ,(translate-exp f)) 493 | (%ee (list ,@(mapcar #'translate-exp ee))) 494 | (%if-does-not-exist (cadr (memv ':if-does-not-exist %ee)))) 495 | (cond ((and (not %if-does-not-exist) (not (file-exists? %f))) false) 496 | (else (load %f)))))) 497 | 498 | (def-cliiscm-translator open (f &rest ee) 499 | (cond ((null ee) 500 | `(open-input-file ,(translate-exp f))) 501 | ((and (eq (list-length ee) 2) (eq (car ee) :direction) 502 | (member (cadr ee) '(:input :output))) 503 | (ecase (cadr ee) 504 | (:input `(open-input-file ,(translate-exp f))) 505 | (:output `(open-output-file ,(translate-exp f))))) 506 | (t 507 | `(let* ((%f ,(translate-exp f)) 508 | (%ee (list ,@(mapcar #'translate-exp ee))) 509 | (%direction (memv ':direction %ee)) 510 | (%if-exists (memv ':if-exists %ee)) 511 | (%if-does-not-exist ':error) 512 | (%if-does-not-exist-from-user (memv ':if-does-not-exist %ee))) 513 | (when %direction 514 | (set! %direction (cadr %direction))) 515 | (when %if-exists 516 | (set! %if-exists (cadr %if-exists))) 517 | (when %if-does-not-exist-from-user 518 | (set! %if-does-not-exist (cadr %if-does-not-exist-from-user))) 519 | (cond ((eqv? %direction ':output) 520 | (when (and (eqv? %if-exists ':supersede) (file-exists? %f)) 521 | (delete-file %f)) 522 | (open-output-file %f)) 523 | ((and (not %if-does-not-exist) (not (file-exists? %f))) false) 524 | (else (open-input-file %f))))))) 525 | 526 | (def-cliiscm-translator close (port) 527 | `(let ((%close-port-arg ,(translate-exp port))) 528 | ((if (input-port? %close-port-arg) close-input-port close-output-port) 529 | %close-port-arg))) 530 | 531 | #| 532 | (def-cliiscm-translator probe-file (f) 533 | `(let ((%probed-file ,(translate-exp f))) 534 | (if (file-exists? %probed-file) %probed-file false))) 535 | |# 536 | 537 | (def-cliiscm-translator with-open-file (open-args &rest body) 538 | (let ((wof-port (car open-args)) 539 | (wof-file (cadr open-args)) 540 | (wof-rest (cddr open-args))) 541 | (let* ((close-port (cond ((and (= (list-length wof-rest) 2) 542 | (eq (car wof-rest) :direction) 543 | (eq (cadr wof-rest) :output)) 544 | 'close-output-port) 545 | (t 'close-input-port))) 546 | (wof-result (if (eq close-port 'close-input-port) 547 | '%with-open-input-file-result '%with-open-output-file-result))) 548 | (translate-exp 549 | `(let* ((,wof-port (open ,wof-file ,@wof-rest)) 550 | (,wof-result (progn ,@body))) 551 | (,close-port ,wof-port) 552 | ,wof-result))))) 553 | 554 | (def-cliiscm-translator with-output-to-string (arg1 &rest body) 555 | (unless (equal arg1 '((current-output-port))) 556 | (error "with-output-to-string first arg has to be (*standard-output*)")) 557 | `(with-output-to-string (lambda () ,@(mapcar #'translate-exp body)))) 558 | 559 | (def-cliiscm-translator position (v s &rest ee) 560 | (let ((has-from-end-p (member :from-end ee)) 561 | (has-start-p (member :start ee))) 562 | (cond ((and has-from-end-p has-start-p) 563 | (error 'position "can't deal with both :from-end and :start")) 564 | (has-from-end-p 565 | `(let ((%position-v ,(translate-exp v)) 566 | (%position-s ,(translate-exp s)) 567 | (%ee (list ,@(mapcar #'translate-exp ee)))) 568 | (cond ((string? %position-s) 569 | (string-reverse-index %position-s %position-v)) 570 | (else 571 | ;not dealing with :from-end for lists 572 | (index-of %position-s %position-v ))))) 573 | (has-start-p 574 | `(let ((%position-v ,(translate-exp v)) 575 | (%position-s ,(translate-exp s)) 576 | (%ee (list ,@(mapcar #'translate-exp ee)))) 577 | (let ((%position-start (cadr (memv ':start %ee)))) 578 | (cond ((string? %position-s) 579 | (let* ((%position-n (string-length %position-s)) 580 | (%position-i (string-index 581 | (substring %position-s 582 | %position-start %position-n) 583 | %position-v))) 584 | (and %position-i (+ %position-start %position-i)))) 585 | (else 586 | ;not dealing with :start for lists 587 | (list-position %position-v %position-s)))))) 588 | (t `(let ((%position-v ,(translate-exp v)) 589 | (%position-s ,(translate-exp s))) 590 | (cond ((string? %position-s) 591 | (string-index %position-s %position-v)) 592 | (else 593 | (list-position %position-v %position-s)))))))) 594 | 595 | (def-cliiscm-translator nth (i ll) 596 | (translate-exp `(list-ref ,ll ,i))) 597 | 598 | (def-cliiscm-translator assoc (v s &rest ee) 599 | (declare (ignore ee)) 600 | `(assoc ,(translate-exp v) ,(translate-exp s))) 601 | 602 | (def-cliiscm-translator member (v s &rest ee) 603 | (declare (ignore ee)) 604 | `(member ,(translate-exp v) ,(translate-exp s))) 605 | 606 | (def-cliiscm-translator delete (v s &rest ee) 607 | (declare (ignore ee)) 608 | `(remove ,(translate-exp v) ,(translate-exp s))) 609 | 610 | (def-cliiscm-translator floor (p &optional q) 611 | (if (null q) 612 | `(inexact->exact (floor ,p)) 613 | `(quotient ,p ,q))) 614 | 615 | (def-cliiscm-translator with-input-from-string (bdg &rest body) 616 | `(call-with-input-string 617 | ,(translate-exp (cadr bdg)) 618 | (lambda (,(car bdg)) ,@(mapcar #'translate-exp body)))) 619 | 620 | (def-cliiscm-translator read (&rest ee) 621 | (if (null ee) 622 | `(read) 623 | `(let ((%read-res (read ,(translate-exp (car ee))))) 624 | (when (eof-object? %read-res) 625 | (set! %read-res ,(translate-exp (caddr ee)))) 626 | %read-res))) 627 | 628 | (def-cliiscm-translator peek-char (x port &rest ee) 629 | (declare (ignore x)) 630 | (if (null ee) 631 | `(peek-char ,(translate-exp port))) 632 | `(let ((%peek-char-res (peek-char ,(translate-exp port)))) 633 | (when (eof-object? %peek-char-res) 634 | (set! %peek-char-res ,(translate-exp (car ee)))) 635 | %peek-char-res)) 636 | 637 | (def-cliiscm-translator read-char (&rest ee) 638 | (if (null ee) 639 | `(read-char) 640 | `(let* ((%read-char-port ,(translate-exp (car ee))) 641 | (%read-char-res (if %read-char-port 642 | (read-char %read-char-port) 643 | (read-char)))) 644 | (when (eof-object? %read-char-res) 645 | (set! %read-char-res ,(translate-exp (caddr ee)))) 646 | %read-char-res))) 647 | 648 | (def-cliiscm-translator read-line (&rest ee) 649 | (if (null ee) 650 | `(read-line) 651 | `(let ((%read-line-res (read-line ,(translate-exp (car ee))))) 652 | (when (eof-object? %read-line-res) 653 | (set! %read-line-res ,(translate-exp (caddr ee)))) 654 | %read-line-res))) 655 | 656 | (def-cliiscm-translator push (v s) 657 | (translate-exp `(setf ,s (cons ,v ,s)))) 658 | 659 | (def-cliiscm-translator pushnew (v s &rest ee) 660 | (declare (ignore ee)) 661 | `(let ((%push-added-value ,(translate-exp v)) 662 | (%push-old-stack ,(translate-exp s))) 663 | (cond ((member %push-added-value %push-old-stack) %push-old-stack) 664 | (else ,@(prune-begins 665 | (list (translate-exp 666 | `(setf ,s (cons %push-added-value %push-old-stack))))))))) 667 | 668 | (def-cliiscm-translator pop (s) 669 | `(let* ((%pop-old-stack ,(translate-exp s)) 670 | (%pop-top-value (car %pop-old-stack))) 671 | ,(translate-exp `(setf ,s (cdr %pop-old-stack))) 672 | %pop-top-value)) 673 | 674 | (def-cliiscm-translator /= (&rest ee) 675 | `(not (= ,@(mapcar #'translate-exp ee)))) 676 | 677 | (def-cliiscm-translator length (s) 678 | `(let ((%length-arg ,(translate-exp s))) 679 | ((if (string? %length-arg) string-length length) %length-arg))) 680 | 681 | (def-cliiscm-translator list-length (s) 682 | `(length ,(translate-exp s))) 683 | 684 | (def-cliiscm-translator intern (s &optional p) 685 | (if (eq p :keyword) 686 | `(string->symbol (string-append ":" ,(translate-exp s))) 687 | `(string->symbol ,(translate-exp s)))) 688 | --------------------------------------------------------------------------------