;;; Some Scheme implementations do not support any macro facility ;;; whatsoever. For such systems we have created the procedure ;;; EOPL->Standard-Scheme, which takes as input a Scheme expression ;;; and expands out instances of define-record and variant-case, ;;; leaving everything else as it was. ;;; ;;; The procedure EOPL-file->Standard-Scheme-file takes as its arguments ;;; two filenames. It applies EOPL->Standard-Scheme to each ;;; expression in the first file, producing the second file as output. ;;; ;;; To get readable output, you should define the variable ;;; EOPL->Standard-Scheme-prettyprinter to be the prettyprinter in ;;; your implementation of Scheme. If your Scheme does not have a ;;; prettyprinter, then you will have to re-indent the output file ;;; manually. In this case, we recommend using GNU Emacs; our ;;; scheme.el, which contains an indentation algorithm, is also available ;;; via anonymous ftp. ;;; ;;; Below is a trace of the facility, followed by its implementation. ;;; ;> (EOPL->Standard-Scheme ; '(define-record howdy (hi hello))) ; ;(begin ; (define make-howdy ; (lambda (hi hello) (vector 'howdy hi hello))) ; (define howdy? ; (lambda (obj) ; (if (vector? obj) ; (if (= (vector-length obj) 3) ; (eq? (vector-ref obj 0) 'howdy) ; #f) ; #f))) ; (define howdy->hi ; (lambda (obj) ; (if (howdy? obj) ; (vector-ref obj 1) ; (error "howdy->hi: bad record" obj)))) ; (define howdy->hello ; (lambda (obj) ; (if (howdy? obj) ; (vector-ref obj 2) ; (error "howdy->hello: bad record" obj)))) ; 'howdy) ; ;> (EOPL->Standard-Scheme ; '(define-record foo (bar baz top))) ; ;(begin ; (define make-foo ; (lambda (bar baz top) (vector 'foo bar baz top))) ; (define foo? ; (lambda (obj) ; (if (vector? obj) ; (if (= (vector-length obj) 4) ; (eq? (vector-ref obj 0) 'foo) ; #f) ; #f))) ; (define foo->bar ; (lambda (obj) ; (if (foo? obj) ; (vector-ref obj 1) ; (error "foo->bar: bad record" obj)))) ; (define foo->baz ; (lambda (obj) ; (if (foo? obj) ; (vector-ref obj 2) ; (error "foo->baz: bad record" obj)))) ; (define foo->top ; (lambda (obj) ; (if (foo? obj) ; (vector-ref obj 3) ; (error "foo->top: bad record" obj)))) ; 'foo) ; ;> (EOPL->Standard-Scheme ; '(begin ; (write ; (cons 9 ; (variant-case (make-foo 10 11 12) ; (howdy (hi hello) 99) ; (foo (baz top bar) (list bar baz top)) ; (else 100)))) ; (newline))) ; ;(begin ; (write ; (cons 9 ; (let ((g2 (make-foo 10 11 12))) ; (cond ; ((howdy? g2) ; (let ((hi (howdy->hi g2)) ; (hello (howdy->hello g2))) ; 99)) ; ((foo? g2) ; (let ((baz (foo->baz g2)) ; (top (foo->top g2)) ; (bar (foo->bar g2))) ; (list bar baz top))) ; (else 100))))) ; (newline)) ; ;;; End of trace ;;; ;;; If testout.ss does not exist and if testin.ss ;;; contains the file, without the semi-colons: ;(define-record howdy (hi hello)) ; ;(define-record foo (bar baz top)) ; ;(begin ; (write ; (cons 9 ; (variant-case (make-foo 10 11 12) ; (howdy (hi hello) 99) ; (foo (baz top bar) (list bar baz top)) ; (else 100)))) ; (newline)) ; ;;; ;;; then testout.ss will contain the file with the ;;; three expressions expanded so that define-record ;;; and variant-case will disappear. ;;; ;> (EOPL-file->Standard-Scheme-file "testin.ss" "testout.ss") ;> (load "testout.ss") ;(9 10 11 12) ;;; ;;; Beginning of Implementation ;;; ;;; name of local prettyprinter (define EOPL->Standard-Scheme-prettyprinter pretty-print) (define EOPL-file->Standard-Scheme-file (lambda (in-file out-file) (let ((in-port (open-input-file in-file)) (out-port (open-output-file out-file))) (letrec ((loop (lambda (exp) (if (not (eof-object? exp)) (begin (EOPL->Standard-Scheme-prettyprinter (EOPL->Standard-Scheme exp) out-port) (newline out-port) (loop (read in-port))))))) (loop (read in-port))) (close-input-port in-port) (close-output-port out-port)))) (define EOPL->Standard-Scheme (lambda (e) (cond ((pair? e) (if (eq? (car e) 'define-record) (expand-define-record e) (EOPL-expander e))) (else e)))) (define EOPL-expander (lambda (e) (cond ((pair? e) (cond ((eq? (car e) 'quote) e) ((eq? (car e) 'variant-case) (expand-variant-case e)) (else (map EOPL-expander e)))) (else e)))) (define expand-define-record (lambda (e) (let ((name (dr-exp->name e)) (field-list (dr-exp->field-list e))) `(begin (define ,(stick-make-on-front name) (lambda ,field-list (vector ',name ,@field-list))) (define ,(stick-?-on-end name) (lambda (obj) (if (vector? obj) (if (= (vector-length obj) ,(+ (length field-list) 1)) (eq? (vector-ref obj 0) ',name) #f) #f))) ,@(letrec ((loop (lambda (field-list i) (cond ((null? field-list) '()) (else (let ((field (car field-list))) (cons `(define ,(combine-with-arrow name field) (lambda (obj) (if (,(stick-?-on-end name) obj) (vector-ref obj ,i) (error ,(string-append (symbol->string (combine-with-arrow name field)) ": bad record") obj)))) (loop (cdr field-list) (+ i 1))))))))) (loop field-list 1)) ',name )))) (define expand-variant-case (lambda (e) (let ((g (string->symbol (symbol->string (gensym))))) `(let ((,g ,(EOPL-expander (v-c-exp->record-exp e)))) (cond ,@(map (lambda (clause) (let ((name (v-c-clause->name clause))) (if (eq? name 'else) clause (let ((field-list (v-c-clause->field-list clause))) `((,(stick-?-on-end name) ,g) (let ,(map (lambda (field) `(,field (,(combine-with-arrow name field) ,g))) field-list) ,@(map EOPL-expander (v-c-clause->consequent-list clause)))))))) (v-c-exp->clauses e))))))) (define dr-exp->name (lambda (e) (ensure-at-least 2 e) (ensure-just-a-symbol (cadr e)) (cadr e))) (define dr-exp->field-list (lambda (e) (ensure-at-least 3 e) (ensure-only-symbols (caddr e)) (caddr e))) (define v-c-exp->record-exp (lambda (e) (ensure-at-least 2 e) (cadr e))) (define v-c-exp->clauses (lambda (e) (ensure-at-least 3 e) (cddr e))) (define v-c-clause->name (lambda (c) (ensure-at-least 1 c) (ensure-just-a-symbol (car c)) (car c))) (define v-c-clause->field-list (lambda (c) (ensure-at-least 2 c) (ensure-only-symbols (cadr c)) (cadr c))) (define v-c-clause->consequent-list (lambda (c) (ensure-at-least 3 c) (cddr c))) (define ensure-at-least (lambda (this-many exp) (letrec ((at-least (lambda (n e) (cond ((zero? n) ') ((pair? e) (at-least (- n 1) (cdr e))) (else (error "List too short, expected at least" this-many "in the expression:" exp)))))) (at-least this-many exp)))) (define ensure-just-a-symbol (lambda (expect-symbol) (if (symbol? expect-symbol) ' (error "This is not a symbol:" expect-symbol)))) (define ensure-only-symbols (lambda (expect-symbol-list) (letrec ((only-symbols (lambda (ls) (cond ((pair? ls) (if (symbol? (car ls)) (only-symbols (cdr ls)) (error "This contains a non-symbol:" expect-symbol-list))) ((null? ls) ') (else (error "This is not a proper list:" expect-symbol-list)))))) (only-symbols expect-symbol-list)))) (define stick-?-on-end (lambda (name) (string->symbol (string-append (symbol->string name) "?")))) (define stick-make-on-front (lambda (x) (string->symbol (string-append (symbol->string 'make-) (symbol->string x))))) (define combine-with-arrow (lambda (name field) (string->symbol (string-append (symbol->string name) "->" (symbol->string field)))))