Projects : gscm : gscm_usrbin
| 1 | ;;; Test the GSCM compiler, e.g. to run it on its own code. Should support any |
| 2 | ;;; standard R5RS implementation, including the bare GSCM interpreter. |
| 3 | |
| 4 | (define error #f) |
| 5 | (define variable-ref (lambda (sym) sym)) |
| 6 | ;; to verify variable ref conversion |
| 7 | ;(define variable-ref (lambda (sym) (list 'variable-ref sym))) |
| 8 | ;(define *max-parameters* 10) ; deliberately low for testing |
| 9 | (define *max-parameters* (expt 2 24)) |
| 10 | (define car/unchecked car) |
| 11 | (define cdr/unchecked cdr) |
| 12 | (define fx=/unchecked =) |
| 13 | (define fx</unchecked <) |
| 14 | (define fx+/unchecked +) |
| 15 | (define fx-/unchecked -) |
| 16 | (define fxneg/unchecked -) |
| 17 | (define apply/unchecked apply) |
| 18 | (define vector-ref/unchecked vector-ref) |
| 19 | |
| 20 | (define compile (eval (with-input-from-file "compiler.scm" read) |
| 21 | (interaction-environment))) |
| 22 | |
| 23 | (define compile-loop |
| 24 | (lambda () |
| 25 | ((lambda (val) |
| 26 | (if (eof-object? val) '() |
| 27 | (begin (write (compile val)) |
| 28 | (newline) |
| 29 | (flush-output-port) ; XXX |
| 30 | (compile-loop)))) |
| 31 | (read)))) |
| 32 | |
| 33 | (call-with-current-continuation |
| 34 | (lambda (restart) |
| 35 | (set! error |
| 36 | (lambda (msg . detail) |
| 37 | (display "ERROR: ") |
| 38 | (display msg) |
| 39 | (if (not (null? detail)) |
| 40 | (begin (display " ") |
| 41 | (write (car detail)))) |
| 42 | (newline) |
| 43 | (flush-output-port) ; XXX |
| 44 | (restart '()))))) |
| 45 | |
| 46 | (compile-loop) |