├── scmxlate-version.tex ├── README.adoc ├── COPYING ├── manifest ├── makefile ├── scm2cl.adoc ├── scmxlate.cl ├── sample.configure ├── mbe-procs.cl ├── clprocs.cl ├── clnames.cl ├── history ├── scm2cl.cl ├── clmacros.cl ├── index.tex └── scmxlate.scm /scmxlate-version.tex: -------------------------------------------------------------------------------- 1 | 20230101% last change 2 | -------------------------------------------------------------------------------- /README.adoc: -------------------------------------------------------------------------------- 1 | = Scmxlate 2 | 3 | Scmxlate is a configuration tool for software packages written in 4 | Scheme. 5 | 6 | For more details, please see https://ds26gte.github.io/scmxlate. 7 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 1997-2003, Dorai Sitaram. 2 | All rights reserved. 3 | 4 | Permission to distribute and use this work for any 5 | purpose is hereby granted provided this copyright 6 | notice is included in the copy. This work is provided 7 | as is, with no warranty of any kind. 8 | -------------------------------------------------------------------------------- /manifest: -------------------------------------------------------------------------------- 1 | COPYING 2 | README 3 | INSTALL 4 | manifest 5 | makefile 6 | scmxlate.scm 7 | scmxlate.cl 8 | index.tex 9 | scm2cl.cl 10 | clnames.cl 11 | clmacros.cl 12 | clprocs.cl 13 | mbe-procs.cl 14 | scm2cl.tex 15 | history 16 | scmxlate-version.tex 17 | sample.configure 18 | README.md 19 | 20 | ;last change: 2014-08-22 21 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | submake = make -f ${HOME}/.www/tex2page/makefile.common 2 | 3 | TRIGGER_FILES = history manifest makefile version.tex \ 4 | scmxlate.scm scmxlate.cl scm2cl.cl \ 5 | scmxlate.tex 6 | 7 | default: 8 | @cat README 9 | 10 | %.html: %.tex 11 | tex2page $(@:%.html=%) 12 | while grep -i "rerun: tex2page" $(@:%.html=%.hlog); do \ 13 | tex2page $(@:%.html=%); \ 14 | done 15 | 16 | scmxlate.html: scmxlate.tex 17 | $(submake) $@ 18 | 19 | scmxlate.pdf: scmxlate.tex 20 | $(submake) $@ 21 | 22 | dist: 23 | $(submake) scmxlate.dist 24 | 25 | html: scmxlate.html scm2cl.html 26 | 27 | pdf: scmxlate.pdf 28 | 29 | dvi: scmxlate.dvi 30 | 31 | %: FORCE 32 | $(submake) $@ 33 | 34 | FORCE: ; 35 | -------------------------------------------------------------------------------- /scm2cl.adoc: -------------------------------------------------------------------------------- 1 | = scm2cl 2 | 3 | (scm2cl is part of the https://github.com/ds26gte/scmxlate[scmxlate distribution].) 4 | 5 | `scm2cl` is a Common Lisp 6 | program that converts Scheme 7 | code to Common Lisp. Its goal is to remove the tedium of 8 | transcribing a large Scheme file into CL, not to avoid human 9 | intervention altogether. You may have to do some 10 | hand-tuning — `scm2cl` will assist you here too. 11 | 12 | `scm2cl` understands R5RS Scheme, including the 13 | high-level macros (`define-syntax`, `let-syntax`, 14 | and `letrec-syntax`), plus some common Scheme 15 | extensions, viz, `andmap`, `append!`, 16 | `call-with-input-string`, 17 | `call-with-output-string`, `delete-file`, `exit`, 18 | `file-exists?`, 19 | `fluid-let`, `flush-output`, `getenv`, `get-output-string`, 20 | `open-input-string`, `open-output-string`, 21 | `ormap`, `read-line`, `reverse!`, 22 | `string-index`, `string-reverse-index`, `system`. 23 | 24 | == Usage 25 | 26 | With some Common Lisp dialects, you can call `scm2cl.cl` 27 | on the operating-system command-line, with the Scheme file 28 | to be converted as argument: 29 | 30 | scm2cl.cl scmfile.scm 31 | 32 | This produces the CL file in `scmfile.cl`. 33 | 34 | If this is not possible, you may load `scm2cl.cl` into 35 | your Common Lisp and invoke the function `scheme-to-cl`. 36 | Eg, 37 | 38 | (load "scm2cl.cl") 39 | (scheme-to-cl "scmfile.scm") 40 | 41 | == Human Intervention 42 | 43 | === `funcall` and `function` 44 | 45 | `scm2cl` is good at inserting `funcall` and `function` 46 | (aka `#’`) where needed, but not perfect. It will, 47 | however, draw your attention to code locations where a 48 | `funcall` _may_ be needed. `scm2cl` will not 49 | miss any of these problem spots, so you don’t have to hunt 50 | for `funcall` locations on your own. 51 | 52 | No similar signaling is offered for potential 53 | `+#’+` locations. 54 | (The reason is that this would lead to too many signals for 55 | `+#’+`, the vast majority of them being red herrings. 56 | Detecting `funcall` is less noisy, but still not perfect 57 | --- which is why `scm2cl` suggests passively instead of 58 | inserting actively.) 59 | 60 | === Some additional definitions 61 | 62 | The CL file produced by `scm2cl` may use some of the 63 | procedures defined in the file 64 | `scheme-procs.cl`. (`scheme-procs.cl` contains some Scheme-like 65 | procedure definitions for CL.) At the end of the 66 | conversion, `scm2cl` will give you the exact list of 67 | Scheme procedures from 68 | `scheme-procs.cl` actually used. You will need to 69 | incorporate these procedure definitions into the 70 | converted code. How you do it is up to your 71 | convenience. 72 | 73 | === Caveats 74 | 75 | Only “escape” continuations are allowed for 76 | `call-with-current-continuation`. 77 | 78 | “Named” ``let``s whose names begin with the substring 79 | `"loop"` are converted into iterative CL loops. 80 | `scm2cl` assumes that such named ``let``s were intended to 81 | write iterative (“tail-recursive”) loops, and translates 82 | accordingly. This will cause error if the `let` wasn’t so 83 | intended. 84 | 85 | Named ``let``s with names that do not begin with `loop` 86 | are converted using CL `labels`. 87 | -------------------------------------------------------------------------------- /scmxlate.cl: -------------------------------------------------------------------------------- 1 | ":";exec clisp -q $0 2 | ":";exec lisp -Q -L $0 3 | 4 | ;last change 2016-12-18 5 | 6 | (defvar *dialect* 'cl) 7 | 8 | (setq *load-verbose* nil) 9 | 10 | #+clisp 11 | (setq *print-pretty* nil) 12 | 13 | (defvar *in-scmxlate* t) 14 | 15 | (defun compile-possible? () t) 16 | 17 | (defmacro define (&rest ee) 18 | `(defvar ,@ee)) 19 | 20 | (load (merge-pathnames "scm2cl" *load-pathname*)) 21 | 22 | (defun eval1 (e) 23 | (eval e)) 24 | 25 | (defvar eval1 #'eval1) 26 | 27 | (defun exists-file? (f) 28 | (probe-file f)) 29 | 30 | (defun ensure-file-deleted (f) 31 | (if (probe-file f) (delete-file f))) 32 | 33 | (defun read-a-line (i) 34 | (read-line i)) 35 | 36 | (defun translate-define-syntax (e) 37 | (format t "~&define-syntax is probably best configured manually: ~s~%" e) 38 | e) 39 | 40 | (defun translate-define-macro (e) 41 | (format t "~&define-macro is probably best configured manually: ~s~%" e) 42 | e) 43 | 44 | (defun writeln (e o) 45 | (pprint 46 | (if *reading-source-file?* 47 | (let ((*scm2cl-bound-vars* '())) 48 | (scm2cl-sexp (nsublis *aliases* e))) 49 | (progn 50 | (when (and (consp e) (eq (car e) 'defun)) 51 | (let ((name (cadr e))) 52 | (push (cons name `(function ,name)) *aliases*))) 53 | (if (and (consp e) (eq (car e) 'define)) 54 | ;silently change define in non-source file 55 | ;to defvar (useful for user-override file 56 | ;that user forgot to change for CL) 57 | `(defvar ,@(cdr e)) 58 | e))) o) 59 | (terpri o)) 60 | 61 | (defun scmxlate-system (c) 62 | 63 | #+(or allegro clisp) 64 | (shell 65 | #+win32 (concatenate 'string "cmd /c " c) 66 | #-win32 c) 67 | 68 | #+(and (or cmu sbcl) unix) 69 | (#+cmu ext:run-program 70 | #+sbcl run-program 71 | "/bin/sh" (list "-c" c)) 72 | 73 | #+ecl 74 | (si:system c) 75 | 76 | #+mkcl 77 | (mkcl:system c) 78 | 79 | #+clozure 80 | (ccl::os-command c) 81 | 82 | #+abcl 83 | (ext:run-shell-command c) 84 | 85 | ) 86 | 87 | (defun chmod+x (f) 88 | #+unix 89 | (let ((f (namestring f))) 90 | (when *shell-script?* 91 | (scmxlate-system 92 | (concatenate 'string "chmod +x " f))))) 93 | 94 | (defun compile-file-to-file (fi fo) 95 | (when (not (pathname-type fi)) 96 | (let ((new-fi (concatenate 'string fi "-temp.lisp"))) 97 | (copy-file-to-file fi new-fi) 98 | (setq fi new-fi))) 99 | (compile-file fi :output-file fo) 100 | fo) 101 | 102 | (with-open-file (i (merge-pathnames 103 | (make-pathname :type "scm") *load-pathname*) 104 | :direction :input) 105 | (loop 106 | (let ((x (read i nil :eof-object))) 107 | (when (eql x :eof-object) (return)) 108 | (when (equal x ''eval-in-cl-also) 109 | (eval (scm2cl-sexp (nsublis *predefined-aliases* 110 | (read i)))))))) 111 | 112 | #+allegro (exit) 113 | #+(or clisp cmu ecl sbcl) (quit) 114 | 115 | #-(or allegro clisp cmu ecl sbcl) 116 | (cond ((fboundp 'bye) (bye)) 117 | ((fboundp 'exit) (exit)) 118 | ((fboundp 'quit) (quit)) 119 | (t (format t "~&You may exit CL now!~%"))) 120 | -------------------------------------------------------------------------------- /sample.configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Last modified: 2014-08-22 4 | 5 | # Set scmxlate to the pathname of scmxlate/scmxlate.scm 6 | # on your system, if you know it. Otherwise let 7 | # this script figure it out. 8 | 9 | scmxlate= 10 | 11 | # Modify searchpathforscmxlate if you think a 12 | # different set of directories should be 13 | # searched for scmxlate/scmxlate.scm. 14 | 15 | searchpathforscmxlate=".. ../.. ../../.. ~ /usr/local /opt" 16 | 17 | findscmxlate() { 18 | test "$scmxlate" && return 19 | echo Trying to find scmxlate/scmxlate.scm on your machine. 20 | echo This may take a while. 21 | for f in $searchpathforscmxlate 22 | do 23 | scmxlate=`find $f -name scmxlate.scm -print|sed 1q` 24 | test "$scmxlate" && return 25 | done 26 | echo Couldn\'t find scmxlate/scmxlate.scm on your machine. 27 | echo Trying to get it off the Internet. 28 | git clone https://github.com/ds26gte/scmxlate 29 | test -d scmxlate &&\ 30 | scmxlate=scmxlate/scmxlate.scm 31 | 32 | test "$scmxlate" && return 33 | echo Unable to get scmxlate off the Internet. 34 | echo scmxlate is available at 35 | echo github.com/ds26gte/scmxlate. 36 | echo The scmxlate manual is at 37 | echo http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html. 38 | echo You may want to get and install scmxlate manually, 39 | echo then try configure again. 40 | exit 41 | } 42 | 43 | adieu() { 44 | for f in `cat dialects/files-to-be-ported.scm` 45 | do 46 | if test -f my-$f 47 | then 48 | echo File my-$f created. 49 | echo You may rename it to $f and 50 | echo \ \ put it in your PATH. 51 | fi 52 | done 53 | } 54 | 55 | makeit() { 56 | findscmxlate 57 | echo Ignore questions on console. 58 | case "$dialect" in 59 | bigloo) 60 | echo bigloo|bigloo -eval '(load "'$scmxlate'")';; 61 | 62 | chicken) 63 | echo chicken|csi $scmxlate;; 64 | 65 | clisp) 66 | clisp -q -i $scmxlate;; 67 | 68 | cmucl) 69 | cmucl -load $scmxlate;; 70 | 71 | gambit) 72 | echo gambit|gsi $scmxlate;; 73 | 74 | gauche) 75 | echo gauche|gosh -l $scmxlate;; 76 | 77 | guile) 78 | echo guile|guile -l $scmxlate;; 79 | 80 | mitscheme) 81 | echo mitscheme|scheme -load $scmxlate;; 82 | 83 | petite) 84 | echo petite|petite $scmxlate;; 85 | 86 | plt) 87 | echo If you are not a PLT developer, you probably shouldn\'t 88 | echo be needing to do this. 89 | echo plt|mzscheme -f $scmxlate;; 90 | 91 | sbcl) 92 | sbcl --load $scmxlate;; 93 | 94 | scm) 95 | echo scm|scm -f $scmxlate;; 96 | 97 | scsh) 98 | echo scsh|scsh -s $scmxlate;; 99 | 100 | sxm) 101 | echo sxm|sxi $scmxlate;; 102 | 103 | *) 104 | echo Dialect $dialect not supported! 105 | exit;; 106 | esac 107 | #adieu 108 | } 109 | 110 | echodialectsuggestions() { 111 | clisppresent= 112 | guilepresent= 113 | test "`which clisp 2>/dev/null|grep -v ' '`" &&\ 114 | clisppresent=yes 115 | test "`which guile 2>/dev/null|grep -v ' '`" &&\ 116 | guilepresent=yes 117 | if test "$clisppresent" -o "$guilepresent" 118 | then 119 | echo 120 | echo Note: The following looks promising on your system: 121 | echo 122 | test "$guilepresent" &&\ 123 | echo \ \ ./configure --dialect=guile 124 | test "$clisppresent" &&\ 125 | echo \ \ ./configure --dialect=clisp 126 | fi 127 | } 128 | 129 | echohelp() { 130 | echo List of dialects supported: 131 | echo 132 | echo clisp cmucl sbcl \ 133 | `grep '^[^;]' dialects/dialects-supported.scm |\ 134 | sed -e 's/^\([^ ]*\).*/\1/'` |\ 135 | sed -e 's/ \ */\n/g' |\ 136 | sort |\ 137 | sed -e '$!N;$!N;$!N;$!N;$!N;s/\n/ /g' |\ 138 | sed -e 's/^/ /g' 139 | 140 | echo 141 | echo If your dialect D is listed above, type 142 | echo \ \ ./configure --dialect=D 143 | echodialectsuggestions 144 | exit 145 | } 146 | 147 | if test 1 -eq `echo $1|grep "^--dialect="|sed 1q|wc -l` 148 | then 149 | dialect=`echo $1|sed 's/--dialect=//'` 150 | if test "$dialect" = "mzscheme" 151 | then 152 | echo Program runs out of the box on MzScheme! 153 | echo You don\'t need to configure anything! 154 | exit 155 | fi 156 | if test "$dialect" = "guile" -a -f ./dialects/make-guile-version 157 | then 158 | ./dialects/make-guile-version 159 | else 160 | makeit 161 | fi 162 | else echohelp 163 | fi 164 | -------------------------------------------------------------------------------- /mbe-procs.cl: -------------------------------------------------------------------------------- 1 | (defun scheme-mbe-ellipsis? (x) 2 | (and (consp x) (consp (cdr x)) (eq (cadr x) '***))) 3 | 4 | (defun scheme-mbe-matches-pattern? (p e k) 5 | (cond ((scheme-mbe-ellipsis? p) 6 | (if (not (= (list-length p) 2)) (error "bad ellipsis: ~a" p)) 7 | (and (scheme-list? e) 8 | (let ((p0 (car p))) 9 | (every #'(lambda (e_i) (scheme-mbe-matches-pattern? p0 e_i k)) 10 | e)))) 11 | ((consp p) 12 | (and (consp e) (scheme-mbe-matches-pattern? (car p) (car e) k) 13 | (scheme-mbe-matches-pattern? (cdr p) (cdr e) k))) 14 | ((scheme-symbol? p) (if (member p k) (eq p e) t)) 15 | (t (equal p e)))) 16 | 17 | (defun scheme-mbe-get-ellipsis-nestings (p k) 18 | (labels ((sub (p) 19 | (cond ((scheme-mbe-ellipsis? p) 20 | (cons (sub (car p)) (sub (cddr p)))) 21 | ((consp p) (nconc (sub (car p)) (sub (cdr p)))) 22 | ((scheme-symbol? p) (if (member p k) '() (list p))) 23 | (t '())))) 24 | (sub p))) 25 | 26 | (defun scheme-mbe-ellipsis-sub-envs (nestings r) 27 | (some #'(lambda (c) 28 | (if (scheme-mbe-intersect? nestings (car c)) (cdr c) nil)) 29 | r)) 30 | 31 | (defun scheme-mbe-intersect? (v y) 32 | (if (or (scheme-symbol? v) (scheme-symbol? y)) 33 | (eq v y) 34 | (some #'(lambda (v_i) 35 | (some #'(lambda (y_j) (scheme-mbe-intersect? v_i y_j)) y)) 36 | v))) 37 | 38 | (defun scheme-mbe-get-bindings (p e k) 39 | (cond ((scheme-mbe-ellipsis? p) 40 | (let ((p0 (car p))) 41 | (list (cons (scheme-mbe-get-ellipsis-nestings p0 k) 42 | (mapcar #'(lambda (e_i) 43 | (scheme-mbe-get-bindings p0 e_i k)) 44 | e))))) 45 | ((consp p) 46 | (nconc (scheme-mbe-get-bindings (car p) (car e) k) 47 | (scheme-mbe-get-bindings (cdr p) (cdr e) k))) 48 | ((scheme-symbol? p) (if (member p k) '() (list (cons p e)))) 49 | (t '()))) 50 | 51 | (defun scheme-mbe-expand-pattern (p r k) 52 | (cond ((scheme-mbe-ellipsis? p) 53 | (nconc (let* ((p0 (car p)) 54 | (nestings (scheme-mbe-get-ellipsis-nestings p0 k)) 55 | (rr (scheme-mbe-ellipsis-sub-envs nestings r))) 56 | (mapcar #'(lambda (r_i) 57 | (scheme-mbe-expand-pattern p0 (append r_i r) k)) 58 | rr)) 59 | (scheme-mbe-expand-pattern (cddr p) r k))) 60 | ((consp p) 61 | (cons (scheme-mbe-expand-pattern (car p) r k) 62 | (scheme-mbe-expand-pattern (cdr p) r k))) 63 | ((scheme-symbol? p) 64 | (if (member p k) p (let ((x (assoc p r))) (if x (cdr x) p)))) 65 | (t p))) 66 | 67 | (defun scheme-mbe-syntax-rules-proc (macro-name kk cc arg-sym kk-sym) 68 | (let ((kk (cons macro-name kk))) 69 | `(let ((,arg-sym (cons ',macro-name ,arg-sym)) 70 | (,kk-sym ',kk)) 71 | (cond ,@(mapcar #'(lambda (c) 72 | (let ((in-pat (car c)) (out-pat (cadr c))) 73 | `((scheme-mbe-matches-pattern? 74 | ',in-pat ,arg-sym ,kk-sym) 75 | (let ((r (scheme-mbe-get-bindings ',in-pat 76 | ,arg-sym 77 | ,kk-sym))) 78 | ,(if (and (consp out-pat) 79 | (eq (car out-pat) 'with)) 80 | `(scheme-mbe-expand-pattern 81 | ',(caddr out-pat) 82 | (nconc (list ,@(mapcar #'(lambda (w) 83 | `(cons ',(car w) 84 | ,(cadr w))) 85 | (cadr out-pat))) 86 | r) 87 | ,kk-sym) 88 | `(scheme-mbe-expand-pattern ',out-pat r 89 | ,kk-sym)))))) 90 | cc) 91 | (t (error "~a: no matching clause" ',macro-name)))))) 92 | -------------------------------------------------------------------------------- /clprocs.cl: -------------------------------------------------------------------------------- 1 | ;This file contains some suggested definitions that you 2 | ;may need to manually load into your 3 | ;scm2cl-generated CL file. 4 | 5 | (defvar *scm2cl-lisp-extension* "lsp") 6 | 7 | ;r5rs 8 | 9 | (defun scheme-assoc (x l) 10 | (assoc x l :test #'equal)) 11 | 12 | (defun scheme-boolean? (o) 13 | (or (eq o t) (eq o nil))) 14 | 15 | (defun scheme-current-input-port () 16 | *standard-input*) 17 | 18 | (defun scheme-current-output-port () 19 | *standard-output*) 20 | 21 | (defun scheme-call-with-input-file (f p) 22 | (with-open-file (i f :direction :input) 23 | (funcall p i))) 24 | 25 | (defun scheme-call-with-output-file (f p) 26 | (with-open-file (o f :direction :output) 27 | (funcall p o))) 28 | 29 | (defun scheme-call-with-values (producer consumer) 30 | (multiple-value-call consumer (funcall producer))) 31 | 32 | (defun scheme-char-whitespace? (c) 33 | (or (char= c #\space) (char= c #\tab) 34 | (not (graphic-char-p c)))) 35 | 36 | (defun scheme-eof-object? (v) 37 | (eq v :eof-object)) 38 | 39 | (defun scheme-eval (exp env) 40 | (eval exp)) 41 | 42 | (defun scheme-list? (o) 43 | (and (listp o) (null (cdr (last o))))) 44 | 45 | (defun scheme-list->string (l) 46 | (concatenate 'string l)) 47 | 48 | (defun scheme-list->vector (l) 49 | (concatenate 'vector l)) 50 | 51 | (defun scheme-make-string (n &optional (c #\space)) 52 | (make-string n :initial-element c)) 53 | 54 | (defun scheme-make-vector (n &optional x) 55 | (make-array (list n) :initial-element x)) 56 | 57 | (defun scheme-member (x l) 58 | (member x l :test #'equal)) 59 | 60 | (defun scheme-not-quite-call/cc (p) 61 | (let ((k (gensym))) 62 | (catch k 63 | (funcall p #'(lambda (v) (throw k v)))))) 64 | 65 | (defun scheme-number->string (n &optional (b 10)) 66 | (write-to-string n :base b)) 67 | 68 | (defun scheme-open-input-file (f) 69 | (open f :direction :input)) 70 | 71 | (defun scheme-open-output-file (f) 72 | (open f :direction :output)) 73 | 74 | (defun scheme-peek-char (&optional p) 75 | (peek-char nil p nil :eof-object)) 76 | 77 | (defun scheme-read (&optional p) 78 | (read p nil :eof-object)) 79 | 80 | (defun scheme-read-char (&optional p) 81 | (read-char p nil :eof-object)) 82 | 83 | (defun scheme-string (&rest z) 84 | (concatenate 'string z)) 85 | 86 | (defun scheme-string-append (&rest z) 87 | (apply #'concatenate 'string z)) 88 | 89 | (defun scheme-string-set! (s i c) 90 | (setf (char s i) c)) 91 | 92 | (defun scheme-string->list (s) 93 | (concatenate 'list s)) 94 | 95 | (defun scheme-string->number (s &optional (b 10)) 96 | (let ((s1 s)) 97 | (if (position #\: s1 :test #'char=) nil 98 | (let ((*read-base* b)) 99 | (let ((n (read-from-string s nil))) 100 | (if (numberp n) n nil)))))) 101 | 102 | (defun scheme-string->symbol (s) 103 | (let ((s (map 'string 104 | #'(lambda (c) (cond ((upper-case-p c) (char-downcase c)) 105 | ((lower-case-p c) (char-upcase c)) 106 | (t c))) s))) 107 | (if (or (string= s "") (not (char= (char s 0) #\:))) 108 | (intern s) 109 | (intern (subseq s 1) :keyword)))) 110 | 111 | (defun scheme-symbol? (o) 112 | (and (symbolp o) 113 | (not (scheme-boolean? o)))) 114 | 115 | (defun scheme-symbol->string (sym) 116 | (string-downcase (symbol-name sym))) 117 | 118 | (defun scheme-vector-set (v i x) 119 | (setf (svref v i) x)) 120 | 121 | (defun scheme-vector->list (v) 122 | (concatenate 'list v)) 123 | 124 | (defun scheme-with-input-from-file (f th) 125 | (with-open-file (i f :direction :input) 126 | (let ((*standard-input* i)) 127 | (funcall th)))) 128 | 129 | (defun scheme-with-output-to-file (f th) 130 | (with-open-file (o f :direction :output) 131 | (let ((*standard-output* o)) 132 | (funcall th)))) 133 | 134 | ;mbe 135 | 136 | (load (merge-pathnames "mbe-procs" *load-pathname*)) 137 | 138 | ;some slib procs 139 | 140 | (defun scheme-read-line (&optional i) 141 | (read-line i nil :eof-object)) 142 | 143 | (defun scheme-call-with-input-string (s p) 144 | (with-input-from-string (i s) 145 | (funcall p i))) 146 | 147 | (defun scheme-call-with-output-string (p) 148 | (with-output-to-string (o) 149 | (funcall p o))) 150 | 151 | (defun scheme-load-relative (f) 152 | (load (merge-pathnames (make-pathname :type *scm2cl-lisp-extension*) 153 | (merge-pathnames f *load-pathname*)))) 154 | 155 | (defun scheme-string-index (s c) 156 | (position c s :test #'char=)) 157 | 158 | (defun scheme-string-reverse-index (s c) 159 | (position c s :test #'char= :from-end t)) 160 | -------------------------------------------------------------------------------- /clnames.cl: -------------------------------------------------------------------------------- 1 | ;name conversions 2 | 3 | ;last change 2017-01-03 4 | 5 | (defvar *scm2cl-fns-named-same* 6 | '( 7 | + 8 | - 9 | * 10 | / 11 | < 12 | = 13 | > 14 | <= 15 | >= 16 | apply 17 | caaar 18 | caadr 19 | caar 20 | cadar 21 | caddr 22 | cadr 23 | car 24 | cdaar 25 | cdadr 26 | cdar 27 | cddar 28 | cdddr 29 | cddr 30 | cdr 31 | cons 32 | ;eval 33 | list 34 | write-char 35 | )) 36 | 37 | (defvar *scm2cl-fns-named-diff* 38 | '( 39 | add1 1+ 40 | andmap every 41 | append! nconc 42 | assoc scheme-assoc 43 | assq assoc 44 | assv assoc 45 | boolean? scheme-boolean? 46 | call-with-current-continuation scheme-not-quite-call/cc 47 | call-with-input-file scheme-call-with-input-file 48 | call-with-input-string scheme-call-with-input-string 49 | call-with-output-file scheme-call-with-output-file 50 | call-with-output-string scheme-call-with-output-string 51 | char->integer char-code 52 | char? characterp 53 | char=? char= 54 | char? char> 56 | char<=? char<= 57 | char>=? char>= 58 | char-ci=? char-equal 59 | char-ci? char-greaterp 61 | char-ci<=? char-not-greaterp 62 | char-ci>=? char-not-lessp 63 | char-lower-case? lower-case-p 64 | char-upper-case? upper-case-p 65 | char-alphabetic? alpha-char-p 66 | char-numeric? digit-char-p 67 | char-whitespace? scheme-char-whitespace? 68 | close-input-port close 69 | close-output-port close 70 | complex? complexp 71 | current-input-port scheme-current-input-port 72 | current-output-port scheme-current-output-port 73 | display princ 74 | eof-object? scheme-eof-object? 75 | eq? eq 76 | equal? equal 77 | eqv? eql 78 | eval scheme-eval 79 | even? evenp 80 | file-exists? probe-file 81 | ;file-or-directory-modify-seconds file-write-date 82 | flush-output force-output 83 | for-each mapc 84 | get-output-string get-output-stream-string 85 | 86 | #+allegro getenv 87 | #+allegro system::getenv 88 | 89 | #+ecl getenv 90 | #+ecl si:getenv 91 | 92 | #+mkcl getenv 93 | #+mkcl mkcl:getenv 94 | 95 | #+clisp getenv 96 | #+clisp ext:getenv 97 | 98 | #+sbcl getenv 99 | #+sbcl sb-ext:posix-getenv 100 | 101 | #+clozure getenv 102 | #+clozure ccl::getenv 103 | 104 | #+abcl getenv 105 | #+abcl ext:getenv 106 | 107 | inexact->exact identity 108 | input-port? input-stream-p 109 | integer? integerp 110 | integer->char code-char 111 | length list-length 112 | list? scheme-list? 113 | list-ref elt 114 | list-tail subseq 115 | list->string scheme-list->string 116 | list->vector scheme-list->vector 117 | load-relative scheme-load-relative 118 | make-string scheme-make-string 119 | make-vector scheme-make-vector 120 | map mapcar 121 | member scheme-member 122 | memq member 123 | memv member 124 | modulo mod 125 | negative? minusp 126 | newline terpri 127 | null? null 128 | number? numberp 129 | number->string scheme-number->string 130 | odd? oddp 131 | open-input-file scheme-open-input-file 132 | open-input-string make-string-input-stream 133 | open-output-file scheme-open-output-file 134 | open-output-string make-string-output-stream 135 | ormap some 136 | pair? consp 137 | peek-char scheme-peek-char 138 | positive? plusp 139 | procedure? functionp;;really? 140 | quotient floor 141 | read scheme-read 142 | read-char scheme-read-char 143 | read-line scheme-read-line 144 | real? realp 145 | reverse! nreverse 146 | set-car! rplaca 147 | set-cdr! rplacd 148 | sort! sort 149 | string scheme-string 150 | string? stringp 151 | string=? string= 152 | string? string> 154 | string<=? string<= 155 | string>=? string>= 156 | string-ci=? string-equal 157 | string-ci? string-greaterp 159 | string-ci<=? string-not-greaterp 160 | string-ci>=? string-not-lessp 161 | string-append scheme-string-append 162 | ;string-index scheme-string-index 163 | string-length length 164 | string->list scheme-string->list 165 | string->number scheme-string->number 166 | string-ref char 167 | ;string-reverse-index scheme-string-reverse-index 168 | string-set! scheme-string-set! 169 | string->symbol scheme-string->symbol 170 | sub1 1- 171 | substring subseq 172 | symbol? scheme-symbol? 173 | symbol->string scheme-symbol->string 174 | 175 | #+(and unix (or allegro clisp)) system 176 | #+(and unix (or allegro clisp)) shell 177 | 178 | #+(and unix clozure) system 179 | #+(and unix clozure) ccl::os-command 180 | 181 | #+(and (or unix darwin) ecl) system 182 | #+(and (or unix darwin) ecl) si:system 183 | 184 | #+abcl system 185 | #+abcl ext:run-shell-command 186 | 187 | transcript-on dribble 188 | transcript-off dribble 189 | vector? vectorp 190 | vector->list scheme-vector->list 191 | vector-ref svref 192 | vector-set! scheme-vector-set 193 | void values 194 | with-input-from-file scheme-with-input-from-file 195 | with-input-from-port scheme-with-input-from-port 196 | with-output-to-file scheme-with-output-to-file 197 | with-output-to-port scheme-with-output-to-port 198 | write prin1 199 | zero? zerop 200 | 201 | )) 202 | 203 | (defvar *scm2cl-kwds-named-diff* 204 | '( 205 | begin progn 206 | cond scm2cl-cond 207 | define-syntax scheme-define-syntax 208 | defstruct scheme-defstruct 209 | else t 210 | fluid-let let 211 | lambda scm2cl-lambda 212 | let scm2cl-let 213 | ;let* scm2cl-let* 214 | let-syntax scheme-let-syntax 215 | letrec-syntax scheme-letrec-syntax 216 | ;loop is a common variable in Scheme. 217 | ;we don't want it to clash with CL's loop macro 218 | loop loop! 219 | set! setq 220 | 221 | false nil 222 | null nil 223 | true t 224 | )) 225 | 226 | (defvar *predefined-aliases* '()) 227 | 228 | (dolist (x *scm2cl-fns-named-same*) 229 | (push (cons x `(function ,x)) *predefined-aliases*)) 230 | 231 | (do ((s *scm2cl-fns-named-diff* (cddr s))) 232 | ((null s)) 233 | (push (cons (car s) `(function ,(cadr s))) *predefined-aliases*)) 234 | 235 | (do ((s *scm2cl-kwds-named-diff* (cddr s))) 236 | ((null s)) 237 | (push (cons (car s) (cadr s)) *predefined-aliases*)) 238 | -------------------------------------------------------------------------------- /history: -------------------------------------------------------------------------------- 1 | Last change: 2014-08-22 2 | 3 | Aug 22, 2014 4 | 5 | No need to temporarily set load to primitive-load for Guile 6 | anymore (?). Bug reported by Andrea Girotto. 7 | 8 | Added to github. Changed sample.configure to refer to github. 9 | 10 | Apr 21, 2012 11 | 12 | Chicken seems to have stopped using getenv since after about v. 13 | 4.6.0. Use get-environment-variable instead, which should work 14 | for older versions too. Rpt by Timothy Beyer. 15 | 16 | Apr 11, 2009 17 | 18 | Updated for Chicken Scheme 4.0.0. 19 | 20 | Apr 10, 2009 21 | 22 | Some support for Armed Bear Common Lisp. However: It abbreviates long 23 | sexprs with "...", which is no use at all. 24 | 25 | Updated for Gambit 4.4.2. 26 | 27 | datum->syntax-object and syntax-object->datum now are named 28 | datum->syntax and syntax->datum. 29 | 30 | Apr 2, 2009 31 | 32 | Scheme quotient == CL floor. 33 | 34 | Mar 31, 2009 35 | 36 | Less verbose translation of cond with =>; and let*. 37 | 38 | Mar 19, 2009 39 | 40 | Some support for Clozure CL. 41 | 42 | Jun 13, 2006 43 | 44 | In previous change, => should have been <= 45 | (greater-than-or-equals). This was causing => in cond to 46 | translate badly. 47 | 48 | May 21, 2006 49 | 50 | clnames.cl: *scm2cl-fns-named-same* should include < = > <= => 51 | 52 | clmacros.lsp: scheme-make-vector typo (should use make-array instead of 53 | make-string). Correction from Jacques Mequin, j-mequin at ti dot com. 54 | 55 | Apr 15, 2005 56 | 57 | getenv => posix-getenv for SBCL 58 | 59 | Apr 12, 2005 60 | 61 | scm2cl changes: 62 | 63 | - Translate cond into cascaded-if only if it contains =>. Otherwise 64 | preserve the cond for readability. 65 | 66 | - Allow eval to take a second argument, which CL will ignore. 67 | 68 | - Recognize + - * / when they appear in non-function-call position. (These 69 | have repl-related values in CL, so caused quite weird bugs, without #' in 70 | front of them!) 71 | 72 | - scm2cl: Catch more instances of automatic funcall insertion. 73 | 74 | Mar 15, 2005 75 | 76 | sample.configure added. Put this file in a scmxlate-configured package and 77 | name it 'configure' 78 | 79 | Allow ((...) ...) in subsexps of if, unless and when. (I.e., funcalls will 80 | be automatically inserted.) 81 | 82 | Sept 8, 2004 83 | 84 | If $COMSPEC is set (i.e., it's a Windows box), and $TERM is cygwin, then 85 | consider OS to be unix. 86 | 87 | July 15, 2003 88 | 89 | CL xln of call-with-output-string bugfixed. 90 | 91 | May 30, 2003 92 | 93 | Allow compile option for Chicken. 94 | 95 | Use date of release instead of (cooked up) version numbers. 96 | 97 | v 1a10a 98 | 99 | May 29, 2003 100 | 101 | Remove predefn of eof for Gauche, as it is 102 | written out as unreadable object. Remove 103 | use of file-mtime as it depends on (use file.util). 104 | 105 | v 1a10 106 | 107 | May 27, 2003 108 | 109 | Alex Shinn supplied configuration for Gauche. 110 | 111 | v 1a9 112 | 113 | Mar 25, 2003 114 | 115 | Translate define-macro into define-syntax for 116 | MzScheme version 200+. 117 | 118 | v 1a8 119 | 120 | Mar 9, 2003 121 | 122 | s/scmxlate-ignore/scmxlate-ignore-define/ 123 | 124 | v 1a7 125 | 126 | Feb 9, 2003 127 | 128 | Use pretty-print for Guile. 129 | 130 | resolve-aliases shouldn't if *reading-source-file?* 131 | 132 | Feb 8, 2003 133 | 134 | scm2cl: Recognize struct-accessors as global functions. 135 | 136 | Use pp (pretty-printer) for MIT Scheme. 137 | 138 | Translate inexact->exact as identity. 139 | 140 | Insert funcalls for top-level expr inside lambda-body 141 | if it begins with two left parens. 142 | 143 | Jan 18, 2003 144 | 145 | with-input-from-port, with-output-to-port 146 | 147 | v 1a6 148 | 149 | Jan 11, 2003 150 | 151 | Allow self-recursions of the sort 152 | 153 | (define fname 154 | (lambda (...) 155 | (... fname (as value) ...))) 156 | 157 | v 1a5 158 | 159 | Dec 15, 2002 160 | 161 | resolve-aliases s/be called only when reading 162 | source file. 163 | 164 | Dec 13, 2002 165 | 166 | current-seconds. 167 | 168 | Remove Scheme file-or-directory-modify-seconds == 169 | CL file-write-date because they have a 70-year 170 | age difference. 171 | 172 | Dec 11, 2002 173 | 174 | Scsh 0.6.2: close-input-port of input string port 175 | says Error: returning zero values when one is expected 176 | (values). Removing it for now. 177 | 178 | Scheme48 won't tolerate \n in strings, even if 179 | it's deadcode! So I can't use \n for newline 180 | in display's argument string. :-( 181 | 182 | v 1a4 183 | 184 | Dec 10, 2002 185 | 186 | STKlos 0.53. 187 | 188 | For CLISP (only), set *print-pretty* to t so calls to 189 | princ inside scmxlate-insert work like Scheme 190 | display with no gratuitous newlines. (info from Sam 191 | Steingold.) 192 | 193 | v 1a3 194 | 195 | Dec 7, 2002 196 | 197 | CL banner uses lisp-implementation-{type,version} 198 | 199 | SBCL 200 | 201 | v 1a2 202 | 203 | Dec 3, 2002 204 | 205 | Support for Chicken added. 206 | 207 | Nov 29, 2002 208 | 209 | Guile 1.6.0's eval can't be called with just one 210 | argument. 211 | 212 | Nov 27, 2002 213 | 214 | MIT Scheme seems to now use syntactic closure macros 215 | rather than syntax-table-define. Accommodate. 216 | 217 | Nov 24, 2002 218 | 219 | Reject compile request for Chez/Petite if 220 | it's really Petite. Use (eqv? (current-eval) 221 | compile) trick suggested by Gustavo Gomez. 222 | 223 | v 1a1 224 | 225 | Nov 24, 2002 226 | 227 | Add code in scm2cl.cl so, when called by itself, 228 | it displays the same version number as scmxlate. 229 | 230 | Nov 23, 2002 231 | 232 | Fix scmxlate's response to a user request for compile. 233 | Shell-magic lines are preserved. CL's compile-file 234 | (or maybe just CLISP's) doesn't seem to allow an 235 | extensionless source filename -- add workaround. 236 | 237 | v 1a 238 | 239 | Nov 23, 2002 240 | 241 | Replace scmxlate-disable-main with 242 | the more general scmxlate-uncall. 243 | 244 | Documentation now covers all relevant 245 | aspects! Version finally jumps to 1! 246 | 247 | Nov 22, 2002 248 | 249 | Replace scmxlate-when with the more versatile 250 | scmxlate-cond. Added scmxlate-eval, so 251 | scmxlate-cond and scmxlate-insert have something 252 | substantial to munch on. 253 | 254 | Nov 21, 2002 255 | 256 | Reduce the number of config files needed in dialects/ 257 | subdiry to one per source file. To this end, add 258 | the following commands: 259 | scmxlate-insert 260 | scmxlate-postamble 261 | scmxlate-postprocess 262 | 263 | v 0o 264 | 265 | Nov 20, 2002 266 | 267 | Added documentation about writing an scmxlate 268 | configuration. (Lots TBD.) 269 | 270 | Shorten some filenames. 271 | s/scm2cl-names/clnames 272 | s/scm2cl-macros/clmacros 273 | s/scheme-procs/clprocs 274 | 275 | Treat #' of local procedure names introduced by 276 | labels (from non-TR named-let) correctly. 277 | 278 | Can't believe scm2cl didn't tackle letrec till 279 | now! I guess I tend to use named-let instead. 280 | 281 | Use scm2cl to translate parts of scmxlate.scm for 282 | scmxlate.cl, so I can concentrate effort on 283 | scmxlate.scm and not worry that scmxlate.cl won't 284 | be up-to-date. 285 | 286 | Nov 19, 2002 287 | 288 | Added scmxlate-when. 289 | 290 | Nov 17, 2002 291 | 292 | Added makefile for my own use. 293 | 294 | v 0n 295 | 296 | Nov 10, 2002 297 | 298 | CL: Translate set! of global vars that were previously 299 | defuns into setf's of symbol-functions. So 300 | (define foo ) followed by (set! foo ) 301 | allows foo to continue to be treated as 302 | a global function albeit with a new value. 303 | Of course, we have to ensure the new value 304 | is also a procedure, but that's probably an ok 305 | restriction. 306 | 307 | Nov 4, 2002 308 | 309 | Check for MzScheme version (< or >= 200) made more 310 | robust. Input from Paul Steckler. 311 | 312 | Nov 1, 2002 313 | 314 | Translate define-syntax into define-macro for PLT 315 | versions before 200. 316 | 317 | v 0m 318 | 319 | 15 Sep 2002 320 | 321 | CL: If first line of file-to-be-ported starts with #, 322 | ignore it. 323 | 324 | CL: Heads of case clause should be pruned of 325 | #'. 326 | 327 | 26 Mar 2002 328 | 329 | scmxlate-rename just renames a symbol in the source. 330 | scmxlate-rename-define furthermore eliminates its 331 | definition in the source. 332 | 333 | 25 Mar 2002 334 | 335 | add *predefined-aliases* that is dialect-dependent 336 | 337 | v 0L1 338 | 339 | 24 Mar 2002 340 | 341 | scmxlate.cl now uses cl pathnames instead of 342 | os-dependent stringy pathnames. (Uses :relative which 343 | isn't in CLtL1 -- I hope this doesn't break on 344 | older CLs) 345 | 346 | scmxlate-disable-main 347 | 348 | 23 Mar 2002 349 | 350 | scmxlate calls translates the cl version of 351 | each sexp rather than scm2cl'ing the entire file 352 | and then translating that result. This allows 353 | scmxlate config for cl (which is written in cl) 354 | to be more natural, ie, it doesn't have to know 355 | what the intermediate cl-translation looks like 356 | 357 | Allow defstructs to be overridden 358 | 359 | Added scmxlate-prefix, scmxlate-include, and allow 360 | scmxlate[-dialect[-os]]-start- in dialects/ 361 | 362 | When renaming x to y, we can also ignore any 363 | definition for x. 364 | 365 | 22 Mar 2002 366 | 367 | Added scmxlate-compile? 368 | as option specifiable in user-override file 369 | 370 | 21 Mar 2002 371 | 372 | Use distinct names: scmxlate-ignore, 373 | scmxlate-rename 374 | 375 | Allow user overrides in file 376 | scmxlate- 377 | 378 | Added scmxlate-target-file, which allows user to set 379 | *target-file*, which can be fruitfully used by 380 | package-writer-supplied configuration code in 381 | dialects/ to make ready-to-run scripts 382 | 383 | v 0L 384 | 385 | 19 Mar 2002 386 | 387 | Included the Scheme-to-Scheme porting mechanism from 388 | tex2page (also schelog) into this (formerly scm2cl) 389 | distribution, and rename latter to scmxlate. It still 390 | contains scm2cl as an independently usable 391 | submodule. scmxlate is thus a general 392 | configuration tool that translates a Scheme package to 393 | a variety of Scheme dialects and Common Lisp. 394 | 395 | --- I include here some history of the porting mechanism 396 | from tex2page. 397 | 398 | --- 16 Mar 2002 399 | 400 | tex2page's to-Common-Lisp porting method made general 401 | (ie, not specific to tex2page), just like the 402 | Scheme-to-Scheme method. 403 | 404 | changes to porting mechanism to help make 405 | it more easily customizable in the 406 | "dialects" directory -- defignore, 407 | defalias. don't wait for user input 408 | if singleton files dialects-supported.scm 409 | and operating-systems-supported.scm found 410 | in dialects/ 411 | 412 | --- 31 Jan 2002 413 | 414 | Scheme 48 415 | 416 | -- 16 Dec 2001 417 | 418 | Low-level define-syntax as implemented in MzScheme. 419 | Convert this to defmacro for dialects that need it. 420 | Thing to note: Petite and SXM's low-level define-syntax is 421 | almost like MzScheme's but with a slightly less 422 | convenient semantics for the procedure datum->syntax-object. 423 | 424 | --- 18 Jan 2001 425 | 426 | SXM, Pocket Scheme 427 | 428 | --- 16 Jan 2001 429 | 430 | Scsh 431 | 432 | --- 13 Dec 2000 433 | 434 | Move porting-related clutter into subdirectory "dialects". 435 | 436 | --- 4 April 1999 437 | 438 | Petite Chez Scheme 439 | 440 | --- 16 April 1998 441 | 442 | MIT Scheme 443 | 444 | --- 14 April 1998 445 | 446 | Guile 447 | 448 | --- 24 April 1997 449 | 450 | Extensible mechanism added for porting to various Scheme dialects 451 | (MzScheme, Gambit). 452 | 453 | --- end of sxmlate pre-history from tex2page 454 | 455 | 16 Mar 2002 456 | 457 | Allow correct lexical shadowing of global 458 | procedure names, where the new value can also be a 459 | procedure. These inner procs will acquire a funcall 460 | since they are not global. 461 | 462 | v 0k3 463 | 464 | 20 Mar 2001 465 | 466 | define translates to defparameter (not defvar) 467 | so a later define overwrites an earlier define 468 | of the same identifier 469 | 470 | v 0k2 471 | 472 | 6 Jan 2001 473 | 474 | (MzScheme) flush-output = (CL) force-output 475 | 476 | Dec 19, 2000 477 | 478 | getenv = system:getenv, for ACL and CLISP 479 | 480 | v 0k1 481 | 482 | Dec 17, 2000 483 | 484 | string->symbol is more Scheme-y. 485 | Leading-colon strings are cvted to keywords. 486 | All-lowercase strings are cvted to all-uppercase 487 | symbols, so symbols can remain unescaped in both 488 | Scheme and CL. In general, a lowercase char 489 | in the string becomes an uppercase char in the 490 | symbol and an uppercase char becomes a lowercase. 491 | ":keyword" -> :keyword 492 | "symbol" -> symbol 493 | "SYMBOL" -> |symbol| 494 | "SyMbOL" -> |sYmBoL| 495 | 496 | v 0k 497 | 498 | Dec 16, 2000 499 | 500 | Allow dotted data in source. 501 | 502 | string->number should work on "" too 503 | (it's defined using read-from-string, which 504 | should return nil on eof instead of erroring) 505 | 506 | struct-setter-p (scm2cl-macros.cl) shouldn't 507 | error on nonsymbols 508 | 509 | v 0j1 510 | 511 | Nov 28, 2000 512 | 513 | labels (xln of named-let) correction. The 514 | args of the procs it introduces shd be 515 | allowed to be procs themselves. 516 | 517 | v 0j 518 | 519 | Nov 23, 2000 520 | 521 | with-input-from-file, with-output-to-file 522 | load-relative 523 | 524 | v 0i 525 | 526 | Nov 2, 2000 527 | 528 | Change CL defmacro's rest arg from just 529 | __syntax-rules-arg__ to 530 | (&rest __syntax-rules-arg__) because CL spec seems (?) 531 | to disallow former. Sugg by Rainer Joswig 532 | (joswig@corporate-world.lisp.de) 533 | 534 | v. 0h 535 | 536 | Apr 2, 2000 537 | 538 | (define x (let ((y ...)) (lambda ...))) converted to 539 | (let ((y ...)) (defun x ...)) 540 | 541 | v. 0g 542 | 543 | Oct 9, 1999 544 | 545 | Procs introduces by an earlier entry in a let* should be 546 | usable in subsequent entries. 547 | 548 | Treat cond-clause that has only one element (which is 549 | both test and then-expression). 550 | 551 | v. 0f 552 | 553 | Oct 3, 1999 554 | 555 | Give uppercase char to set-dispatch-macro-character. 556 | Shouldn't matter ideally, but a version of CLISP choked. 557 | 558 | v. 0e 559 | 560 | Feb 14, 1999 561 | 562 | current-input-port, current-output-port 563 | 564 | v. 0d 565 | 566 | Feb 11, 1999 567 | 568 | A Scheme version of defstruct supported. 569 | 570 | April 27, 1998 571 | 572 | v. 0c 573 | 574 | scheme-procs.cl not included automatically in 575 | translation (it is hardly ever needed). 576 | 577 | Only those named lets whose names begin (rather than 578 | contain) the substring "loop" are converted into CL 579 | loops 580 | 581 | April 18, 1998 582 | 583 | v. 0b 584 | 585 | let-syntax and letrec-syntax treated. 586 | 587 | Made funcall-insertion better by keeping track of 588 | bound variables. 589 | 590 | => in cond recognized. 591 | 592 | April 27, 1997 593 | 594 | v. 0a 595 | -------------------------------------------------------------------------------- /scm2cl.cl: -------------------------------------------------------------------------------- 1 | ":";exec clisp -norc -q -x '(progn (setq *load-verbose* nil) (defvar scheme-file "'$1'") (load "'$0'") (exit))' 2 | ":";exec lisp -e '(defvar scheme-file "'$1'")' -e '(load "'$0'")' -e '(exit)' 3 | 4 | ;scm2cl 5 | ;converts Scheme code to Common Lisp 6 | ;resulting code _must_ be spot-checked 7 | ;Dorai Sitaram 8 | ;April 26, 1997 9 | 10 | ;last change 2009-04-10 11 | 12 | ;Shuffle the ":" lines above so that the one relevant to 13 | ;your Common Lisp dialect is the first line. This will let 14 | ;you use this file as a Unix shellscript. 15 | 16 | ;The line containing clisp is for CLISP. 17 | ;The other line is for Allegro Common Lisp. 18 | 19 | ;You can create your own ":" line for your CL dialect 20 | ;modeled on the above. Even if you're using the abovementioned 21 | ;dialects, the Lisp executable name may be different in 22 | ;your case -- change per need. 23 | 24 | (defvar *scm2cl-lisp-extension* "cl") 25 | 26 | (setq *print-case* :downcase) 27 | (setq *load-verbose* nil) 28 | 29 | ;read #t and #f as t and nil resply 30 | 31 | (set-dispatch-macro-character #\# #\T 32 | #'(lambda (p ig ig2) 33 | (declare (ignore p ig ig2)) 34 | t)) 35 | 36 | (set-dispatch-macro-character #\# #\F 37 | #'(lambda (p ig ig2) 38 | (declare (ignore p ig ig2)) 39 | nil)) 40 | 41 | ;brackets are like parens 42 | 43 | (defun read-bracketed-sexp (i c) 44 | (declare (ignore c)) 45 | (read-delimited-list #\] i t)) 46 | 47 | (set-macro-character #\] (get-macro-character #\) nil)) 48 | (set-macro-character #\[ #'read-bracketed-sexp nil) 49 | 50 | (defvar *in-scmxlate* 51 | ;this would already be t if this file is 52 | ;being loaded by scmxlate 53 | nil) 54 | 55 | (unless *in-scmxlate* 56 | (defvar *scmxlate-version* 57 | (with-open-file (i (merge-pathnames 58 | "scmxlate" 59 | (merge-pathnames 60 | (make-pathname :type "scm") 61 | *load-pathname*))) 62 | (loop 63 | (let ((x (read i nil :eof-object))) 64 | (when (eql x :eof-object) (return)) 65 | (when (and (consp x) 66 | (= (length x) 3) 67 | (eql (car x) 'define) 68 | (eql (cadr x) '*scmxlate-version*)) 69 | (return (caddr x)))))))) 70 | 71 | (load (merge-pathnames "clnames" *load-pathname*)) 72 | 73 | (load (merge-pathnames "clmacros" *load-pathname*)) 74 | 75 | (load (merge-pathnames "clprocs" *load-pathname*)) 76 | 77 | (defvar *scm2cl-procs-used* '()) 78 | 79 | (defvar *scm2cl-bound-vars* '()) 80 | 81 | (defvar *aliases* *predefined-aliases*) 82 | (defvar *local-procedures* '()) 83 | 84 | (defun scheme-to-cl (fi &optional fo) 85 | ;create cl version of scheme file fi in fo 86 | (format t "~&Translating ~a ...~%" fi) 87 | (setq *aliases* *predefined-aliases*) 88 | (unless fo 89 | (setq fo (merge-pathnames (make-pathname :type *scm2cl-lisp-extension*) 90 | fi))) 91 | ; 92 | (with-open-file (i fi :direction :input) 93 | ;discard first line if it contains # 94 | (let ((c (peek-char nil i nil :eof-object))) 95 | (unless (eq c :eof-object) 96 | (if (char= c #\#) (read-line i nil :eof-object)))) 97 | (with-open-file (o fo :direction :output :if-exists :supersede) 98 | ;(pprint '(load "clprocs.cl") o) 99 | (format o "~&;Generated from Scheme source by scm2cl (scmxlate v ~a)~%" *scmxlate-version*) 100 | (format o ";(c) Dorai Sitaram~%") 101 | (format o "; http://www.ccs.neu.edu/~~dorai/scmxlate/scmxlate.html~%") 102 | (let ((*scm2cl-procs-used* '())) 103 | (loop 104 | (let ((x (read i nil :eof-object))) 105 | (if (eq x :eof-object) (return)) 106 | (let* ((*scm2cl-bound-vars* '()) 107 | (xm (scm2cl-sexp 108 | (nsublis *aliases* x)))) 109 | (cond ((not xm) nil) 110 | ((and (consp xm) (eq (car xm) 'progn)) 111 | (dolist (y (cdr xm)) 112 | (if y (pprint y o)))) 113 | (t (pprint xm o))) 114 | (terpri o)))) 115 | (when *scm2cl-procs-used* 116 | (format t "~%~ 117 | The following Scheme procedures in clprocs.cl were used~%") 118 | (#+abcl print #-abcl pprint *scm2cl-procs-used*))))) 119 | ; 120 | (format t "~&Translation written on ~a~%" fo) 121 | ) 122 | 123 | (defun scm2cl-map (f x) 124 | (if (null x) '() 125 | (if (consp x) 126 | (cons (funcall f (car x)) (scm2cl-map f (cdr x))) 127 | (funcall f x)))) 128 | 129 | (defun scm2cl-id (e) 130 | (cond ((consp e) 131 | (let ((a (car e))) 132 | (case a 133 | ((function) (cadr e)) 134 | (t (format t "~&Funny id ~s~%" e) 135 | e)))) 136 | (t e))) 137 | 138 | (defun scm2cl-ids (e) 139 | (cond ((consp e) 140 | (let ((a (car e))) 141 | (case a 142 | ((function) (cadr e)) 143 | (t (mapcar #'scm2cl-id e))))) 144 | (t e))) 145 | 146 | (defun scm2cl-sexp-insert-funcall (e) 147 | (scm2cl-sexp e t)) 148 | 149 | (defun scm2cl-sexp (e &optional insert-funcall-p) 150 | ;transform scheme sexp e into its cl counterpart 151 | (cond ((consp e) 152 | (let ((a (car e))) 153 | (if (consp a) 154 | (let ((aa (car a))) 155 | (case aa 156 | ((function) 157 | (let ((f (cadr a))) 158 | (if (member f *scm2cl-bound-vars*) 159 | (cons 'funcall 160 | (cons f 161 | (mapcar #'scm2cl-sexp-insert-funcall 162 | (cdr e)))) 163 | (let ((xfmr (gethash f *scm2cl-macros*))) 164 | (if xfmr 165 | (scm2cl-sexp (apply xfmr (cdr e))) 166 | (cons f 167 | (mapcar #'scm2cl-sexp-insert-funcall 168 | (cdr e)))))))) 169 | ((scm2cl-lambda) 170 | (cons 171 | (scm2cl-sexp 172 | (cons 'scm2cl-functionless-lambda (cdr a))) 173 | (mapcar #'scm2cl-sexp-insert-funcall (cdr e)))) 174 | ((case cond if when unless) 175 | (cons 'funcall 176 | (mapcar #'scm2cl-sexp-insert-funcall 177 | e))) 178 | (t 179 | (if insert-funcall-p 180 | (cons 'funcall 181 | (mapcar #'scm2cl-sexp-insert-funcall e)) 182 | (progn 183 | (unless (eq aa 'scm2cl-lambda) 184 | (format t "~&Possible funcall at ~s~%" e)) 185 | (scm2cl-map #'scm2cl-sexp-insert-funcall e)))))) 186 | (let ((xfmr (gethash a *scm2cl-macros*))) 187 | (if xfmr (scm2cl-sexp (apply xfmr (cdr e))) 188 | (cond ((eq a 'case) 189 | `(case ,(scm2cl-sexp-insert-funcall (cadr e)) 190 | ,@(mapcar 191 | #'(lambda (c) 192 | `(,(scm2cl-ids (car c)) 193 | ,@(mapcar #'scm2cl-sexp-insert-funcall 194 | (cdr c)))) 195 | (cddr e)))) 196 | ((eq a 'cond) 197 | `(cond ,@(mapcar 198 | #'(lambda (c) 199 | (mapcar #'scm2cl-sexp-insert-funcall 200 | c)) 201 | (cdr e)))) 202 | ((member a '(flet multiple-value-setq)) 203 | ;generated by named let (tr) 204 | `(,a ,(cadr e) 205 | ,@(mapcar #'scm2cl-sexp-insert-funcall 206 | (cddr e)))) 207 | ((eq a 'lambda) 208 | `(lambda ,(cadr e) 209 | ,@(let ((*scm2cl-bound-vars* 210 | (append (cadr e) *scm2cl-bound-vars*))) 211 | (mapcar 212 | #'scm2cl-sexp-insert-funcall 213 | (cddr e))))) 214 | ((member a '(if unless when)) 215 | `(,a ,@(mapcar #'scm2cl-sexp-insert-funcall 216 | (cdr e)))) 217 | ((eq a 'defun) 218 | (let ((bvv (caddr e))) 219 | `(defun ,(cadr e) ,bvv 220 | ,@(let ((*scm2cl-bound-vars* 221 | (append bvv *scm2cl-bound-vars*))) 222 | (mapcar #'scm2cl-sexp-insert-funcall 223 | (cdddr e)))))) 224 | ((eq a 'setq) 225 | (let ((x (cadr e))) 226 | (if (and (consp x) (eq (car x) 'function)) 227 | `(setf (symbol-function ',(cadr x)) 228 | ,(scm2cl-sexp (caddr e))) 229 | `(setq ,x 230 | ,(scm2cl-sexp-insert-funcall 231 | (caddr e)))))) 232 | ((and (eq a 'progn) (= (length e) 2)) 233 | (scm2cl-sexp-insert-funcall (cadr e))) 234 | ((eq a 'let) ;(member a '(let let*)) 235 | `(let ,(mapcar 236 | #'(lambda (xv) 237 | `(,(scm2cl-id (car xv)) 238 | ,(scm2cl-sexp-insert-funcall (cadr xv)))) 239 | (cadr e)) 240 | ,@(let ((*scm2cl-bound-vars* 241 | (append (mapcar 242 | #'(lambda (xv) 243 | (scm2cl-id (car xv))) 244 | (cadr e)) 245 | *scm2cl-bound-vars*))) 246 | (mapcar #'scm2cl-sexp-insert-funcall 247 | (cddr e))))) 248 | ((eq a 'let*) 249 | `(let* ,(let ((xvxv (cadr e)) (r '()) 250 | (*scm2cl-bound-vars* *scm2cl-bound-vars*)) 251 | (loop 252 | (unless xvxv (return (nreverse r))) 253 | (destructuring-bind (x v) (pop xvxv) 254 | (let ((x (scm2cl-id x))) 255 | (push `(,x ,(scm2cl-sexp-insert-funcall v)) r) 256 | (push x *scm2cl-bound-vars*))))) 257 | ,@(let ((*scm2cl-bound-vars* 258 | (append (mapcar (lambda (xv) (scm2cl-id (car xv))) (cadr e)) 259 | *scm2cl-bound-vars*))) 260 | (mapcar #'scm2cl-sexp-insert-funcall (cddr e))))) 261 | ((eq a 'labels) 262 | (let ((*local-procedures* *local-procedures*)) 263 | (mapcar #'(lambda (label-init) 264 | (push (car label-init) 265 | *local-procedures*)) 266 | (cadr e)) 267 | `(,a ,(mapcar 268 | #'(lambda (label-init) 269 | (let ((bvv (cadr label-init))) 270 | `(,(scm2cl-id 271 | (scm2cl-sexp (car label-init))) 272 | ,(mapcar #'scm2cl-sexp bvv) 273 | ,@(let ((*scm2cl-bound-vars* 274 | (append bvv 275 | *scm2cl-bound-vars* 276 | ) 277 | )) 278 | (mapcar #'scm2cl-sexp 279 | (cddr label-init)))))) 280 | (cadr e)) 281 | ,@(mapcar #'scm2cl-sexp-insert-funcall 282 | (cddr e))))) 283 | ((eq a 'with-open-file) 284 | `(,a ,(mapcar #'scm2cl-sexp (cadr e)) 285 | ,@(mapcar #'scm2cl-sexp-insert-funcall 286 | (cddr e)))) 287 | ((eq a 'quote) 288 | (let ((quotee (cadr e))) 289 | (if (and (consp quotee) 290 | (eql (car quotee) 'function)) 291 | (list 'quote (cadr quotee)) 292 | e))) 293 | ((member a '(define-macro)) 294 | (format t "~&Skipping ~a ~a~%" a (cadr e)) 295 | nil) 296 | ((and (struct-setter-p a) (= (length e) 3)) 297 | `(setf (,(struct-getter a) ,(scm2cl-sexp (cadr e))) 298 | ,(scm2cl-sexp (caddr e)))) 299 | ((struct-maker-p e) 300 | (cons a (mapcar #'scm2cl-sexp 301 | (keywordize-fieldnames (cdr e))))) 302 | ((member a *scm2cl-bound-vars*) 303 | (cons 'funcall (mapcar #'scm2cl-sexp e))) 304 | ((member a *local-procedures*) 305 | (cons (scm2cl-id (scm2cl-sexp a)) 306 | (mapcar #'scm2cl-sexp (cdr e)))) 307 | (t (scm2cl-map #'scm2cl-sexp e)))))))) 308 | ((symbolp e) 309 | (if (eql (search "SCHEME-" (symbol-name e)) 0) 310 | (pushnew e *scm2cl-procs-used*)) 311 | (if (member e *local-procedures*) 312 | `(function ,e) 313 | e)) 314 | (t e))) 315 | 316 | ;(trace scm2cl-sexp) 317 | 318 | (when (boundp 'scheme-file) 319 | ;if this file is being used as a shellscript, 320 | ;convert its first arg, which is a scheme file 321 | (let ((cl-file 322 | (merge-pathnames (make-pathname :type *scm2cl-lisp-extension*) 323 | scheme-file))) 324 | (format t "~&This is scm2cl (scmxlate v ~a)~%" *scmxlate-version*) 325 | (scheme-to-cl scheme-file cl-file) 326 | )) 327 | 328 | ;(trace scm2cl-sexp) 329 | -------------------------------------------------------------------------------- /clmacros.cl: -------------------------------------------------------------------------------- 1 | ;translator macros 2 | 3 | ;last change 2017-01-03 4 | 5 | (defvar *scm2cl-macros* (make-hash-table)) 6 | 7 | (defvar *scm2cl-gentemp-prefix* "Scheme-to-CL-") 8 | 9 | (defmacro defmacro-scm2cl (name args &rest body) 10 | `(setf (gethash ',name *scm2cl-macros*) 11 | #'(lambda ,args ,@body))) 12 | 13 | (defmacro-scm2cl scm2cl-lambda (args &rest body) 14 | `(function 15 | (lambda ,(scm2cl-dot-to-rest args) ,@body))) 16 | 17 | (defmacro-scm2cl scm2cl-functionless-lambda (args &rest body) 18 | `(lambda ,(scm2cl-dot-to-rest args) ,@body)) 19 | 20 | (defun scm2cl-dot-to-rest (vv) 21 | (if (null vv) nil 22 | (if (symbolp vv) `(&rest ,vv) 23 | (let* ((l (last vv)) 24 | (d (cdr l))) 25 | (unless (null d) 26 | (setf (cdr l) `(&rest ,d))) 27 | vv)))) 28 | 29 | (defmacro-scm2cl 30 | define (x &rest ee) 31 | (let (new-alias-cell (e (car ee))) 32 | (cond ((and (consp x) (eq (car x) 'function)) 33 | (setq x (cadr x))) 34 | ;remaining clauses add definee to 35 | ;*aliases* 36 | ((consp x) 37 | (let ((f (car x))) 38 | (setq new-alias-cell (cons f `(function ,f))) 39 | (push new-alias-cell *aliases*))) 40 | ((and (consp e) (eq (car e) 'scm2cl-lambda)) 41 | (setq new-alias-cell (cons x `(function ,x))) 42 | (push new-alias-cell *aliases*)) 43 | ((and (consp e) (= (length e) 3) 44 | (eq (car e) 'scm2cl-let) (eq (car (caddr e)) 'scm2cl-lambda)) 45 | (setq new-alias-cell (cons x `(function ,x))) 46 | (push new-alias-cell *aliases*))) 47 | ; 48 | (if (and (symbolp x) (cdr ee)) 49 | (error "bad define: ~s" (cons 'define (cons x ee)))) 50 | ; 51 | ;follg to allow self-recursion 52 | (when new-alias-cell 53 | (setq ee 54 | (nsublis (list new-alias-cell) ee)) 55 | (setq e (car ee))) 56 | ; 57 | (cond ((and (symbolp x) (consp e) (eq (car e) 'scm2cl-lambda)) 58 | `(defun ,x ,(scm2cl-dot-to-rest (cadr e)) ,@(cddr e))) 59 | ((and (symbolp x) (consp e) (= (length e) 3) 60 | (eq (car e) 'scm2cl-let) 61 | (eq (car (caddr e)) 'scm2cl-lambda)) 62 | `(scm2cl-let ,(cadr e) 63 | (define ,x ,(caddr e)))) 64 | ((consp x) 65 | `(defun ,(car x) ,(scm2cl-dot-to-rest (cdr x)) ,@ee)) 66 | (t `(defparameter ,x ,e))))) 67 | 68 | (defmacro-scm2cl scm2cl-let (n &rest ee) 69 | (if (and n (symbolp n)) 70 | (let ((tail-recursive-p (search "LOOP" (symbol-name n)))) 71 | `(,(if (and tail-recursive-p (= tail-recursive-p 0)) 72 | 'scm2cl-named-let-tr 73 | 'scm2cl-named-let-non-tr) ,n ,@ee)) 74 | `(let ,n ,@ee))) 75 | 76 | (defmacro-scm2cl letrec (xvxv &rest ee) 77 | `(let ,(mapcar #'(lambda (xv) `(,(car xv) 'void)) xvxv) 78 | ,@(mapcar #'(lambda (xv) (cons 'setq xv)) xvxv) 79 | ,@ee)) 80 | 81 | (defmacro-scm2cl scm2cl-named-let-non-tr (n xvxv &rest ee) 82 | `(labels ((,n ,(mapcar #'car xvxv) ,@ee)) 83 | (,n ,@(mapcar #'cadr xvxv)))) 84 | 85 | (defmacro-scm2cl scm2cl-named-let-tr (n xvxv &rest ee) 86 | (let ((xx (mapcar #'car xvxv))) 87 | `(let ,xvxv 88 | (flet ((,n ,xx 89 | (throw ',n (values ,@xx)))) 90 | (loop 91 | (multiple-value-setq ,xx 92 | (let ,(mapcar #'(lambda (x) `(,x ,x)) xx) 93 | (catch ',n 94 | (return ,(if (= (length ee) 1) (car ee) 95 | (cons 'progn ee))))))))))) 96 | 97 | (defmacro-scm2cl scm2cl-cond (&rest clauses) 98 | (if (some #'(lambda (clause) 99 | (and (>= (length clause) 2) 100 | (eq (cadr clause) '=>))) clauses) 101 | `(scm2cl-cond-with-arrow ,@clauses) 102 | `(scm2cl-cond-without-arrow ,@clauses))) 103 | 104 | (defun scm2cl-cond-with-arrow-aux (clause) 105 | (if (not (and (= (length clause) 3) 106 | (eq (elt clause 1) '=>))) 107 | clause 108 | `((setq __test__ ,(elt clause 0)) 109 | (funcall ,(elt clause 2) __test__)))) 110 | 111 | (defmacro-scm2cl scm2cl-cond-with-arrow (&rest clauses) 112 | (let ((n (length clauses))) 113 | (if (= n 0) 'nil 114 | (let ((last-clause (elt clauses (1- n)))) 115 | (when (eq (car last-clause) 'else) 116 | (setf (car last-clause) 't)) 117 | `(let ((__test__ nil)) 118 | (cond ,@(mapcar #'scm2cl-cond-with-arrow-aux clauses))))))) 119 | 120 | 121 | (defmacro-scm2cl scm2cl-cond-without-arrow (&rest clauses) 122 | (let ((n (length clauses))) 123 | (if (= n 0) 'nil 124 | (let ((last-clause (elt clauses (1- n)))) 125 | (when (eq (car last-clause) 'else) 126 | (setf (car last-clause) 't)) 127 | `(cond ,@clauses))))) 128 | 129 | (defmacro-scm2cl scheme-defstruct (name &rest fields) 130 | (mapc #'(lambda (field) 131 | (when (consp field) (setq field (car field))) 132 | (let ((constructor 133 | (intern (concatenate 'string (symbol-name name) "." 134 | (symbol-name field))))) 135 | (push (cons constructor `(function ,constructor)) 136 | *aliases*))) 137 | fields) 138 | `(defstruct ,name ,@fields) 139 | ) 140 | 141 | (defun struct-setter-p (x) 142 | (and x (symbolp x) 143 | (let ((xs (symbol-name x))) 144 | (and (> (length xs) 4) 145 | (eql (search "SET!" xs) 0))))) 146 | 147 | (defun struct-getter (setter-name) 148 | (intern (subseq (symbol-name setter-name) 4))) 149 | 150 | (defun struct-maker-p (call) 151 | (and (oddp (length call)) 152 | (let ((fn (car call))) 153 | (and (symbolp fn) 154 | (let ((fns (symbol-name fn))) 155 | (and (> (length fns) 5) 156 | (eql (search "MAKE-" fns) 0) 157 | (progn (pop call) 158 | (loop 159 | (if (null call) (return t)) 160 | (let ((f (pop call))) 161 | (unless (and (consp f) 162 | (= (length f) 2) 163 | (eq (car f) 'quote)) 164 | (return nil)) 165 | (pop call)))))))))) 166 | 167 | (defun keywordize-fieldnames (args) 168 | (let ((s '())) 169 | (loop 170 | (when (null args) (return)) 171 | (push (intern (symbol-name (cadr (pop args))) 172 | :keyword) s) 173 | (push (pop args) s) 174 | ) 175 | (nreverse s))) 176 | 177 | '(defmacro-scm2cl scheme-define-macro (name xfmr) 178 | ;MzScheme's define-macro 179 | (unless (eq (car xfmr) 'lambda) 180 | (error "scheme-define-macro ~s ~s" name xfmr)) 181 | `(defmacro ,name ,@(cdr xfmr))) 182 | 183 | ;mbe 184 | 185 | (defmacro-scm2cl scheme-define-syntax (macroname synrules) 186 | (let ((keywords (cadr synrules)) 187 | (clauses (cddr synrules))) 188 | `(defmacro ,macroname (&rest __syntax-rules-arg__) 189 | ,(scheme-mbe-syntax-rules-proc macroname keywords clauses 190 | '__syntax-rules-arg__ 191 | '__syntax-rules-keywords__)))) 192 | 193 | (defmacro-scm2cl scheme-letrec-syntax (synruledefs &rest body) 194 | `(macrolet 195 | ,(mapcar #'(lambda (synruledef) 196 | (let ((macroname (car synruledef)) 197 | (keywords (cadadr synruledef)) 198 | (clauses (cddadr synruledef))) 199 | `(,macroname (&rest __syntax-rules-arg__) 200 | ,(scheme-mbe-syntax-rules-proc macroname 201 | keywords 202 | clauses 203 | '__syntax-rules-arg__ 204 | '__syntax-rules-keywords__)))) 205 | synruledefs) 206 | ,@body)) 207 | 208 | ;Actually, CL can't distinguish let- from letrec-syntax very well. 209 | 210 | (defmacro-scm2cl scheme-let-syntax (synruledefs &rest body) 211 | (case (length synruledefs) 212 | ((0) `(progn ,@body)) 213 | ((1) `(letrec-syntax ,synruledefs ,@body)) 214 | (otherwise 215 | `(letrec-syntax (,(car synruledefs)) 216 | (let-syntax ,(cdr synruledefs) 217 | ,@body))))) 218 | 219 | ;;don't load mbe.cl if not available. this feature needed 220 | ;;because scm2cl is used to create mbe.cl from mbe.scm 221 | 222 | '(load (merge-pathnames "mbe" *load-pathname*) 223 | :if-does-not-exist nil) 224 | 225 | ;inline some scheme procedure calls 226 | 227 | (defmacro-scm2cl scheme-eval (x &rest etc) 228 | `(eval ,x)) 229 | 230 | (defmacro-scm2cl scheme-assoc (x l) 231 | `(assoc ,x ,l :test #'equal)) 232 | 233 | (defmacro-scm2cl scheme-boolean? (o) 234 | `(case ,o 235 | ((t nil) t) 236 | (t nil))) 237 | 238 | (defmacro-scm2cl scheme-current-input-port () 239 | `*standard-input*) 240 | 241 | (defmacro-scm2cl scheme-current-output-port () 242 | `*standard-output*) 243 | 244 | (defmacro-scm2cl scheme-call-with-input-file (f p) 245 | (if (and (consp p) (eq (car p) 'scm2cl-lambda)) 246 | `(with-open-file (,(caadr p) ,f :direction :input) 247 | ,@(cddr p)) 248 | (let ((i (gentemp *scm2cl-gentemp-prefix*))) 249 | `(with-open-file (,i ,f :direction :input) 250 | (funcall ,p ,i))))) 251 | 252 | (defmacro-scm2cl scheme-call-with-output-file (f p) 253 | (if (and (consp p) (eq (car p) 'scm2cl-lambda)) 254 | `(with-open-file (,(caadr p) ,f :direction :output) 255 | ,@(cddr p)) 256 | (let ((o (gentemp *scm2cl-gentemp-prefix*))) 257 | `(with-open-file (,o ,f :direction :output) 258 | (funcall ,p ,o))))) 259 | 260 | (defmacro-scm2cl scheme-char-whitespace? (c) 261 | (let ((c1 (gentemp *scm2cl-gentemp-prefix*))) 262 | `(let ((,c1 ,c)) 263 | (or (char= ,c1 #\space) (char= ,c1 #\tab) 264 | (not (graphic-char-p ,c1)))))) 265 | 266 | (defmacro-scm2cl scheme-eof-object? (v) 267 | `(eq ,v :eof-object)) 268 | 269 | (defmacro-scm2cl scheme-list->string (l) 270 | `(concatenate 'string ,l)) 271 | 272 | (defmacro-scm2cl scheme-list->vector (l) 273 | `(concatenate 'vector l)) 274 | 275 | (defmacro-scm2cl scheme-make-string (n &optional c) 276 | `(make-string ,n :initial-element 277 | ,(if c c #\space))) 278 | 279 | (defmacro-scm2cl scheme-make-vector (n &optional x) 280 | `(make-array ,n :initial-element ,x)) 281 | 282 | (defmacro-scm2cl scheme-member (x l) 283 | `(member ,x ,l :test #'equal)) 284 | 285 | (defmacro-scm2cl scheme-not-quite-call/cc (p) 286 | (let ((k (gentemp *scm2cl-gentemp-prefix*))) 287 | ;had to use gentemp above because we're writing 288 | ;expansion into file 289 | `(let ((,k (gensym))) 290 | (catch ,k 291 | ,(if (and (consp p) (eq (car p) 'scm2cl-lambda)) 292 | `(,p #'(lambda (v) (throw ,k v))) 293 | `(funcall ,p #'(lambda (v) (throw ,k v)))))))) 294 | 295 | (defmacro-scm2cl scheme-number->string (n &optional b) 296 | `(write-to-string ,n 297 | ,@(if b `(:base ,b) '()))) 298 | 299 | (defmacro-scm2cl scheme-open-input-file (f) 300 | `(open ,f :direction :input)) 301 | 302 | (defmacro-scm2cl scheme-open-output-file (f) 303 | `(open ,f :direction :output)) 304 | 305 | (defmacro-scm2cl scheme-peek-char (&optional p) 306 | `(peek-char nil ,p nil :eof-object)) 307 | 308 | (defmacro-scm2cl scheme-read (&optional p) 309 | `(read ,p nil :eof-object)) 310 | 311 | (defmacro-scm2cl scheme-read-char (&optional p) 312 | `(read-char ,p nil :eof-object)) 313 | 314 | (defmacro-scm2cl scheme-string (&rest cc) 315 | `(concatenate 'string (list ,@cc))) 316 | 317 | (defmacro-scm2cl scheme-string-append (&rest ss) 318 | `(concatenate 'string ,@ss)) 319 | 320 | (defmacro-scm2cl scheme-string-set! (s i c) 321 | `(setf (char ,s ,i) ,c)) 322 | 323 | (defmacro-scm2cl scheme-string->list (s) 324 | `(concatenate 'list ,s)) 325 | 326 | (defmacro-scm2cl scheme-string->number (s &optional b) 327 | (let ((s1 (gentemp *scm2cl-gentemp-prefix*)) 328 | (n (gentemp *scm2cl-gentemp-prefix*))) 329 | (if b 330 | `(let ((,s1 ,s)) 331 | (if (position #\: ,s1 :test #'char=) nil 332 | (let* ((*read-base* ,b) 333 | (,n (read-from-string ,s1 nil))) 334 | (if (numberp ,n) ,n nil)))) 335 | `(let ((,s1 ,s)) 336 | (if (position #\: ,s1 :test #'char=) nil 337 | (let ((,n (read-from-string ,s1 nil))) 338 | (if (numberp ,n) ,n nil))))))) 339 | 340 | (defmacro-scm2cl scheme-string->symbol (s) 341 | (let ((s1 (gentemp *scm2cl-gentemp-prefix*))) 342 | `(let ((,s1 (map 'string 343 | #'(lambda (c) (cond ((upper-case-p c) (char-downcase c)) 344 | ((lower-case-p c) (char-upcase c)) 345 | (t c))) ,s))) 346 | (if (or (string= ,s1 "") (not (char= (char ,s1 0) #\:))) 347 | (intern ,s1) 348 | (intern (subseq ,s1 1) :keyword))))) 349 | 350 | (defmacro-scm2cl scheme-symbol? (x) 351 | (let ((x1 (gentemp *scm2cl-gentemp-prefix*))) 352 | `(let ((,x1 ,x)) 353 | (and (symbolp ,x1) 354 | (not (or (eq ,x1 t) (eq ,x1 nil))))))) 355 | 356 | (defmacro-scm2cl scheme-symbol->string (x) 357 | `(string-downcase (symbol-name ,x))) 358 | 359 | (defmacro-scm2cl scheme-vector-set! (v i x) 360 | `(setf (svref ,v ,i) ,x)) 361 | 362 | (defmacro-scm2cl scheme-vector->list (v) 363 | `(concatenate 'list ,v)) 364 | 365 | (defmacro-scm2cl scheme-with-input-from-file (f th) 366 | `(with-open-file (__temp-input-port ,f :direction :input) 367 | (let ((*standard-input* __temp-input-port)) 368 | (funcall ,th)))) 369 | 370 | (defmacro-scm2cl scheme-with-output-to-file (f th) 371 | `(with-open-file (__temp-output-port ,f :direction :output) 372 | (let ((*standard-output* __temp-output-port)) 373 | (funcall ,th)))) 374 | 375 | ;slib 376 | 377 | (defmacro-scm2cl scheme-with-output-to-port (p th) 378 | `(let ((*standard-output* ,p)) 379 | (funcall ,th))) 380 | 381 | (defmacro-scm2cl scheme-with-input-from-port (p th) 382 | `(let ((*standard-input* ,p)) 383 | (funcall ,th))) 384 | 385 | (defmacro-scm2cl scheme-call-with-input-string (s p) 386 | (if (and (consp p) (eq (car p) 'scm2cl-lambda)) 387 | `(with-input-from-string (,(caadr p) ,s) 388 | ,@(cddr p)) 389 | (let ((i (gentemp *scm2cl-gentemp-prefix*))) 390 | `(with-input-from-string (,i ,s) 391 | (funcall ,p ,i))))) 392 | 393 | (defmacro-scm2cl scheme-call-with-output-string (p) 394 | (if (and (consp p) (eq (car p) 'scm2cl-lambda)) 395 | `(with-output-to-string (,(caadr p)) 396 | ,@(cddr p)) 397 | (let ((o (gentemp *scm2cl-gentemp-prefix*))) 398 | `(with-output-to-string (,o) 399 | (funcall ,p ,o))))) 400 | 401 | (defmacro-scm2cl scheme-load-relative (f) 402 | `(load (merge-pathnames (make-pathname :type ,*scm2cl-lisp-extension*) 403 | (merge-pathnames ,f *load-pathname*)))) 404 | 405 | (defmacro-scm2cl scheme-read-line (&optional i) 406 | `(read-line ,i nil :eof-object)) 407 | 408 | (defmacro-scm2cl scheme-string-index (s c) 409 | `(position ,c ,s :test #'char=)) 410 | 411 | (defmacro-scm2cl scheme-string-reverse-index (s c) 412 | `(position ,c ,s :test #'char= :from-end t)) 413 | 414 | ;eof 415 | -------------------------------------------------------------------------------- /index.tex: -------------------------------------------------------------------------------- 1 | % last change: 2023-01-01 2 | 3 | % 4 | \input texrc 5 | %\input tex2page 6 | \input plainsection 7 | 8 | \ifx\shipout\UnDeFiNeD 9 | \cssblock 10 | body { max-width: 450pt; } 11 | \endcssblock 12 | \fi 13 | 14 | \let\TZPtexlayout 0 15 | \let\n\noindent 16 | \let\f\numberedfootnote 17 | \let\q\scm 18 | 19 | \ifx\shipout\toHTML 20 | \let\oldsection\section 21 | \def\section{\eject\oldsection} 22 | \fi 23 | \let\re\subsection 24 | 25 | \advance\hoffset .75 true in 26 | \advance\hsize -1.5 true in 27 | 28 | \activettchar` 29 | 30 | \title{scmxlate} 31 | 32 | %\ignorenextinputtimestamp 33 | 34 | \centerline{\urlh{https://github.com/ds26gte/scmxlate}{\ifx\shipout\totheWeb 35 | Download \fi Version \input scmxlate-version }} 36 | 37 | \centerline{\urlh{../index.html}{Dorai Sitaram}} 38 | 39 | \medskip 40 | 41 | Scmxlate is a configuration tool for software 42 | packages written in Scheme. 43 | 44 | Scmxlate provides the package author with a strategy 45 | for programmatically specifying the changes required to 46 | translate the package for a variety of Scheme dialects 47 | and Common Lisp, and a variety of operating systems. 48 | The end-user simply loads {\em one} file into 49 | their Scheme or Common Lisp, which triggers the entire 50 | configuration process with little or no further 51 | intervention. 52 | 53 | Thus, there are two types of user for Scmxlate: 54 | 55 | (i) The end-user of an Scmxlate-configured package, who 56 | relies on the 57 | Scmxlate program to perform the configuration 58 | for their system; and 59 | 60 | (ii) the package author, who uses the Scmxlate 61 | methodology to specify an executable form of the 62 | configuration details for the package. 63 | 64 | \n The package author is still required to know a lot more 65 | about the configuration process than the end-user, even 66 | with Scmxlate helping the former. 67 | %(The Common Lisp half 68 | %of Scmxlate uses \urlh{scm2cl.html}{Scm2cl}, 69 | %which is included in the Scmxlate distribution.) 70 | The advantage to using Scmxlate is that the several 71 | end-users can each configure the product to their 72 | different systems by following the same simple 73 | step. 74 | 75 | Section~\ref{useconfig} describes the use of Scmxlate 76 | to execute an already written configuration, and is all 77 | the information you will need if you are an 78 | end-user of packages that have Scmxlate configurations. 79 | 80 | Sections~\ref{writeconfig} and \ref{glossary} are for 81 | package authors, and describe the method and the 82 | language used to write an Scmxlate configuration. 83 | 84 | \bigbreak 85 | 86 | \n{\bf Contents} 87 | 88 | \tableofcontents 89 | 90 | \ifx\shipout\totheWeb\else 91 | \vfill\eject 92 | \fi 93 | 94 | \section{Using an Scmxlate configuration} 95 | \label{useconfig} 96 | 97 | Scenario: You are an end-user who has just downloaded a 98 | Scheme package, say, 99 | \urlh{../tex2page/index.html}{TeX2page}. 100 | The package author claims to have included the Scmxlate 101 | configuration details in the package. What do 102 | you do? 103 | 104 | First, you need to have Scmxlate installed on {\em 105 | your} system. Get 106 | \urlh{https://github.com/ds26gte/scmxlate}{Scmxlate from GitHub}: 107 | 108 | \begintt 109 | git clone https://github.com/ds26gte/scmxlate 110 | \endtt 111 | This creates a directory called `scmxlate`. Place 112 | this directory in its entirety in a place that is 113 | convenient to you. Among the files in this directory 114 | is the file `scmxlate.scm`. Note down 115 | its {\em full} pathname so you can refer to it from 116 | anywhere on your filesystem. 117 | Just to make it concrete, let’s assume you put the 118 | `scmxlate` directory in `/usr/local/lib`. Then the 119 | full pathname to remember is 120 | 121 | \begintt 122 | /usr/local/lib/scmxlate/scmxlate.scm 123 | \endtt 124 | 125 | Now to configure the TeX2page package. Unpack it 126 | and `cd` to its directory. 127 | 128 | For each Scheme file {\em filename} that is to be 129 | translated, there may (but not necessarily) be a 130 | user-configuration file `scmxlate-`{\em filename} in 131 | the top directory. If the instructions that came with 132 | the package suggest you edit them, do so. In our 133 | example package, there is only one user-configuration 134 | file, it is called `scmxlate-tex2page.rkt`, and it 135 | doesn’t seem to require any edits from the casual user. 136 | 137 | Start your Scheme or Common Lisp in the top directory 138 | (being in that directory is important!). In your 139 | Scheme (or Common Lisp), type 140 | 141 | \begintts 142 | (load "/usr/local/lib/scmxlate/scmxlate.scm") 143 | \endtt 144 | where the \q{load} argument is of course the correct 145 | pathname of the file `scmxlate.scm` for your 146 | setup. 147 | 148 | Scmxlate may ask you a few questions. A 149 | choice of answers will be provided, so you don’t need 150 | to be too creative. When Scmxlate finishes, you 151 | will be left with a version of the package tailormade 152 | for you. 153 | 154 | \section{Writing an Scmxlate configuration} 155 | \label{writeconfig} 156 | 157 | %{\color{red}\relax Nothing in this section is 158 | %stable. The implementation and user interface is 159 | %extremely likely to change in order to make the 160 | %documentation easier to write.} 161 | % 162 | %In the following, we will assume that Scmxlate was 163 | %unpacked in `/usr/local/lib`, so the full pathname of the 164 | %`scmxlate.scm` file is 165 | %`/usr/local/lib/scmxlate/scmxlate.scm`. 166 | 167 | \subsection{A minimal configuration} 168 | 169 | Let us say you have a number of Scheme files in 170 | a directory that you intend to package as a 171 | distribution. For specificity let’s say the name of the 172 | directory is `pkgdir` and you have three Scheme files in it, 173 | viz, `apple`, `orange.scm`, and `banana.rkt`. 174 | There is no restriction on the names of these Scheme 175 | files: They may have any or no extension. An end-user 176 | of your distribution will unpack it to produce a 177 | `pkgdir` of their own with the three Scheme files in 178 | it. 179 | 180 | Let us now say that you wrote the Scheme files in the 181 | Racket dialect of Scheme, but that the end-user 182 | uses the Guile dialect of Scheme. In order for them to 183 | be able to create Guile versions of your files, you 184 | need to provide in `pkgdir` some configuration 185 | information. This can be done as follows: 186 | 187 | Create a subdirectory called `dialects` in 188 | `pkgdir`. In the `dialects` subdirectory, 189 | create a file called `files-to-be-ported.scm` 190 | containing the names of the Scheme files to be 191 | translated, viz., 192 | 193 | \begintts 194 | "apple" 195 | "orange.scm" 196 | "banana.rkt" 197 | \endtt 198 | and a file called `dialects-supported.scm` containing 199 | the line 200 | 201 | \begintts 202 | guile 203 | \endtt 204 | The symbol \q{guile} of course stands for the Scheme 205 | dialect Guile. 206 | 207 | The Guile-using user can now start Guile in `pkgdir`, 208 | and load `scmxlate.scm` (using the appropriate 209 | pathname for `scmxlate.scm` on their system, as 210 | described in Section~\ref{useconfig}). Scmxlate will learn 211 | from \path{dialects/files-to-be-ported.scm} that the files 212 | `apple`, `orange.scm`, and `banana.rkt` need to be 213 | translated. It will ask the user what the dialect is, 214 | offering as choices the dialects listed in 215 | \path{dialects/dialects-supported.scm}, plus a catch-all 216 | dialect called Other:\f{The astute reader may wonder 217 | why Scmxlate needs to explicitly ask the user what the 218 | target dialect is, when it is already running on it! 219 | Unfortunately, since the Scxmlate code is necessarily 220 | written in a style that must load in all Schemes, it 221 | cannot portably determine the identity of the 222 | particular Scheme dialect it is currently running on.} 223 | 224 | \begintt 225 | What is your Scheme dialect? 226 | (guile other) 227 | \endtt 228 | 229 | The user types `guile` in response. Scmxlate now 230 | understands that it is to create Guile translations of 231 | the three files, and proceeds to do so. By default, 232 | the translation-result files are created in the 233 | `pkgdir` directory and have the same names as the 234 | original but with the prefix `my-` attached. Thus, 235 | in this case, their names are `my-apple`, 236 | `my-orange.scm`, and `my-banana.rkt`. 237 | 238 | In the following, we will for convenience use 239 | the following terms: 240 | 241 | (i) {\em input file}: a file to be translated; 242 | 243 | (ii) {\em output file}: a file that is the result of 244 | a translation; 245 | 246 | (iii) {\em target dialect}: the dialect translated to. 247 | 248 | In our example above, `apple` is an input 249 | file, `my-apple` is its corresponding output file, 250 | and Guile is the target dialect. 251 | 252 | \subsection{Dialect-configuration files} 253 | 254 | The output file `my-apple` above uses Scmxlate’s 255 | default rules for an Racket-to-Guile translation. 256 | These rules are general and cannot be expected to cover 257 | any peculiar translational information that may be 258 | relevant to the code in `apple`. You can supply such 259 | additional information to Scmxlate via a {\em 260 | dialect-configuration file} called `guile-apple` in 261 | the `dialects` subdirectory. I.e., the name of 262 | the dialect-configuration file for a given input file 263 | and a given dialect is formed from the Scmxlate symbol 264 | for the dialect, followed by a hyphen, followed by the 265 | name of the input file. 266 | 267 | Scmxlate typically takes code from a 268 | dialect-configuration file and sticks it ahead of the 269 | translated code in the output file. This code can be 270 | any Scheme code in the target dialect, and in 271 | particular, it can include definitions. The order of 272 | the code in the dialect-configuration file is preserved 273 | in the output file. 274 | 275 | For instance, if the Racket code in `apple` made 276 | use of a nonstandard (Racket-only) primitive such as 277 | \q{file-or-directory-modify-seconds}, we could supply 278 | the following Guile definition in the 279 | dialect-configuration file, 280 | \path{dialects/guile-apple}: 281 | 282 | \begintts 283 | (define file-or-directory-modify-seconds 284 | (lambda (f) (vector-ref (stat f) 9))) 285 | \endtt 286 | 287 | If the dialect-configuration file supplies a definition for 288 | a name that is also defined in the input file, 289 | then the output file will contain the definition from 290 | the dialect-configuration file, not the input file. 291 | For example, if `apple` contained 292 | the definition 293 | 294 | \begintts 295 | (define file-newer? 296 | (lambda (f1 f2) 297 | ;checks if f1 is newer than f2 298 | (> (file-or-directory-modify-seconds f1) 299 | (file-or-directory-modify-seconds f2)))) 300 | \endtt 301 | we could put a competing Guile-specific definition 302 | in `dialects/guile-apple`: 303 | 304 | \begintts 305 | (define file-newer? 306 | (lambda (f1 f2) 307 | (> (vector-ref (stat f1) 9) 308 | (vector-ref (stat f2) 9)))) 309 | \endtt 310 | 311 | When Scmxlate translates `apple`, it will directly 312 | incorporate this Guile definition into the output file 313 | `my-apple` and won’t even attempt to translate 314 | the Racket definition of the same name in the 315 | input file. 316 | 317 | \subsection{Target dialects} 318 | 319 | In the above, we used the symbol \q{guile} in the 320 | `dialects/dialects-supported.scm` file to signal to 321 | Scmxlate that Guile is one of the dialects into which 322 | the package can be translated. The list of dialect symbols 323 | recognized by Scmxlate is: \q{bigloo}, \q{chez}, 324 | \q{chibi}, \q{chicken}, \q{cl}, 325 | \q{gambit}, \q{gauche}, \q{guile}, \q{ikarus}, \q{kawa}, \q{mitscheme}, 326 | \q{mzscheme}, \q{other}, \q{petite}, \q{plt}, \q{pscheme}, 327 | \q{racket}, \q{scheme48}, 328 | \q{scm}, \q{scsh}, \q{stk}, \q{stklos}, \q{sxm}, 329 | \q{umbscheme}, \q{ypsilon}. 330 | 331 | % The symbols \q{mzscheme} and \q{plt} 332 | % may both be used for PLT Scheme: two symbols are 333 | % provided in case two distinct types of translations are 334 | % called for --- with \q{mzscheme} perhaps being used to create a 335 | % self-sufficient MzScheme script file, and \q{plt} to construct a 336 | % PLT module library. 337 | 338 | The symbol \q{cl} stands for 339 | Common Lisp.\f{Note that 340 | Scmxlate can readily determine if it’s running 341 | on Common Lisp (as opposed to Scheme), so it will not query the user 342 | for further “dialect” information.} 343 | 344 | The symbol \q{other} can be used by the package author 345 | to provide a default configuration for an unforeseen 346 | dialect. Since the dialect is unknown, there isn’t 347 | much information to exploit, but it may be 348 | possible to provide some bare-minimum functionality 349 | (or at least display some advice). 350 | 351 | The package author can make use of other symbols to 352 | denote other Scheme dialects. However, as Scmxlate 353 | cannot do any special translation for such dialects, it 354 | is the responsibility of the package author to provide 355 | additional configuration information for them by 356 | writing dialect-configuration files. 357 | 358 | \subsection{User-configuration files} 359 | 360 | Some packages need some configuration information that 361 | the package author cannot predict and that therefore 362 | can come only come from the user. The information 363 | typically contains user preferences for global 364 | variables in the program. It should not be 365 | dialect-specific. 366 | 367 | Such user information can be placed in {\em 368 | user-configuration files} in the package directory. 369 | Each input file can have its own 370 | user-configuration file, and the latter’s name 371 | consists of the prefix `scmxlate-` followed by the 372 | name of the input file. Thus the user configuration 373 | file for `orange.scm` is `scmxlate-orange.scm`. 374 | 375 | While the package author may not be able to predict the 376 | values of the globals preferred by their various 377 | users, they can include in the package sample 378 | user-configuration files that mention the globals 379 | requiring the user’s intervention, with comments 380 | instructing how the user is to customize them. 381 | 382 | Note that user-configuration code comes ahead of the 383 | dialect-configuration code in the output file. 384 | Definitions in the user-configuration code override 385 | definitions in the dialect-configuration code, just 386 | as the latter themselves override definitions in the 387 | input file. 388 | 389 | \section{The Scmxlate directives} 390 | \label{glossary} 391 | 392 | In addition to Scheme code intended to either augment 393 | or override code in the input file, the 394 | dialect- and user-configuration files can 395 | use a small set of Scmxlate directives to finely control 396 | the text that goes into the output file, and even 397 | specify actions that go beyond the mere creation 398 | of the output file. These directives are now described. 399 | 400 | \re{{\tt scmxlate-insert}} 401 | 402 | As we saw, Scheme code in the dialect- and 403 | user-configuration files is transferred verbatim 404 | to the output file. Sometimes, we need to put into the 405 | output file arbitrary text that is not Scheme code. 406 | For instance, we may want the output file to start with 407 | a “shell magic” line, so that it can be used as a 408 | shell script. Such text can be written using the 409 | `scmxlate-insert` directive, which evaluates its 410 | subforms in Scheme and displays them on the output 411 | file. 412 | 413 | E.g., if you put the following at 414 | the very head of the `guile-apple` file: 415 | 416 | \begintts 417 | (scmxlate-insert 418 | "#!/bin/sh 419 | exec guile -s $0 \"$@\" 420 | !# 421 | ") 422 | \endtt 423 | the output Guile file `my-apple` will start with the 424 | line 425 | 426 | \begintt 427 | #!/bin/sh 428 | exec guile -s $0 "$@" 429 | !# 430 | \endtt 431 | 432 | Note that the order of the code and \q{scmxlate-insert} 433 | text in the configuration file is preserved in 434 | the output file. 435 | 436 | \re{{\tt scmxlate-postamble}} 437 | 438 | Typically, the Scheme code and `scmxlate-insert`s 439 | specified in the dialect-configuration file occur in 440 | the output file before the translated counterpart of 441 | input file’s contents, and thus may be considered as 442 | {\em preamble} text. Sometimes we need to add {\em 443 | postamble} text, i.e., things that go {\em after} the 444 | code from the input file. In order to do this, 445 | place the directive 446 | 447 | \begintts 448 | (scmxlate-postamble) 449 | \endtt 450 | after any preamble text in the dialect-configuration 451 | file. Everything following that, whether Scheme 452 | code or \q{scmxlate-insert}s, will show up in the 453 | output file after the translated contents of the input 454 | file. 455 | 456 | \re{{\tt scmxlate-postprocess}} 457 | 458 | One can also specify actions that need to performed 459 | after the output file has been written. E.g., let’s say 460 | we want the Guile output file for `apple` to be 461 | named `pear` rather than `my-apple`. We can 462 | enclose Scheme code for achieving this inside the 463 | Scmxlate directive \q{scmxlate-postprocess}: 464 | 465 | \begintts 466 | (scmxlate-postprocess 467 | (rename-file "my-apple" "pear")) 468 | \endtt 469 | 470 | \re{{\tt scmxlate-ignoredef}} 471 | 472 | Sometimes the input file has a definition that the 473 | target dialect does not need, either because the target 474 | dialect already has it as a primitive, or because we 475 | wish to completely re-write input code that uses that 476 | definition. E.g., if the target dialect is Gambit, 477 | which already contains \q{reverse!}, any definition of 478 | \q{reverse!} in the input file can be ignored. 479 | 480 | \begintts 481 | (scmxlate-ignoredef reverse!) 482 | \endtt 483 | 484 | \q{scmxlate-ignoredef} can have any number of 485 | arguments. The definitions of all of them will be 486 | ignored. 487 | 488 | \re{{\tt scmxlate-rename}} 489 | 490 | Sometimes we want to rename certain identifiers from 491 | the input file. One possible motivation is that 492 | these identifiers name nonstandard primitives that are 493 | provided under a different name in the target dialect. 494 | For instance, the Bigloo versions of the Racket 495 | primitives \q{current-directory} and 496 | \q{file-or-directory-modify-seconds} are \q{chdir} and 497 | \q{file-modification-time} respectively. So if your 498 | Racket input file uses \q{current-directory} and 499 | \q{file-or-directory-modify-seconds}, your Bigloo 500 | dialect-configuration file should contain 501 | 502 | \begintts 503 | (scmxlate-rename 504 | (current-directory chdir) 505 | (file-or-directory-modify-seconds file-modification-time)) 506 | \endtt 507 | 508 | Note the syntax: \q{scmxlate-rename} has any number of 509 | twosomes as arguments. The left item is the name in 510 | the input file, and the right item is its proposed 511 | replacement. 512 | 513 | \re{{\tt scmxlate-ignoredef-rename}} 514 | 515 | Sometimes the input file includes a definition 516 | for an operator that the target dialect already has as 517 | a primitive, but with a different name. E.g., consider 518 | an input file that contains a definition for 519 | \q{nreverse}. Gambit has the same operator but with 520 | name \q{reverse!}. You could add the following to 521 | the Gambit dialect-configuration file: 522 | 523 | \begintts 524 | (scmxlate-ignoredef-rename 525 | (nreverse reverse!)) 526 | \endtt 527 | 528 | Note that this is shorthand for 529 | 530 | \begintts 531 | (scmxlate-ignoredef nreverse) 532 | (scmxlate-rename 533 | (nreverse reverse!)) 534 | \endtt 535 | 536 | \re{{\tt scmxlate-prefix}} 537 | 538 | Another motivation for renaming is to avoid polluting 539 | namespace. We may wish to have short names in the 540 | input file, but when we configure it, we want longer, 541 | “qualified” names. It is possible to use 542 | \q{scmxlate-rename} for this, but the 543 | \q{scmxlate-prefix} is convenient when the newer names 544 | are all uniformly formed by adding a prefix. 545 | 546 | \begintts 547 | (scmxlate-prefix 548 | "regexp::" 549 | match 550 | substitute 551 | substitute-all) 552 | \endtt 553 | renames the identifiers \q{match}, \q{substitute}, 554 | and \q{substitute-all} to 555 | \q{regexp::match}, \q{regexp::substitute}, and 556 | \q{regexp::substitute-all} respectively. 557 | 558 | The first argument of \q{scmxlate-prefix} is the 559 | string form of the prefix; the remaining arguments are 560 | the identifiers that should be renamed. 561 | 562 | \re{{\tt scmxlate-cond}} 563 | 564 | Sometimes we want parts of the dialect-configuration 565 | file to processed only when a condition holds. For 566 | instance, we can use the following \q{cond}-like 567 | conditional in 568 | a dialect-configuration file to 569 | write out a shell-magic 570 | line appropriate to the operating system: 571 | 572 | \begintts 573 | (scmxlate-cond 574 | ((eqv? (system-type) 'unix) 575 | (scmxlate-insert *unix-shell-magic-line*)) 576 | ((eqv? (system-type) 'windows) 577 | (scmxlate-insert *windows-shell-magic-line*))) 578 | \endtt 579 | where \q{*unix-shell-magic-line*} and 580 | \q{*windows-shell-magic-line*} are replaced by 581 | appropriate strings. 582 | 583 | Note that while \q{scmxlate-cond} allows the \q{else} 584 | keyword for its final clause, it does not support the 585 | Scheme \q{cond}’s \q{=>} keyword. 586 | 587 | \re{{\tt scmxlate-eval}} 588 | 589 | The test argument of \q{scmxlate-cond} and all the 590 | arguments of \q{scmxlate-insert} are evaluated in the 591 | Scheme global environment when Scmxlate is running. 592 | You can enhance this environment with 593 | \q{scmxlate-eval}. Thus, if we had 594 | 595 | \begintts 596 | (scmxlate-eval 597 | (define *unix-shell-magic-line* <...>) 598 | (define *windows-shell-magic-line* <...>)) 599 | \endtt 600 | where the \q{<...>} stand for code that constructs 601 | the appropriate string, then we could use these 602 | variables as the arguments to \q{scmxlate-insert} in 603 | the example under \q{scmxlate-cond}. 604 | 605 | \q{scmxlate-eval} can have any number of subforms. 606 | It evaluates each of them in the given order. 607 | 608 | \re{{\tt scmxlate-compile}} 609 | 610 | \q{scmxlate-compile} can be used to tell if the output 611 | file is to be compiled. Typical usage is 612 | 613 | \begintts 614 | (scmxlate-compile #t) ;or 615 | (scmxlate-compile #f) 616 | \endtt 617 | The first forces compilation but only if the dialect 618 | supports it, and the second disables compilation even 619 | if the dialect supports it. The argument of 620 | \q{scmxlate-compile} can be any expression, which is 621 | evaluated only for its boolean significance. 622 | 623 | Without a \q{scmxlate-compile} setting, Scmxlate will 624 | ask the user explicitly for advice, but only if 625 | the dialect supports compilation. 626 | 627 | \re{{\tt scmxlate-include}} 628 | 629 | It is often convenient to keep in a separate file some 630 | of the portions of the text that should go into a 631 | dialect-configuration file. Some definitions may 632 | naturally be already written down somewhere else, or 633 | we may want the text to be shared across several 634 | dialect-configuration files (for different dialects). 635 | The call 636 | 637 | \begintts 638 | (scmxlate-include "filename") 639 | \endtt 640 | inserts the contents of \q{"filename"} 641 | into that location in the dialect-configuration file. 642 | 643 | \re{{\tt scmxlate-uncall}} 644 | 645 | It is sometimes necessary to skip a top-level 646 | call when translating an input file. For instance, 647 | the input file may be used as a script file whose 648 | scriptural action consists in calling a procedure 649 | called \q{main}. The target dialect may not allow 650 | the output file to be a script, so the user may prefer 651 | to load the output file into Scheme as a library 652 | and make other arrangements to invoke its 653 | functionality. To disable the call to \q{main} 654 | in the output file, add 655 | 656 | \begintts 657 | (scmxlate-uncall main) 658 | \endtt 659 | to the configuration file. 660 | 661 | \q{scmxlate-uncall} can take any number of symbol 662 | arguments. All the corresponding top-level calls 663 | will be disabled in the output. 664 | 665 | \bye 666 | 667 | Some rejecta follows. 668 | 669 | Only two of these symbols need special explanation: A 670 | user can pick the `other` dialect if his Scheme isn’t 671 | listed in the choices that Scmxlate offers. The 672 | dialect `cl` isn’t a Scheme dialect but Common Lisp. 673 | Scheme dialects do identified by human 674 | intervention, as there is (yet) no portable Scheme code 675 | to id the dialect. 676 | 677 | More than one file can be configured using 678 | Scmxlate. Just add the filenames to 679 | `dialects/files-to-be-ported.scm`. Customizing info 680 | tailored to each file can be added to the `dialects` 681 | directory as we have already described for the 682 | file `progfile`. I.e., an Scsh customization file 683 | for `anotherfile.ss` would be 684 | `dialects/scsh-anotherfile.ss`. 685 | 686 | \iffalse 687 | This kind of definition replacement is particularly 688 | useful when the target language is Common Lisp. 689 | For instance, let’s say `progfile` contains 690 | the definition 691 | 692 | \begintts 693 | (define lassoc 694 | (lambda (k al equ?) 695 | (let loop ((al al)) 696 | (if (null? al) #f 697 | (let ((c (car al))) 698 | (if (equ? (car c) k) c 699 | (loop (cdr al)))))))) 700 | \endtt 701 | 702 | Scmxlate will provide a complicated if working 703 | Common Lisp translation of the above code, but it 704 | will not be as simple as 705 | 706 | \begintts 707 | (defun lassoc (k al equ?) 708 | (assoc k al :test equ?)) 709 | \endtt 710 | 711 | You can put this latter definition in 712 | `dialects/cl-progfile` — where the symbol \q{cl} 713 | stands for Common Lisp — and it will be used in 714 | preference to the default translation. 715 | \fi 716 | 717 | You may wish for some extra CL code to precede or 718 | follow the translated `progfile` code. For instance, 719 | you may wish to add some additional definitions before 720 | the translation to cover some Racket-specific 721 | procedures you may have used in `progfile`. E.g., 722 | 723 | \begintts 724 | (defun getenv (ev) 725 | (system::getenv ev)) 726 | \endtt 727 | This can be placed in the file 728 | `dialects/cl-preamble-progfile`. 729 | 730 | CL code you want following the `progfile` code can be 731 | placed in `dialects/cl-postamble-progfile`. 732 | 733 | \subsection{Specifying Scheme dialects} 734 | 735 | The filename prefix `cl-` used in the previous 736 | example is used to identify configuration info 737 | for Common Lisp. If the target language is another 738 | Scheme dialect, rather than Common Lisp, you can follow 739 | a similar procedure, except that we need some way for 740 | the target Scheme to identify itself to Scmxlate. 741 | Scmxlate can tell if it is running in CL, but 742 | needs help in determining which particular Scheme 743 | dialect it is running. 744 | 745 | For example, let’s say the target Scheme dialect 746 | is Guile. We create in `dialects` a file called 747 | `dialects-supported.scm` containing the line 748 | 749 | \begintt 750 | guile 751 | \endtt 752 | 753 | Now if the user starts Guile in the `pkgdir` 754 | directory and loads `scmxlate.scm`, the following 755 | question will be asked: 756 | 757 | \begintt 758 | What is your Scheme dialect? 759 | (guile other) 760 | \endtt 761 | 762 | Typing `guile` in response will cause Scmxlate to 763 | create a `my-progfile` that is the Guile translation 764 | of `progfile`. You can add additional Guile 765 | configuration info in the form of the files 766 | `guile-preamble-progfile`, `guile-procs-progfile`, 767 | and `guile-postamble-progfile`, exactly as for CL 768 | above. 769 | 770 | The user can use the symbol `other` if his Scheme 771 | dialect is not listed in `dialects-supported.scm` but 772 | he wants to configure the package anyway. The results 773 | may be variable. The configurer can also put in 774 | additional config info in the `dialects` 775 | directory using the `other-` prefix. 776 | 777 | You can certainly add a symbol of your own in 778 | `dialects-supported.scm`. Scmxlate will not know 779 | of it by default, but you can add additional 780 | configuration files using the appropriate prefix in 781 | `dialects`. 782 | 783 | \subsection{Configuring more than one file} 784 | 785 | You can of course configure more than one `progfile`. 786 | Simply add their names to the 787 | `dialects/files-to-be-ported.scm` directory. By 788 | default, the translated files will have the same names 789 | as the originals, but with the prefix `my-` in front 790 | of them. 791 | 792 | \subsection{To be described} 793 | 794 | Scmxlate-specific commands used in the 795 | configuration files: 796 | 797 | user-override-file 798 | 799 | operating-system dependencies 800 | 801 | Let us say you wrote a Scheme file named 802 | `progfile`\f{The Scheme file’s name may have no or 803 | any extension. Thus, `newton-raphson`, 804 | `newton-raphson~`, `newton-raphson.bak`, 805 | `newton-raphson.scm`, `newton-raphson.ss`, 806 | `newton-raphson.java` are all acceptable filenames 807 | --- but the file’s contents must be Scheme code.} in a 808 | directory `pkgdir`, and you package it off into a 809 | distribution which an end-user will unpack to 810 | produce a directory `pkgdir` of his own. 811 | -------------------------------------------------------------------------------- /scmxlate.scm: -------------------------------------------------------------------------------- 1 | (cond ((not 'nil) 2 | ;Common Lisp 3 | (load 4 | (merge-pathnames 5 | (make-pathname :type "cl") 6 | *load-pathname*)))) 7 | 8 | ;(require (lib "trace.ss")) 9 | 10 | 'eval-in-cl-also 11 | (define *scmxlate-version* "20230101") ;last change 12 | 13 | 'eval-in-cl-also 14 | (begin 15 | (display "This is scmxlate, v ") 16 | (display *scmxlate-version*) 17 | (newline)) 18 | 19 | (define *dialect* #f) 20 | (define *dialect-version* 1) ;? 21 | 'eval-in-cl-also 22 | (define *operating-systems-supported* '()) 23 | 'eval-in-cl-also 24 | (define *operating-system* 'unix) 25 | 'eval-in-cl-also 26 | (define *compile?* #f) 27 | 'eval-in-cl-also 28 | (define *shell-script?* #f) 29 | 'eval-in-cl-also 30 | (define *source-file* #f) 31 | 'eval-in-cl-also 32 | (define *source-file-translated?* #f) 33 | 'eval-in-cl-also 34 | (define *reading-source-file?* #f) 35 | 'eval-in-cl-also 36 | (define *names-defined* '()) 37 | 'eval-in-cl-also 38 | (define *calls-disallowed* '()) 39 | ;(define *names-ignored* '()) 40 | ;(define *names-disabled* '()) 41 | 'eval-in-cl-also 42 | (define *aliases* '()) 43 | ;(define *predefined-aliases* '()) 44 | 'eval-in-cl-also 45 | (define *num-of-lines-to-skip* 0) 46 | ;'eval-in-cl-also 47 | ;(define *target-file* #f) 48 | 'eval-in-cl-also 49 | (define *target-port* #f) 50 | 'eval-in-cl-also 51 | (define *postprocessing* #f) 52 | 53 | 'eval-in-cl-also 54 | (define *cr* #f) 55 | 'eval-in-cl-also 56 | (define *lf* #f) 57 | 58 | '(define string->lower-case 59 | (lambda (s) 60 | (list->string 61 | (map char-downcase 62 | (string->list s))))) 63 | 64 | ;string->list doesn't work in scsh! 65 | 66 | 'eval-in-cl-also 67 | (define string->lower-case 68 | (lambda (s) 69 | (let loop ((i (- (string-length s) 1)) (r '())) 70 | (if (< i 0) (list->string r) 71 | (loop (- i 1) 72 | (cons (char-downcase (string-ref s i)) r)))))) 73 | 74 | (define read-a-line 75 | (lambda (i) 76 | (list->string 77 | (let loop () 78 | (let ((c (read-char i))) 79 | (if (or (eof-object? c) 80 | (char=? c #\newline)) 81 | '() 82 | (cons c (loop)))))))) 83 | 84 | (define resolve-aliases 85 | (lambda (e) 86 | (cond ((not *reading-source-file?*) e) 87 | ((pair? e) 88 | (cons (resolve-aliases (car e)) 89 | (resolve-aliases (cdr e)))) 90 | ((symbol? e) 91 | (cond ((assv e *aliases*) => cdr) 92 | (else e))) 93 | (else e)))) 94 | 95 | 'eval-in-cl-also 96 | (define copy-port-to-port 97 | (lambda (i o) 98 | (let loop () 99 | (let ((c (read-char i))) 100 | (if (not (eof-object? c)) 101 | (begin 102 | (if (eqv? *operating-system* 'windows) 103 | (cond ((char=? c *cr*) 'skip) 104 | ((char=? c *lf*) (display *cr* o) 105 | (display *lf* o)) 106 | (else (display c o))) 107 | (display c o)) 108 | (loop)) 109 | #f))))) 110 | 111 | 'eval-in-cl-also 112 | (define copy-file-to-port 113 | (lambda (f o) 114 | (call-with-input-file f 115 | (lambda (i) 116 | (copy-port-to-port i o))))) 117 | 118 | 'eval-in-cl-also 119 | (define copy-binary-file-to-port 120 | (lambda (f o) 121 | (call-with-input-file f 122 | (lambda (i) 123 | (let loop () 124 | (let ((c (read-char i))) 125 | (if (not (eof-object? c)) 126 | (begin (write-char c o) (loop)) 127 | #f))))))) 128 | 129 | 'eval-in-cl-also 130 | (define *files-to-be-ported* 131 | (call-with-input-file "dialects/files-to-be-ported.scm" 132 | (lambda (i) 133 | (let sub () 134 | (let ((f (read i))) 135 | (if (eof-object? f) '() 136 | (cons (if (string? f) f 137 | (string->lower-case (symbol->string f))) 138 | (sub)))))))) 139 | 140 | 'eval-in-cl-also 141 | (define *dialects-supported* 142 | (if (eqv? *dialect* 'cl) '(cl) 143 | (call-with-input-file "dialects/dialects-supported.scm" 144 | (lambda (i) 145 | (let loop () 146 | (let ((d (read i))) 147 | (if (eof-object? d) '() 148 | (cons d (loop))))))))) 149 | 150 | (define find-dialect 151 | (lambda () 152 | (display "What is your Scheme dialect?") 153 | (newline) (display " ") (display "(") 154 | (let loop ((dd *dialects-supported*) (i 0)) 155 | (cond ((null? dd) 156 | (display "other)") 157 | (newline)) 158 | (else 159 | (if (>= i 5) 160 | (begin (set! i 0) 161 | (newline) 162 | (display " ") 163 | (display " ")) 164 | #f) 165 | (display (car dd)) (display " ") 166 | (loop (cdr dd) (+ i 1))))) 167 | (read))) 168 | 169 | (set! *dialect* (find-dialect)) 170 | 171 | (if (eqv? *dialect* 'sxm) 172 | ;sxm issues warnings for forward-refs, 173 | ;which can't all be removed anyway 174 | (warning-handler (lambda zzz #f)) 175 | #f) 176 | 177 | (if (eqv? *dialect* 'chicken) 178 | (eval '(import 179 | (chicken file) 180 | (chicken pretty-print) 181 | (chicken process) 182 | (chicken process-context) 183 | )) 184 | #f) 185 | 186 | (if (eqv? *dialect* 'guile) 187 | (if (not (defined? 'primitive-load)) 188 | (begin 189 | (display "Your Scheme dialect is _not_ Guile!") 190 | (newline)) 191 | #f) 192 | #f) 193 | 194 | (if (eqv? *dialect* 'scheme48) 195 | (begin 196 | (display "Structures") (newline) 197 | (for-each 198 | (lambda (str) 199 | (display " ") (display str) (newline)) 200 | '(c-system-function extended-ports posix-files posix-process-data)) 201 | (display "must be open before you configure or run tex2page.") 202 | (newline) 203 | (display "If they aren't open, please open and retry.") 204 | (newline)) 205 | #f) 206 | 207 | (define exists-file? 208 | (case *dialect* 209 | ((bigloo chez chibi chicken gambit gauche guile ikarus kawa mitscheme mzscheme 210 | petite plt racket scm scsh stk stklos sxm umbscheme ypsilon) 211 | file-exists?) 212 | ((scheme48) 213 | (lambda (f) 214 | (accessible? f (access-mode read)))) 215 | ((pscheme) 216 | (lambda (f) 217 | (with-handlers (((lambda (x) #t) (lambda (x) #f))) 218 | (close-input-port (open-input-file f)) 219 | #t))) 220 | (else (lambda (f) #t)))) 221 | 222 | (define obliterate-file 223 | (case *dialect* 224 | ((bigloo chez chibi gambit guile ikarus kawa mitscheme mzscheme petite plt 225 | pscheme racket scsh scm sxm umbscheme ypsilon) 226 | delete-file) 227 | ((gauche) sys-remove) 228 | ((scheme48) unlink) 229 | ((stk stklos) 230 | (lambda (f) 231 | (system (string-append "rm " f)))) 232 | ; ((gambit) 233 | ; ;## causes problems with other Scheme dialects 234 | ; (lambda (f) 235 | ; ((eval (call-with-input-string "##shell-command" read)) 236 | ; (string-append "rm " f)))) 237 | (else (lambda (f) #t)))) 238 | 239 | (define ensure-file-deleted 240 | (lambda (f) 241 | (if (exists-file? f) (obliterate-file f) #f))) 242 | 243 | 'eval-in-cl-also 244 | (define copy-file-to-file 245 | (lambda (fi fo) 246 | (ensure-file-deleted fo) 247 | (call-with-output-file fo 248 | (lambda (o) 249 | (copy-file-to-port fi o))))) 250 | 251 | (if (exists-file? "dialects/operating-systems-supported.scm") 252 | (set! *operating-systems-supported* 253 | (call-with-input-file "dialects/operating-systems-supported.scm" 254 | (lambda (i) 255 | (let loop () 256 | (let ((s (read i))) 257 | (if (eof-object? s) '() 258 | (cons s (loop)))))))) 259 | #f) 260 | 261 | (define dialect-getenv 262 | (case *dialect* 263 | ((bigloo chez guile ikarus mzscheme petite plt racket 264 | scm scsh stk stklos sxm ypsilon) 265 | (lambda (ev) (getenv ev))) 266 | ((gambit) (lambda (ev) 267 | (with-exception-handler (lambda (e) #f) 268 | (lambda () (getenv ev))))) 269 | ((gauche) (lambda (ev) (sys-getenv ev))) 270 | ((scheme48) (lambda (ev) (lookup-environment-variable ev))) 271 | ((chibi chicken mitscheme) (lambda (ev) (get-environment-variable ev))) 272 | (else (lambda (ev) #f)))) 273 | 274 | (define determine-os 275 | (lambda () 276 | (if (dialect-getenv "COMSPEC") 277 | (let ((term (dialect-getenv "TERM"))) 278 | (if (and (string? term) (string=? term "cygwin")) 279 | 'unix 'windows)) 280 | 'unix))) 281 | 282 | (set! *operating-system* 283 | (case (length *operating-systems-supported*) 284 | ((0) 285 | ;if no OSes mentioned, assume unix 286 | 'unix) 287 | ((1) 288 | ;if only one OS mentioned, choose it right away 289 | (car *operating-systems-supported*)) 290 | (else 291 | (case *dialect* 292 | ((bigloo chez chibi chicken gambit gauche guile ikarus mitscheme mzscheme 293 | petite plt racket scheme48 scm scsh stk stklos sxm ypsilon) 294 | (determine-os)) 295 | ((pscheme) 'windows) 296 | ((umbscheme) 'unix) 297 | (else 298 | (display "What is your operating system? (") 299 | (let ((first? #t)) 300 | (for-each 301 | (lambda (os) 302 | (if first? (set! first? #f) 303 | (display " ")) 304 | (display os)) 305 | *operating-systems-supported*)) 306 | (display ")") 307 | (newline) 308 | (read)))))) 309 | 310 | (define integer-to-char 311 | (lambda (n) 312 | (integer->char 313 | (if (memv *dialect* '(scheme48 scsh)) 314 | (+ 1000 n) 315 | n)))) 316 | 317 | 'eval-in-cl-also 318 | (if (eqv? *operating-system* 'windows) 319 | (begin 320 | (set! *cr* (integer-to-char 13)) 321 | (set! *lf* (integer-to-char 10))) 322 | #f) 323 | 324 | ;for PLT and Guile, check version 325 | 326 | (case *dialect* 327 | ((mzscheme plt racket) 328 | (set! *dialect-version* 329 | (string->number 330 | (regexp-replace "^([0-9]+).*" 331 | (version) "\\1")))) 332 | ((guile) 333 | (set! *dialect-version* 334 | (string->number 335 | (string-append 336 | (major-version) "." (minor-version)))))) 337 | 338 | (define eval1 339 | (case *dialect* 340 | ((gauche ikarus scheme48 scsh) 341 | (lambda (e) (eval e (interaction-environment)))) 342 | ((guile) 343 | (if (>= *dialect-version* 1.6) 344 | (lambda (e) (eval e (interaction-environment))) 345 | eval)) 346 | ((mitscheme) (lambda (e) (eval e user-initial-environment))) 347 | (else eval))) 348 | 349 | ;get "system" for PLT Scheme 350 | 351 | (if (memv *dialect* '(mzscheme plt)) 352 | (eval '(require (lib "process.ss"))) 353 | #f) 354 | 355 | ;get "pretty-print" for PLT Scheme 356 | 357 | (if (memv *dialect* '(mzscheme plt)) 358 | (eval '(require (lib "pretty.ss"))) 359 | #f) 360 | 361 | ;get compiler for MzScheme 362 | 363 | (if (memv *dialect* '(mzscheme plt racket)) 364 | (eval '(require (lib "compile.ss"))) 365 | #f) 366 | 367 | ;get pretty-print for Guile 368 | 369 | (if (eqv? *dialect* 'guile) 370 | (use-modules (ice-9 pretty-print)) 371 | #f) 372 | 373 | 'eval-in-cl-also 374 | (define pick-up-shell-magic-lines 375 | (lambda (f) 376 | (if (eqv? *dialect* 'mitscheme) 377 | (begin 378 | (display "Warning! Compiled file won't have shell-magic!") 379 | (newline) 380 | (list '() f)) 381 | (call-with-input-file f 382 | (lambda (i) 383 | (let loop ((r '())) 384 | (if (memv (peek-char i) '(#\# #\")) 385 | (loop (cons (read-a-line i) r)) 386 | (if (or (null? r) (eqv? *dialect* 'chez)) 387 | (list (reverse r) f) 388 | (let ((new-f (string-append f ".temp"))) 389 | (ensure-file-deleted new-f) 390 | (call-with-output-file new-f 391 | (lambda (o) 392 | (copy-port-to-port i o))) 393 | (list (reverse r) new-f)))))))))) 394 | 395 | (define compile-file-to-file 396 | (case *dialect* 397 | ((chez mzscheme petite plt racket) 398 | (lambda (fi fo) (compile-file fi fo) fo)) 399 | ((chicken) 400 | (lambda (fi fo) 401 | (display "For Chicken, it may be better form to compile from ") 402 | (display "the command line.") (newline) 403 | (display "Gamely trying anyway; this will take a while ...") (newline) 404 | (system (string-append "csc " fi " -o " fo " -b -O2")) 405 | fo)) 406 | ((mitscheme) 407 | (lambda (fi fo) 408 | ;MIT Scheme won't allow source file to 409 | ;be extensionless, and it forces target 410 | ;file to have extension .com 411 | (if (not (pathname-type fi)) 412 | (let ((new-fi 413 | (merge-pathnames 414 | (make-pathname #f #f #f #f "scm" #f) fi))) 415 | (copy-file-to-file fi new-fi) 416 | (set! fi new-fi)) 417 | #f) 418 | (set! fo (merge-pathnames 419 | (make-pathname #f #f #f #f "com" #f) fi)) 420 | (newline) 421 | (cf fi) 422 | (enough-namestring fo))) 423 | (else (lambda (fi fo) #f)))) 424 | 425 | ;'eval-in-cl-also 426 | (define compile-possible? 427 | (lambda () 428 | (and (eqv? *operating-system* 'unix) 429 | (or (memv *dialect* '(;chicken 430 | cl mzscheme plt)) 431 | ;TODO: what about racket? 432 | (and (memv *dialect* '(chez petite)) 433 | (eqv? (current-eval) compile)) 434 | (and (eqv? *dialect* 'mitscheme) 435 | (environment-bound? user-initial-environment 436 | 'cf)))))) 437 | 438 | 'eval-in-cl-also 439 | (define kompile 440 | (lambda (f) 441 | (display "Compiling ") (display f) 442 | (display " ...") (newline) 443 | (let* ((x (pick-up-shell-magic-lines f)) 444 | (shell-lines (car x)) 445 | (src (cadr x)) 446 | (tgt (string-append src ".so"))) 447 | (if (and (eqv? *dialect* 'chez) (pair? shell-lines)) 448 | (begin 449 | ;(printf "compile-script ~s ~s~%" src tgt) 450 | (compile-script src tgt)) 451 | (set! tgt (compile-file-to-file src tgt))) 452 | (if tgt 453 | (begin 454 | (display tgt) (display " created.") (newline) 455 | (if (memv *dialect* '(chicken mitscheme)) 456 | (if (not (null? shell-lines)) 457 | (begin 458 | (display "Warning: Throwing out shell-magic ") 459 | (display "lines for compiled file!") 460 | (newline) 461 | (if (eqv? *dialect* 'chicken) 462 | (begin (display "For Chicken, this may not be a problem, ") 463 | (display "as compiled code can query command args.")) 464 | (display "This may or may not be right!")) 465 | (newline)) 466 | #f) 467 | #f) 468 | (if (not (eqv? *dialect* 'mitscheme)) 469 | (begin 470 | (ensure-file-deleted f) 471 | (display "Copying ") (display tgt) 472 | (display " to ") (display f) (newline) 473 | (if (eqv? *dialect* 'chez) 474 | (system 475 | (string-append "cp -p " tgt " " f)) 476 | (call-with-output-file f 477 | (lambda (o) 478 | (for-each 479 | (lambda (line) 480 | (display line o) (newline o)) 481 | shell-lines) 482 | (copy-binary-file-to-port tgt o)))) 483 | (set! tgt f)) 484 | #f)) 485 | (begin (display "Compilation failed?") 486 | (newline) 487 | (set! tgt f))) 488 | (display "If compilation failed, try without compile option.") 489 | (newline) 490 | tgt))) 491 | 492 | 'eval-in-cl-also 493 | (define *dialect-s* 494 | (string-append 495 | (string->lower-case (symbol->string *dialect*)) "-")) 496 | 497 | (define write-nicely write) 498 | 499 | (define writeln 500 | (lambda (e o) 501 | (write-nicely (resolve-aliases e) o) 502 | (newline o))) 503 | 504 | ;redefine write-nicely to use pretty-printer 505 | ;for dialects that have it 506 | 507 | (define stklos-pretty-print list) 508 | 509 | (case *dialect* 510 | ((stklos) 511 | (set! stklos-pretty-print 512 | (lambda z 513 | (apply pretty-print z))))) 514 | 515 | (case *dialect* 516 | ((chez chicken gambit guile ikarus mzscheme petite plt racket sxm ypsilon) 517 | (set! write-nicely pretty-print)) 518 | ((gauche) 519 | (set! write-nicely 520 | (lambda (e o) (pprint e :port o)))) 521 | ((mitscheme) 522 | (set! write-nicely pp)) 523 | ((stklos) 524 | (set! write-nicely 525 | (lambda (e o) 526 | (stklos-pretty-print e :port o)))) 527 | ) 528 | 529 | 'eval-in-cl-also 530 | (define names-defined 531 | (lambda (x) 532 | (let ((r '())) 533 | (let sub ((x x)) 534 | (if (pair? x) 535 | (let ((n (length x))) 536 | (cond ((and (> n 2) 537 | (let ((y (car x))) 538 | (and (symbol? y) 539 | (or 540 | (memv y 541 | '(define define-macro define-syntax 542 | defmacro defstruct 543 | defconstant defparameter 544 | defun defvar)) 545 | (let ((y-s 546 | (symbol->string y))) 547 | (or 548 | (string-ci=? y-s "define-syntax") 549 | (string-ci=? y-s "defstruct"))))))) 550 | (set! r 551 | (cons 552 | (let ((name (cadr x))) 553 | (if (pair? name) (car name) name)) 554 | r))) 555 | ((and (>= n 2) (memv (car x) '(scmxlate-ignoredef 556 | scmxlate-ignore-define 557 | scmxlate-ignore))) 558 | (set! r 559 | (append (cdr x) r))) 560 | ((and (>= n 2) (memv (car x) '(scmxlate-ignoredef-rename 561 | scmxlate-rename-define))) 562 | (set! r 563 | (append (map car (cdr x)) r))) 564 | ((and (> n 3) (eqv? (car x) 'syntax-table-define)) 565 | (set! r 566 | (cons 567 | (cadr (caddr x)) 568 | r))) 569 | ((and (> n 2) (memv (car x) '(begin if when unless))) 570 | (for-each sub (cddr x))))) 571 | #f)) 572 | r))) 573 | 574 | (define translate-define-syntax 575 | (case *dialect* 576 | ((stk) 577 | (lambda (e) 578 | `(define-macro (,(cadr e) . _args) 579 | (let ((datum->syntax (lambda (x y) y)) 580 | (syntax->datum (lambda (x) x))) 581 | (,(caddr e) (cons ',(cadr e) _args)))))) 582 | ((mitscheme) 583 | (if (environment-bound? user-initial-environment 'rsc-macro-transformer) 584 | (lambda (e) 585 | `(define-syntax ,(cadr e) 586 | (rsc-macro-transformer 587 | (let ((datum->syntax (lambda (x y) y)) 588 | (syntax->datum (lambda (x) x))) 589 | (lambda (__e __r) 590 | (,(caddr e) __e)))))) 591 | (lambda (e) 592 | `(syntax-table-define system-global-syntax-table ',(cadr e) 593 | (macro _args 594 | (let ((datum->syntax (lambda (x y) y)) 595 | (syntax->datum (lambda (x) x))) 596 | (,(caddr e) (cons ',(cadr e) _args)))))))) 597 | ((scm kawa umbscheme) 598 | (lambda (e) 599 | `(defmacro ,(cadr e) _args 600 | (let ((datum->syntax (lambda (x y) y)) 601 | (syntax->datum (lambda (x) x))) 602 | (,(caddr e) (cons ',(cadr e) _args)))))) 603 | ((chicken) 604 | (lambda (e) 605 | `(define-syntax ,(cadr e) 606 | (er-macro-transformer 607 | (lambda (__form __rename __compare) 608 | (let ((datum->syntax (lambda (x y) y)) 609 | (syntax->datum (lambda (x) x))) 610 | (,(caddr e) __form))))))) 611 | ((scheme48 scsh) 612 | (lambda (e) 613 | `(define-syntax ,(cadr e) 614 | (lambda (__form __rename __compare) 615 | (let ((datum->syntax (lambda (x y) y)) 616 | (syntax->datum (lambda (x) x))) 617 | (,(caddr e) __form)))))) 618 | ((gambit gauche guile bigloo pscheme stklos) 619 | (lambda (e) 620 | (let ((e-t `(define-macro ,(cadr e) 621 | (lambda _args 622 | (let ((datum->syntax (lambda (x y) y)) 623 | (syntax->datum (lambda (x) x))) 624 | (,(caddr e) (cons ',(cadr e) _args))))))) 625 | (if (and #f (eqv? *dialect* 'gambit)) 626 | ;disabled; but why was it ever needed? 627 | `(begin ,e-t 628 | (eval ',e-t)) 629 | e-t)))) 630 | ((chez petite sxm) 631 | ;unlike Mz, these dialects don't allow 632 | ;a general syntax object as datum->syntax-object's 633 | ;first arg; it's got to be an identifier 634 | (lambda (e) 635 | `(define-syntax ,(cadr e) 636 | (let* ((old-datum->syntax-object datum->syntax-object) 637 | (datum->syntax 638 | (lambda (so output) 639 | (old-datum->syntax-object 640 | (syntax-case so () 641 | ((k . stuff) (syntax k))) 642 | output)))) 643 | ,(caddr e))))) 644 | ((chibi) 645 | ;Chibi's datum->syntax's 1st arg must be an identifier 646 | (lambda (e) 647 | `(define-syntax ,(cadr e) 648 | (let* ((old-datum->syntax datum->syntax) 649 | (datum->syntax 650 | (lambda (so output) 651 | (old-datum->syntax 652 | (syntax-case so () 653 | ((k . stuff) (syntax k))) 654 | output)))) 655 | ,(caddr e))))) 656 | ((mzscheme plt racket) 657 | (lambda (e) 658 | (if *compile?* (eval e) #f) 659 | e) 660 | ) 661 | (else 662 | (lambda (e) e)))) 663 | 664 | (define translate-define-macro 665 | (case *dialect* 666 | ((stk stklos) 667 | (lambda (e) 668 | `(define-macro (,(cadr e) ,@(cadr (caddr e))) 669 | ,@(cddr (caddr e))))) 670 | ((mitscheme) 671 | (if (environment-bound? user-initial-environment 'rsc-macro-transformer) 672 | (lambda (e) 673 | `(define-syntax ,(cadr e) 674 | (rsc-macro-transformer 675 | (let ((xfmr ,(caddr e))) 676 | (lambda (e r) 677 | (apply xfmr (cdr e))))))) 678 | (lambda (e) 679 | `(syntax-table-define system-global-syntax-table ',(cadr e) 680 | (macro ,@(cdr (caddr e))))))) 681 | ((scm kawa umbscheme) 682 | (lambda (e) 683 | `(defmacro ,(cadr e) ,(cadr (caddr e)) 684 | ,@(cddr (caddr e))))) 685 | ((scheme48 scsh) 686 | (lambda (e) 687 | `(define-syntax ,(cadr e) 688 | (lambda (__form __renamee __compare) 689 | (apply ,(caddr e) (cdr __form)))))) 690 | ((gambit) 691 | (lambda (e) 692 | `(begin ,e 693 | (eval ',e)))) 694 | ((chez petite sxm) 695 | (lambda (e) 696 | `(define-syntax ,(cadr e) 697 | (lambda (x) 698 | (syntax-case x () 699 | ((k . stuff) 700 | (datum->syntax-object (syntax k) 701 | (apply ,(caddr e) 702 | (cdr (syntax-object->datum x)))))))))) 703 | ((mzscheme plt racket) 704 | (lambda (e) 705 | (let ((e `(define-syntax ,(cadr e) 706 | (lambda (so) 707 | (datum->syntax so 708 | (let ((so-d (syntax->datum so))) 709 | (apply ,(caddr e) (cdr so-d)))))))) 710 | (if *compile?* (eval e) #f) 711 | e))) 712 | (else ;guile, bigloo, pscheme, etc 713 | (lambda (e) e)))) 714 | 715 | 'eval-in-cl-also 716 | (define translate-port-to-port 717 | (lambda (i o) 718 | (letrec ((process-top-level-expression 719 | (lambda (x) 720 | (let* ((a (if (pair? x) (car x) #f)) 721 | (names (names-defined x)) 722 | (name (and (pair? names) (car names)))) 723 | (cond ((not (pair? x)) 'skip) 724 | ((and (not (memv a '(scmxlate-ignoredef 725 | scmxlate-ignore-define 726 | scmxlate-ignore 727 | scmxlate-ignoredef-rename 728 | scmxlate-rename-define))) 729 | (memv name *names-defined*)) 730 | 'skip) 731 | (else 732 | (if (pair? names) 733 | (set! *names-defined* 734 | (append names *names-defined*)) 735 | #f) 736 | (cond (*reading-source-file?* 737 | (case a 738 | ((define-macro) 739 | (writeln (translate-define-macro x) o)) 740 | ((define-syntax) 741 | (writeln (translate-define-syntax x) o)) 742 | (else 743 | (if (not (memv a *calls-disallowed*)) 744 | (writeln x o) 745 | #f)))) 746 | (else 747 | (case a 748 | ((scmxlate-rename 749 | scmxlate-ignoredef-rename 750 | scmxlate-rename-define) 751 | (for-each 752 | (lambda (x-y) 753 | (let ((x (car x-y))) 754 | ;(set! *names-defined* 755 | ; (cons x *names-defined*)) 756 | (set! *aliases* 757 | (cons (cons x (cadr x-y)) 758 | *aliases*)))) 759 | (cdr x))) 760 | ((scmxlate-include) 761 | (translate-file-to-port 762 | (string-append "dialects/" 763 | (cadr x)) o)) 764 | ((scmxlate-insert) 765 | (for-each 766 | (lambda (e) (display (eval1 e) o)) 767 | (cdr x))) 768 | ((scmxlate-postamble) 769 | (translate-source-file o)) 770 | ((scmxlate-postprocess) 771 | (set! *postprocessing* 772 | (append *postprocessing* (cdr x)))) 773 | ((scmxlate-prefix) 774 | (let ((pfx (eval1 (cadr x)))) 775 | (for-each 776 | (lambda (id) 777 | (set! *aliases* 778 | (cons (cons 779 | id 780 | (string->symbol 781 | (string-append 782 | pfx 783 | (symbol->string id)))) 784 | *aliases*))) 785 | (cddr x)))) 786 | ;((scmxlate-target-file) 787 | ; (set! *target-file* (cadr x))) 788 | ((scmxlate-compile scmxlate-compile?) 789 | (set! *compile?* 790 | (let ((c (cadr x))) 791 | (cond ((not c) #f) 792 | ((compile-possible?) #t) 793 | (else 794 | (display "Sorry, compile not possible.") 795 | (newline) 796 | #f))))) 797 | ((scmxlate-uncall) 798 | (set! *calls-disallowed* 799 | (append (cdr x) *calls-disallowed*))) 800 | ((scmxlate-ignoredef 801 | scmxlate-ignore-define 802 | scmxlate-ignore) #f) 803 | ((scmxlate-eval) 804 | (for-each eval1 (cdr x))) 805 | ((scmxlate-cond) 806 | (let loop ((cc (cdr x))) 807 | (if (null? cc) #f 808 | (let ((c (car cc)) (cc (cdr cc))) 809 | (if (or 810 | (and (null? cc) 811 | (eqv? (car c) 'else)) 812 | (eval1 (car c))) 813 | (for-each 814 | process-top-level-expression 815 | (cdr c)) 816 | (loop cc)))))) 817 | (else 818 | (writeln x o))))))))))) 819 | (let loop () 820 | (let ((x (read i))) 821 | (if (not (eof-object? x)) 822 | (begin 823 | (process-top-level-expression x) 824 | (loop)) 825 | #f)))))) 826 | 827 | 'eval-in-cl-also 828 | (define translate-file-to-port 829 | (lambda (f o) 830 | (call-with-input-file f 831 | (lambda (i) 832 | (translate-port-to-port i o))))) 833 | 834 | ;(define guile-load 835 | ; (if (eqv? *dialect* 'guile) load #f)) 836 | 837 | (define scmxlate-system 838 | (lambda (s) 839 | (if (eqv? *operating-system* 'unix) 840 | (case *dialect* 841 | ((bigloo chez chicken guile kawa mzscheme petite plt racket 842 | scheme48 scm stk stklos sxm umbscheme ypsilon) 843 | (system s)) 844 | ((gambit) 845 | (shell-command s)) 846 | ((gauche) 847 | (sys-system s)) 848 | ((mitscheme) 849 | ((if (environment-bound? user-initial-environment 'unix/system) 850 | unix/system run-shell-command) s)) 851 | ((scsh) 852 | (eval (let* ((i (make-string-input-port 853 | (string-append 854 | "(run (" 855 | s "))"))) 856 | (e (read i))) 857 | e) 858 | (interaction-environment))) 859 | (else (display "Do") (newline) 860 | (display " ") (display s) (newline))) 861 | #f))) 862 | 863 | (define chmod+x 864 | (lambda (f) 865 | (if (and (eqv? *operating-system* 'unix) 866 | *shell-script?* 867 | (not (and (eqv? *dialect* 'mitscheme) *compile?*))) 868 | (scmxlate-system (string-append "chmod +x " f)) 869 | #f))) 870 | 871 | (define *predefined-aliases* 872 | (case *dialect* 873 | ((bigloo) 874 | '( 875 | (false . #f) 876 | (file-or-directory-modify-seconds . file-modification-time) 877 | (null . '()) 878 | (true . #t) 879 | )) 880 | ((chibi) 881 | '( 882 | (false . #f) 883 | (getenv . get-environment-variable) 884 | (null . '()) 885 | (true . #t) 886 | )) 887 | ((chicken) 888 | '( 889 | (false . #f) 890 | (file-or-directory-modify-seconds . file-modification-time) 891 | (getenv . get-environment-variable) 892 | (null . '()) 893 | (true . #t) 894 | )) 895 | ((gauche) 896 | `( 897 | (current-seconds . sys-time) 898 | (delete-file . sys-remove) 899 | ;(eof . ,(with-input-from-string "" read-char)) 900 | ;(file-or-directory-modify-seconds . file-mtime) 901 | (false . #f) 902 | (flush-output . flush) 903 | (getenv . sys-getenv) 904 | (null . '()) 905 | (system . sys-system) 906 | (true . #t))) 907 | ((guile) 908 | '((andmap . and-map) 909 | (current-seconds . current-time) 910 | (eof . the-eof-object) 911 | (flush-output . force-output) 912 | (load . primitive-load) 913 | (ormap . or-map) 914 | )) 915 | ((ikarus) 916 | '((false . #f) 917 | (null . '()) 918 | (true . #t))) 919 | ((kawa) 920 | '((flush-output . force-output))) 921 | ((mitscheme) 922 | `((false . #f) 923 | (file-or-directory-modify-seconds . file-modification-time) 924 | (gensym . generate-uninterned-symbol) 925 | (getenv . get-environment-variable) 926 | (null . '()) 927 | (open-input-string . string->input-port) 928 | (system . ,(if (environment-bound? user-initial-environment 'unix/system) 929 | 'unix/system 'run-shell-command)) 930 | (true . #t) 931 | )) 932 | ((chez petite) 933 | '((false . #f) 934 | (flush-output . flush-output-port) 935 | (null . '()) 936 | (true . #t) 937 | )) 938 | ((gambit) 939 | `( 940 | (false . #f) 941 | (flush-output . force-output) 942 | ;(get-output-string . close-output-port) 943 | (null . '()) 944 | (system . shell-command) 945 | ;(system . ,(call-with-input-string "##shell-command" read)) 946 | (true . #t) 947 | )) 948 | ((scheme48) 949 | '((delete-file . unlink) 950 | (false . #f) 951 | (getenv . lookup-environment-variable) 952 | (get-output-string . string-output-port-output) 953 | (null . '()) 954 | (open-output-string . make-string-output-port) 955 | (true . #t) 956 | )) 957 | ((scsh) 958 | '((current-seconds . time) 959 | (flush-output . force-output) 960 | (get-output-string . string-output-port-output) 961 | (open-output-string . make-string-output-port))) 962 | ((scm) 963 | '( 964 | (current-seconds . current-time) 965 | (false . #f) 966 | (null . '()) 967 | (true . #t) 968 | )) 969 | ((stklos) 970 | '( 971 | (false . #f) 972 | (flush-output . flush) 973 | (null . '()) 974 | (true . #t))) 975 | ((sxm) 976 | '((current-seconds . current-time) 977 | ;(flush-output . flush) 978 | )) 979 | (else '()))) 980 | 981 | 'eval-in-cl-also 982 | (define translate-source-file 983 | (lambda (o) 984 | (if (not *source-file-translated?*) 985 | ;scmxlate-postamble may already have translated 986 | ;source file! 987 | (begin 988 | (set! *source-file-translated?* #t) 989 | (call-with-input-file *source-file* 990 | (lambda (i) 991 | (cond ((> *num-of-lines-to-skip* 0) 992 | (let loop ((n *num-of-lines-to-skip*)) 993 | (if (= n 0) #f 994 | (begin (read-a-line i) (loop (- n 1)))))) 995 | ((char=? (peek-char i) #\#) 996 | (set! *shell-script?* #t) 997 | (read-a-line i) 998 | (display "; ensure shell-magic above" o) 999 | (newline o))) 1000 | (display ";Configured for " o) 1001 | (case *dialect* 1002 | ((cl) 1003 | (display "Common Lisp " o) 1004 | (display (lisp-implementation-type) o) 1005 | (display #\space o) 1006 | (display (lisp-implementation-version) o)) 1007 | (else 1008 | (display "Scheme dialect " o) 1009 | (display *dialect* o))) 1010 | (display " by scmxlate, v " o) 1011 | (display *scmxlate-version* o) 1012 | (display "," o) (newline o) 1013 | (display ";(c) Dorai Sitaram, " o) (newline o) 1014 | (display ";https://github.com/ds26gte/scmxlate" o) 1015 | (display "scmxlate/scmxlate.html" o) 1016 | (newline o) (newline o) 1017 | (set! *reading-source-file?* #t) 1018 | (translate-port-to-port i o) 1019 | (set! *reading-source-file?* #f) 1020 | (newline o)))) 1021 | #f))) 1022 | 1023 | ;(if (eqv? *dialect* 'guile) 1024 | ; (eval1 `(set! load primitive-load)) 1025 | ; #f) 1026 | 1027 | 'eval-in-cl-also 1028 | (cond ((not (memv *dialect* *dialects-supported*)) 1029 | (display "Sorry, dialect ") 1030 | (display *dialect*) 1031 | (display " is not supported. :-<") (newline)) 1032 | ((not (or (memv *operating-system* '(unix windows)) 1033 | (memv *operating-system* *operating-systems-supported*))) 1034 | (display "Sorry, operating system ") 1035 | (display *operating-system*) 1036 | (display " is not supported. :-<") (newline)) 1037 | (else 1038 | (for-each 1039 | (lambda (file-to-be-ported) 1040 | (newline) 1041 | (display "Porting ") 1042 | (display file-to-be-ported) 1043 | (display " ...") (newline) 1044 | (set! *shell-script?* #f) 1045 | (set! *compile?* 'ask) 1046 | (set! *source-file* file-to-be-ported) 1047 | (set! *source-file-translated?* #f) 1048 | (set! *postprocessing* '()) 1049 | (set! *names-defined* '()) 1050 | (set! *calls-disallowed* '()) 1051 | (set! *aliases* *predefined-aliases*) 1052 | (let* ((user-override-file 1053 | (let ((f (string-append "scmxlate-" file-to-be-ported))) 1054 | (and (exists-file? f) f))) 1055 | (skip-lines-file 1056 | (let ((f (string-append "scmxlate-skip-lines-" file-to-be-ported))) 1057 | (and (exists-file? f) f))) 1058 | (dialect-override-file 1059 | (let ((f (string-append "dialects/" 1060 | *dialect-s* file-to-be-ported))) 1061 | (and (exists-file? f) f))) 1062 | (target-file 1063 | (string-append "my-" file-to-be-ported))) 1064 | (set! *num-of-lines-to-skip* 1065 | (if skip-lines-file (call-with-input-file skip-lines-file read) 0)) 1066 | (ensure-file-deleted target-file) 1067 | (call-with-output-file target-file 1068 | (lambda (o) 1069 | (for-each 1070 | (lambda (f) 1071 | (if f (translate-file-to-port f o) #f)) 1072 | (list 1073 | user-override-file 1074 | dialect-override-file )) 1075 | (translate-source-file o))) 1076 | 1077 | ;compile? 1078 | (if (eqv? *compile?* 'ask) 1079 | (set! *compile?* 1080 | (if (compile-possible?) 1081 | (begin 1082 | (display "Compile? [") 1083 | (display #t) (display " ") (display #f) 1084 | (display "]") 1085 | (newline) (read)) 1086 | #f)) 1087 | #f) 1088 | 1089 | (if *compile?* (set! target-file (kompile target-file)) 1090 | #f) 1091 | 1092 | (chmod+x target-file) 1093 | 1094 | (cond ((null? *postprocessing*) 1095 | (display "Resulting file is `") 1096 | (display target-file) 1097 | (display "'.") (newline) 1098 | (display "You may want to rename it.") (newline)) 1099 | (else 1100 | (for-each eval1 *postprocessing*))) 1101 | )) 1102 | *files-to-be-ported*))) 1103 | 1104 | ;(if (eqv? *dialect* 'guile) 1105 | ; (eval1 `(set! load guile-load)) 1106 | ; #f) 1107 | 1108 | (if (eqv? *dialect* 'scsh) (force-output) 1109 | #f) 1110 | 1111 | ;exit Scheme if possible 1112 | 1113 | (case *dialect* 1114 | ((bigloo chez chibi chicken gambit gauche guile kawa mzscheme petite plt pscheme 1115 | racket scsh stk stklos sxm) (exit)) 1116 | ((mitscheme) (%exit)) 1117 | ((scm) (quit)) 1118 | (else (display "You may exit Scheme now!") 1119 | (newline))) 1120 | --------------------------------------------------------------------------------