diff options
Diffstat (limited to 'module/language')
49 files changed, 28656 insertions, 0 deletions
diff --git a/module/language/assembly.scm b/module/language/assembly.scm new file mode 100644 index 000000000..683da6cc1 --- /dev/null +++ b/module/language/assembly.scm @@ -0,0 +1,165 @@ +;;; Guile Virtual Machine Assembly + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language assembly) + #:use-module (rnrs bytevector) + #:use-module (system base pmatch) + #:use-module (system vm instruction) + #:use-module ((srfi srfi-1) #:select (fold)) + #:export (byte-length + addr+ align-program align-code align-block + assembly-pack assembly-unpack + object->assembly assembly->object)) + +;; nargs, nrest, nlocs, len, metalen, padding +(define *program-header-len* (+ 1 1 2 4 4 4)) + +;; lengths are encoded in 3 bytes +(define *len-len* 3) + + +(define (byte-length assembly) + (pmatch assembly + (,label (guard (not (pair? label))) + 0) + ((load-number ,str) + (+ 1 *len-len* (string-length str))) + ((load-string ,str) + (+ 1 *len-len* (string-length str))) + ((load-wide-string ,str) + (+ 1 *len-len* (* 4 (string-length str)))) + ((load-symbol ,str) + (+ 1 *len-len* (string-length str))) + ((load-array ,bv) + (+ 1 *len-len* (bytevector-length bv))) + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) + (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) + ((,inst . _) (guard (>= (instruction-length inst) 0)) + (+ 1 (instruction-length inst))) + (else (error "unknown instruction" assembly)))) + + +(define *program-alignment* 8) + +(define *block-alignment* 8) + +(define (addr+ addr code) + (fold (lambda (x len) (+ (byte-length x) len)) + addr + code)) + +(define (code-alignment addr alignment header-len) + (make-list (modulo (- alignment + (modulo (+ addr header-len) alignment)) + alignment) + '(nop))) + +(define (align-block addr) + (code-alignment addr *block-alignment* 0)) + +(define (align-code code addr alignment header-len) + `(,@(code-alignment addr alignment header-len) + ,code)) + +(define (align-program prog addr) + (align-code prog addr *program-alignment* 1)) + +;;; +;;; Code compress/decompression +;;; + +(define *abbreviations* + '(((make-int8 0) . (make-int8:0)) + ((make-int8 1) . (make-int8:1)))) + +(define *expansions* + (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) + +(define (assembly-pack code) + (or (assoc-ref *abbreviations* code) + code)) + +(define (assembly-unpack code) + (or (assoc-ref *expansions* code) + code)) + + +;;; +;;; Encoder/decoder +;;; + +(define (object->assembly x) + (cond ((eq? x #t) `(make-true)) + ((eq? x #f) `(make-false)) + ((null? x) `(make-eol)) + ((and (integer? x) (exact? x)) + (cond ((and (<= -128 x) (< x 128)) + (assembly-pack `(make-int8 ,(modulo x 256)))) + ((and (<= -32768 x) (< x 32768)) + (let ((n (if (< x 0) (+ x 65536) x))) + `(make-int16 ,(quotient n 256) ,(modulo n 256)))) + ((and (<= 0 x #xffffffffffffffff)) + `(make-uint64 ,@(bytevector->u8-list + (let ((bv (make-bytevector 8))) + (bytevector-u64-set! bv 0 x (endianness big)) + bv)))) + ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff)) + `(make-int64 ,@(bytevector->u8-list + (let ((bv (make-bytevector 8))) + (bytevector-s64-set! bv 0 x (endianness big)) + bv)))) + (else #f))) + ((char? x) + (cond ((<= (char->integer x) #xff) + `(make-char8 ,(char->integer x))) + (else + `(make-char32 ,(char->integer x))))) + (else #f))) + +(define (assembly->object code) + (pmatch code + ((make-true) #t) + ((make-false) #f) ;; FIXME: Same as the `else' case! + ((make-eol) '()) + ((make-int8 ,n) + (if (< n 128) n (- n 256))) + ((make-int16 ,n1 ,n2) + (let ((n (+ (* n1 256) n2))) + (if (< n 32768) n (- n 65536)))) + ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) + (bytevector-u64-ref + (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) + 0 + (endianness big))) + ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) + (bytevector-s64-ref + (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) + 0 + (endianness big))) + ((make-char8 ,n) + (integer->char n)) + ((make-char32 ,n1 ,n2 ,n3 ,n4) + (integer->char (+ (* n1 #x1000000) + (* n2 #x10000) + (* n3 #x100) + n4))) + ((load-string ,s) s) + ((load-symbol ,s) (string->symbol s)) + (else #f))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm new file mode 100644 index 000000000..688cb6b31 --- /dev/null +++ b/module/language/assembly/compile-bytecode.scm @@ -0,0 +1,158 @@ +;;; Guile VM assembler + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language assembly compile-bytecode) + #:use-module (system base pmatch) + #:use-module (language assembly) + #:use-module (system vm instruction) + #:use-module (srfi srfi-4) + #:use-module (rnrs bytevector) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module ((system vm objcode) #:select (byte-order)) + #:export (compile-bytecode write-bytecode)) + +(define (compile-bytecode assembly env . opts) + (pmatch assembly + ((load-program . _) + ;; the 1- and -1 are so that we drop the load-program byte + (letrec ((v (make-u8vector (1- (byte-length assembly)))) + (i -1) + (write-byte (lambda (b) + (if (>= i 0) (u8vector-set! v i b)) + (set! i (1+ i)))) + (get-addr (lambda () i))) + (write-bytecode assembly write-byte get-addr '()) + (if (= i (u8vector-length v)) + (values v env env) + (error "incorrect length in assembly" i (u8vector-length v))))) + (else (error "bad assembly" assembly)))) + +(define (write-bytecode asm write-byte get-addr labels) + (define (write-char c) + (write-byte (char->integer c))) + (define (write-string s) + (string-for-each write-char s)) + (define (write-uint16-be x) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand x 255))) + (define (write-uint16-le x) + (write-byte (logand x 255)) + (write-byte (logand (ash x -8) 255))) + (define (write-uint32-be x) + (write-byte (logand (ash x -24) 255)) + (write-byte (logand (ash x -16) 255)) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand x 255))) + (define (write-uint32-le x) + (write-byte (logand x 255)) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand (ash x -16) 255)) + (write-byte (logand (ash x -24) 255))) + (define (write-uint32 x) + (case byte-order + ((1234) (write-uint32-le x)) + ((4321) (write-uint32-be x)) + (else (error "unknown endianness" byte-order)))) + (define (write-wide-string s) + (write-loader-len (* 4 (string-length s))) + (string-for-each (lambda (c) (write-uint32 (char->integer c))) s)) + (define (write-loader-len len) + (write-byte (ash len -16)) + (write-byte (logand (ash len -8) 255)) + (write-byte (logand len 255))) + (define (write-loader str) + (write-loader-len (string-length str)) + (write-string str)) + (define (write-sized-loader str) + (let ((len (string-length str)) + (wid (string-bytes-per-char str))) + (write-loader-len len) + (write-byte wid) + (if (= wid 4) + (write-wide-string str) + (write-string str)))) + (define (write-bytevector bv) + (write-loader-len (bytevector-length bv)) + ;; Ew! + (for-each write-byte (bytevector->u8-list bv))) + (define (write-break label) + (let ((offset (- (assq-ref labels label) + (logand (+ (get-addr) 2) (lognot #x7))))) + (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset)) + ((>= offset (ash 1 18)) (error "jump too far forward" offset)) + ((< offset (- (ash 1 18))) (error "jump too far backwards" offset)) + (else (write-uint16-be (ash offset -3)))))) + + (let ((inst (car asm)) + (args (cdr asm)) + (write-uint16 (case byte-order + ((1234) write-uint16-le) + ((4321) write-uint16-be) + (else (error "unknown endianness" byte-order))))) + (let ((opcode (instruction->opcode inst)) + (len (instruction-length inst))) + (write-byte opcode) + (pmatch asm + ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) + (write-byte nargs) + (write-byte nrest) + (write-uint16 nlocs) + (write-uint32 length) + (write-uint32 (if meta (1- (byte-length meta)) 0)) + (write-uint32 0) ; padding + (letrec ((i 0) + (write (lambda (x) (set! i (1+ i)) (write-byte x))) + (get-addr (lambda () i))) + (for-each (lambda (asm) + (write-bytecode asm write get-addr labels)) + code)) + (if meta + ;; don't write the load-program byte for metadata + (letrec ((i -1) + (write (lambda (x) + (set! i (1+ i)) + (if (> i 0) (write-byte x)))) + (get-addr (lambda () i))) + ;; META's bytecode meets the alignment requirements of + ;; `scm_objcode', thanks to the alignment computed in + ;; `(language assembly)'. + (write-bytecode meta write get-addr '())))) + ((make-char32 ,x) (write-uint32-be x)) + ((load-number ,str) (write-loader str)) + ((load-string ,str) (write-loader str)) + ((load-wide-string ,str) (write-wide-string str)) + ((load-symbol ,str) (write-loader str)) + ((load-array ,bv) (write-bytevector bv)) + ((br ,l) (write-break l)) + ((br-if ,l) (write-break l)) + ((br-if-not ,l) (write-break l)) + ((br-if-eq ,l) (write-break l)) + ((br-if-not-eq ,l) (write-break l)) + ((br-if-null ,l) (write-break l)) + ((br-if-not-null ,l) (write-break l)) + ((mv-call ,n ,l) (write-byte n) (write-break l)) + (else + (cond + ((< (instruction-length inst) 0) + (error "unhanded variable-length instruction" asm)) + ((not (= (length args) len)) + (error "bad number of args to instruction" asm len)) + (else + (for-each write-byte args)))))))) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm new file mode 100644 index 000000000..8cdebcfd0 --- /dev/null +++ b/module/language/assembly/decompile-bytecode.scm @@ -0,0 +1,134 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language assembly decompile-bytecode) + #:use-module (system vm instruction) + #:use-module (system base pmatch) + #:use-module (srfi srfi-4) + #:use-module (rnrs bytevector) + #:use-module (language assembly) + #:use-module ((system vm objcode) #:select (byte-order)) + #:export (decompile-bytecode)) + +(define (decompile-bytecode x env opts) + (let ((i 0) (size (u8vector-length x))) + (define (pop) + (let ((b (cond ((< i size) (u8vector-ref x i)) + ((= i size) #f) + (else (error "tried to decode too many bytes"))))) + (if b (set! i (1+ i))) + b)) + (let ((ret (decode-load-program pop))) + (if (= i size) + (values ret env) + (error "bad bytecode: only decoded ~a out of ~a bytes" i size))))) + +(define (br-instruction? x) + (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null))) + +(define (bytes->s16 a b) + (let ((x (+ (ash a 8) b))) + (if (zero? (logand (ash 1 15) x)) + x + (- x (ash 1 16))))) + +;; FIXME: this is a little-endian disassembly!!! +(define (decode-load-program pop) + (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) + (nlocs (+ nlocs0 (ash nlocs1 8))) + (a (pop)) (b (pop)) (c (pop)) (d (pop)) + (e (pop)) (f (pop)) (g (pop)) (h (pop)) + (len (+ a (ash b 8) (ash c 16) (ash d 24))) + (metalen (+ e (ash f 8) (ash g 16) (ash h 24))) + (totlen (+ len metalen)) + (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop)) + (labels '()) + (i 0)) + (define (ensure-label rel1 rel2) + (let ((where (+ (logand i (lognot #x7)) + (* (bytes->s16 rel1 rel2) 8)))) + (or (assv-ref labels where) + (begin + (let ((l (gensym ":L"))) + (set! labels (acons where l labels)) + l))))) + (define (sub-pop) ;; ...records. ha. ha. + (let ((b (cond ((< i len) (pop)) + ((= i len) #f) + (else (error "tried to decode too many bytes"))))) + (if b (set! i (1+ i))) + b)) + (let lp ((out '())) + (cond ((> i len) + (error "error decoding program -- read too many bytes" out)) + ((= i len) + `(load-program ,nargs ,nrest ,nlocs + ,(map (lambda (x) (cons (cdr x) (car x))) + (reverse labels)) + ,len + ,(if (zero? metalen) #f (decode-load-program pop)) + ,@(reverse! out))) + (else + (let ((exp (decode-bytecode sub-pop))) + (pmatch exp + ((,br ,rel1 ,rel2) (guard (br-instruction? br)) + (lp (cons `(,br ,(ensure-label rel1 rel2)) out))) + ((mv-call ,n ,rel1 ,rel2) + (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out))) + (else + (lp (cons exp out)))))))))) + +(define (decode-bytecode pop) + (and=> (pop) + (lambda (opcode) + (let ((inst (opcode->instruction opcode))) + (cond + ((eq? inst 'load-program) + (decode-load-program pop)) + + ((< (instruction-length inst) 0) + ;; the negative length indicates a variable length + ;; instruction + (let* ((make-sequence + (if (or (memq inst '(load-array load-wide-string))) + make-bytevector + make-string)) + (sequence-set! + (if (or (memq inst '(load-array load-wide-string))) + bytevector-u8-set! + (lambda (str pos value) + (string-set! str pos (integer->char value))))) + (len (let* ((a (pop)) (b (pop)) (c (pop))) + (+ (ash a 16) (ash b 8) c))) + (seq (make-sequence len))) + (let lp ((i 0)) + (if (= i len) + `(,inst ,(if (eq? inst 'load-wide-string) + (utf32->string seq) + seq)) + (begin + (sequence-set! seq i (pop)) + (lp (1+ i))))))) + (else + ;; fixed length + (let lp ((n (instruction-length inst)) (out (list inst))) + (if (zero? n) + (reverse! out) + (lp (1- n) (cons (pop) out)))))))))) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm new file mode 100644 index 000000000..492acb7e5 --- /dev/null +++ b/module/language/assembly/disassemble.scm @@ -0,0 +1,172 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language assembly disassemble) + #:use-module (ice-9 format) + #:use-module (system vm instruction) + #:use-module (system vm program) + #:use-module (system base pmatch) + #:use-module (language assembly) + #:use-module (system base compile) + #:export (disassemble)) + +(define (disassemble x) + (format #t "Disassembly of ~A:\n\n" x) + (call-with-values + (lambda () (decompile x #:from 'value #:to 'assembly)) + disassemble-load-program)) + +(define (disassemble-load-program asm env) + (pmatch asm + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code) + (let ((objs (and env (assq-ref env 'objects))) + (free-vars (and env (assq-ref env 'free-vars))) + (meta (and env (assq-ref env 'meta))) + (blocs (and env (assq-ref env 'blocs))) + (srcs (and env (assq-ref env 'sources)))) + (let lp ((pos 0) (code code) (programs '())) + (cond + ((null? code) + (newline) + (for-each + (lambda (sym+asm) + (format #t "Embedded program ~A:\n\n" (car sym+asm)) + (disassemble-load-program (cdr sym+asm) '())) + (reverse! programs))) + (else + (let* ((asm (car code)) + (len (byte-length asm)) + (end (+ pos len))) + (pmatch asm + ((load-program . _) + (let ((sym (gensym ""))) + (print-info pos `(load-program ,sym) #f #f) + (lp (+ pos (byte-length asm)) (cdr code) + (acons sym asm programs)))) + ((nop) + (lp (+ pos (byte-length asm)) (cdr code) programs)) + (else + (print-info pos asm + (code-annotation end asm objs nargs blocs + labels) + (and=> (and srcs (assq end srcs)) source->string)) + (lp (+ pos (byte-length asm)) (cdr code) programs))))))) + + (if (pair? free-vars) + (disassemble-free-vars free-vars)) + (if meta + (disassemble-meta meta)) + + ;; Disassemble other bytecode in it + ;; FIXME: something about the module. + (if objs + (for-each + (lambda (x) + (if (program? x) + (begin (display "----------------------------------------\n") + (disassemble x)))) + (cdr (vector->list objs)))))) + (else + (error "bad load-program form" asm)))) + +(define (disassemble-objects objs) + (display "Objects:\n\n") + (let ((len (vector-length objs))) + (do ((n 0 (1+ n))) + ((= n len) (newline)) + (print-info n (vector-ref objs n) #f #f)))) + +(define (disassemble-free-vars free-vars) + (display "Free variables:\n\n") + (let ((i 0)) + (cond ((< i (vector-length free-vars)) + (print-info i (vector-ref free-vars i) #f #f) + (lp (1+ i)))))) + +(define-macro (unless test . body) + `(if (not ,test) (begin ,@body))) + +(define *uninteresting-props* '(name)) + +(define (disassemble-meta meta) + (let ((sources (cadr meta)) + (props (filter (lambda (x) + (not (memq (car x) *uninteresting-props*))) + (cddr meta)))) + (unless (null? props) + (display "Properties:\n\n") + (for-each (lambda (x) (print-info #f x #f #f)) props) + (newline)))) + +(define (source->string src) + (format #f "~a:~a:~a" (or (source:file src) "(unknown file)") + (source:line src) (source:column src))) + +(define (make-int16 byte1 byte2) + (+ (* byte1 256) byte2)) + +(define (code-annotation end-addr code objs nargs blocs labels) + (let* ((code (assembly-unpack code)) + (inst (car code)) + (args (cdr code))) + (case inst + ((list vector) + (list "~a element~:p" (apply make-int16 args))) + ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) + (list "-> ~A" (assq-ref labels (car args)))) + ((object-ref) + (and objs (list "~s" (vector-ref objs (car args))))) + ((local-ref local-boxed-ref local-set local-boxed-set) + (and blocs + (let lp ((bindings (list-ref blocs (car args)))) + (and (pair? bindings) + (let ((b (car bindings))) + (if (and (< (binding:start (car bindings)) end-addr) + (>= (binding:end (car bindings)) end-addr)) + (list "`~a'~@[ (arg)~]" + (binding:name b) (< (binding:index b) nargs)) + (lp (cdr bindings)))))))) + ((free-ref free-boxed-ref free-boxed-set) + ;; FIXME: we can do better than this + (list "(closure variable)")) + ((toplevel-ref toplevel-set) + (and objs + (let ((v (vector-ref objs (car args)))) + (if (and (variable? v) (variable-bound? v)) + (list "~s" (variable-ref v)) + (list "`~s'" v))))) + ((mv-call) + (list "MV -> ~A" (assq-ref labels (cadr args)))) + (else + (and=> (assembly->object code) + (lambda (obj) (list "~s" obj))))))) + +;; i am format's daddy. +(define (print-info addr info extra src) + (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src)) + +(define (simplify x) + (cond ((string? x) + (cond ((string-index x #\newline) => + (lambda (i) (set! x (substring x 0 i))))) + (cond ((> (string-length x) 16) + (set! x (string-append (substring x 0 13) "...")))))) + x) + diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm new file mode 100644 index 000000000..286c80511 --- /dev/null +++ b/module/language/assembly/spec.scm @@ -0,0 +1,35 @@ +;;; Guile Virtual Machine Assembly + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language assembly spec) + #:use-module (system base language) + #:use-module (language assembly compile-bytecode) + #:use-module (language assembly decompile-bytecode) + #:export (assembly)) + +(define-language assembly + #:title "Guile Virtual Machine Assembly Language" + #:version "2.0" + #:reader read + #:printer write + #:parser read ;; fixme: make a verifier? + #:compilers `((bytecode . ,compile-bytecode)) + #:decompilers `((bytecode . ,decompile-bytecode)) + ) diff --git a/module/language/brainfuck/compile-scheme.scm b/module/language/brainfuck/compile-scheme.scm new file mode 100644 index 000000000..86bc35fdd --- /dev/null +++ b/module/language/brainfuck/compile-scheme.scm @@ -0,0 +1,126 @@ +;;; Brainfuck for GNU Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language brainfuck compile-scheme) + #:export (compile-scheme)) + +;; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of +;; brainfuck's instructions, there are basic representations in Scheme we +;; only have to generate. +;; +;; Brainfuck's pointer and data-tape are stored in the variables pointer and +;; tape, where tape is a vector of integer values initially set to zero. Pointer +;; starts out at position 0. +;; Our tape is thus of finite length, with an address range of 0..n for +;; some defined upper bound n depending on the length of our tape. + + +;; Define the length to use for the tape. + +(define tape-size 30000) + + +;; This compiles a whole brainfuck program. This constructs a Scheme code like: +;; (let ((pointer 0) +;; (tape (make-vector tape-size 0))) +;; (begin +;; <body> +;; (write-char #\newline))) +;; +;; So first the pointer and tape variables are set up correctly, then the +;; program's body is executed in this context, and finally we output an +;; additional newline character in case the program does not output one. +;; +;; TODO: Find out and explain the details about env, the three return values and +;; how to use the options. Implement options to set the tape-size, maybe. + +(define (compile-scheme exp env opts) + (values + `(let ((pointer 0) + (tape (make-vector ,tape-size 0))) + ,@(if (not (eq? '<brainfuck> (car exp))) + (error "expected brainfuck program") + `(begin + ,@(compile-body (cdr exp)) + (write-char #\newline)))) + env + env)) + + +;; Compile a list of instructions to get a list of Scheme codes. As we always +;; strip off the car of the instructions-list and cons the result onto the +;; result-list, it will get out in reversed order first; so we have to (reverse) +;; it on return. + +(define (compile-body instructions) + (let iterate ((cur instructions) + (result '())) + (if (null? cur) + (reverse result) + (let ((compiled (compile-instruction (car cur)))) + (iterate (cdr cur) (cons compiled result)))))) + + +;; Compile a single instruction to Scheme, using the direct representations +;; all of Brainfuck's instructions have. + +(define (compile-instruction ins) + (case (car ins) + + ;; Pointer moval >< is done simply by something like: + ;; (set! pointer (+ pointer +-1)) + ((<bf-move>) + (let ((dir (cadr ins))) + `(set! pointer (+ pointer ,dir)))) + + ;; Cell increment +- is done as: + ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) + ((<bf-increment>) + (let ((inc (cadr ins))) + `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc)))) + + ;; Output . is done by converting the cell's integer value to a character + ;; first and then printing out this character: + ;; (write-char (integer->char (vector-ref tape pointer))) + ((<bf-print>) + '(write-char (integer->char (vector-ref tape pointer)))) + + ;; Input , is done similarly, read in a character, get its ASCII code and + ;; store it into the current cell: + ;; (vector-set! tape pointer (char->integer (read-char))) + ((<bf-read>) + '(vector-set! tape pointer (char->integer (read-char)))) + + ;; For loops [...] we use a named let construction to execute the body until + ;; the current cell gets zero. The body is compiled via a recursive call + ;; back to (compile-body). + ;; (let iterate () + ;; (if (not (= (vector-ref! tape pointer) 0)) + ;; (begin + ;; <body> + ;; (iterate)))) + ((<bf-loop>) + `(let iterate () + (if (not (= (vector-ref tape pointer) 0)) + (begin + ,@(compile-body (cdr ins)) + (iterate))))) + + (else (error "unknown brainfuck instruction " (car ins))))) diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm new file mode 100644 index 000000000..0aaa11274 --- /dev/null +++ b/module/language/brainfuck/compile-tree-il.scm @@ -0,0 +1,181 @@ +;;; Brainfuck for GNU Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: + +;; Brainfuck is a simple language that mostly mimics the operations of a +;; Turing machine. This file implements a compiler from Brainfuck to +;; Guile's Tree-IL. + +;;; Code: + +(define-module (language brainfuck compile-tree-il) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;; Compilation of Brainfuck is pretty straight-forward. For all of +;; brainfuck's instructions, there are basic representations in Tree-IL +;; we only have to generate. +;; +;; Brainfuck's pointer and data-tape are stored in the variables pointer and +;; tape, where tape is a vector of integer values initially set to zero. Pointer +;; starts out at position 0. +;; Our tape is thus of finite length, with an address range of 0..n for +;; some defined upper bound n depending on the length of our tape. + + +;; Define the length to use for the tape. + +(define tape-size 30000) + + +;; This compiles a whole brainfuck program. This constructs a Tree-IL +;; code equivalent to Scheme code like this: +;; +;; (let ((pointer 0) +;; (tape (make-vector tape-size 0))) +;; (begin +;; <body> +;; (write-char #\newline))) +;; +;; So first the pointer and tape variables are set up correctly, then the +;; program's body is executed in this context, and finally we output an +;; additional newline character in case the program does not output one. +;; +;; The fact that we are compiling to Guile primitives gives this +;; implementation a number of interesting characteristics. First, the +;; values of the tape cells do not underflow or overflow. We could make +;; them do otherwise via compiling calls to "modulo" at certain points. +;; +;; In addition, tape overruns or underruns will be detected, and will +;; throw an error, whereas a number of Brainfuck compilers do not detect +;; this. +;; +;; Note that we're generating the S-expression representation of +;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL +;; data structures. This makes the compiler more pleasant to look at, +;; but we do lose is the ability to propagate source information. Since +;; Brainfuck is so obtuse anyway, this shouldn't matter ;-) +;; +;; `compile-tree-il' takes as its input the read expression, the +;; environment, and some compile options. It returns the compiled +;; expression, the environment appropriate for the next pass of the +;; compiler -- in our case, just the environment unchanged -- and the +;; continuation environment. +;; +;; The normal use of a continuation environment is if compiling one +;; expression changes the environment, and that changed environment +;; should be passed to the next compiled expression -- for example, +;; changing the current module. But Brainfuck is incapable of that, so +;; for us, the continuation environment is just the same environment we +;; got in. +;; +;; FIXME: perhaps use options or the env to set the tape-size? + +(define (compile-tree-il exp env opts) + (values + (parse-tree-il + `(let (pointer tape) (pointer tape) + ((const 0) + (apply (primitive make-vector) (const ,tape-size) (const 0))) + ,(compile-body exp))) + env + env)) + + +;; Compile a list of instructions to a Tree-IL expression. + +(define (compile-body instructions) + (let lp ((in instructions) (out '())) + (define (emit x) + (lp (cdr in) (cons x out))) + (cond + ((null? in) + ;; No more input, build our output. + (cond + ((null? out) '(void)) ; no output + ((null? (cdr out)) (car out)) ; single expression + (else `(begin ,@(reverse out)))) ; sequence + ) + (else + (pmatch (car in) + + ;; Pointer moves >< are done simply by something like: + ;; (set! pointer (+ pointer +-1)) + ((<bf-move> ,dir) + (emit `(set! (lexical pointer) + (apply (primitive +) (lexical pointer) (const ,dir))))) + + ;; Cell increment +- is done as: + ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) + ((<bf-increment> ,inc) + (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer) + (apply (primitive +) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)) + (const ,inc))))) + + ;; Output . is done by converting the cell's integer value to a + ;; character first and then printing out this character: + ;; (write-char (integer->char (vector-ref tape pointer))) + ((<bf-print>) + (emit `(apply (primitive write-char) + (apply (primitive integer->char) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)))))) + + ;; Input , is done similarly, read in a character, get its ASCII + ;; code and store it into the current cell: + ;; (vector-set! tape pointer (char->integer (read-char))) + ((<bf-read>) + (emit `(apply (primitive vector-set!) + (lexical tape) (lexical pointer) + (apply (primitive char->integer) + (apply (primitive read-char)))))) + + ;; For loops [...] we use a letrec construction to execute the body until + ;; the current cell gets zero. The body is compiled via a recursive call + ;; back to (compile-body). + ;; (let iterate () + ;; (if (not (= (vector-ref! tape pointer) 0)) + ;; (begin + ;; <body> + ;; (iterate)))) + ;; + ;; Indeed, letrec is the only way we have to loop in Tree-IL. + ;; Note that this does not mean that the closure must actually + ;; be created; later passes can compile tail-recursive letrec + ;; calls into inline code with gotos. Admittedly, that part of + ;; the compiler is not yet in place, but it will be, and in the + ;; meantime the code is still reasonably efficient. + ((<bf-loop> . ,body) + (let ((iterate (gensym))) + (emit `(letrec (iterate) (,iterate) + ((lambda () () + (if (apply (primitive =) + (apply (primitive vector-ref) + (lexical tape) (lexical pointer)) + (const 0)) + (void) + (begin ,(compile-body body) + (apply (lexical ,iterate)))))) + (apply (lexical ,iterate)))))) + + (else (error "unknown brainfuck instruction" (car in)))))))) diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm new file mode 100644 index 000000000..0a71638d8 --- /dev/null +++ b/module/language/brainfuck/parse.scm @@ -0,0 +1,91 @@ +;;; Brainfuck for GNU Guile. + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (language brainfuck parse) + #:export (read-brainfuck)) + +; Purpose of the parse module is to read in brainfuck in text form and produce +; the corresponding tree representing the brainfuck code. +; +; Each object (representing basically a single instruction) is structured like: +; (<instruction> [arguments]) +; where <instruction> is a symbolic name representing the type of instruction +; and the optional arguments represent further data (for instance, the body of +; a [...] loop as a number of nested instructions). +; +; A full brainfuck program is represented by the (<brainfuck> instructions) +; object. + + +; While reading a number of instructions in sequence, all of them are cons'ed +; onto a list of instructions; thus this list gets out in reverse order. +; Additionally, for "comment characters" (everything not an instruction) we +; generate <bf-nop> NOP instructions. +; +; This routine reverses a list of instructions and removes all <bf-nop>'s on the +; way to fix these two issues for a read-in list. + +(define (reverse-without-nops lst) + (let iterate ((cur lst) + (result '())) + (if (null? cur) + result + (let ((head (car cur)) + (tail (cdr cur))) + (if (eq? (car head) '<bf-nop>) + (iterate tail result) + (iterate tail (cons head result))))))) + + +; Read in a set of instructions until a terminating ] character is found (or +; end of file is reached). This is used both for loop bodies and whole +; programs, so that a program has to be either terminated by EOF or an +; additional ], too. +; +; For instance, the basic program so just echo one character would be: +; ,.] + +(define (read-brainfuck p) + (let iterate ((parsed '())) + (let ((chr (read-char p))) + (if (or (eof-object? chr) (eq? #\] chr)) + (reverse-without-nops parsed) + (iterate (cons (process-input-char chr p) parsed)))))) + + +; This routine processes a single character of input and builds the +; corresponding instruction. Loop bodies are read by recursively calling +; back (read-brainfuck). +; +; For the poiner movement commands >< and the cell increment/decrement +- +; commands, we only use one instruction form each and specify the direction of +; the pointer/value increment using an argument to the instruction form. + +(define (process-input-char chr p) + (case chr + ((#\>) '(<bf-move> 1)) + ((#\<) '(<bf-move> -1)) + ((#\+) '(<bf-increment> 1)) + ((#\-) '(<bf-increment> -1)) + ((#\.) '(<bf-print>)) + ((#\,) '(<bf-read>)) + ((#\[) `(<bf-loop> ,@(read-brainfuck p))) + (else '(<bf-nop>)))) diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm new file mode 100644 index 000000000..a4ba60f82 --- /dev/null +++ b/module/language/brainfuck/spec.scm @@ -0,0 +1,44 @@ +;;; Brainfuck for GNU Guile. + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (language brainfuck spec) + #:use-module (language brainfuck compile-tree-il) + #:use-module (language brainfuck compile-scheme) + #:use-module (language brainfuck parse) + #:use-module (system base language) + #:export (brainfuck)) + + +; The new language is integrated into Guile via this (define-language) +; specification in the special module (language [lang] spec). +; Provided is a parser-routine in #:reader, a output routine in #:printer +; and one or more compiler routines (as target-language - routine pairs) +; in #:compilers. This is the basic set of fields needed to specify a new +; language. + +(define-language brainfuck + #:title "Guile Brainfuck" + #:version "1.0" + #:reader (lambda () (read-brainfuck (current-input-port))) + #:compilers `((tree-il . ,compile-tree-il) + (scheme . ,compile-scheme)) + #:printer write + ) diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm new file mode 100644 index 000000000..184565b04 --- /dev/null +++ b/module/language/bytecode/spec.scm @@ -0,0 +1,39 @@ +;;; Guile Lowlevel Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language bytecode spec) + #:use-module (system base language) + #:use-module (system vm objcode) + #:export (bytecode)) + +(define (compile-objcode x e opts) + (values (bytecode->objcode x) e e)) + +(define (decompile-objcode x e opts) + (values (objcode->bytecode x) e)) + +(define-language bytecode + #:title "Guile Bytecode Vectors" + #:version "0.3" + #:reader read + #:printer write + #:compilers `((objcode . ,compile-objcode)) + #:decompilers `((objcode . ,decompile-objcode)) + ) diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm new file mode 100644 index 000000000..e9fc3c6f4 --- /dev/null +++ b/module/language/ecmascript/array.scm @@ -0,0 +1,121 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript array) + #:use-module (oop goops) + #:use-module (language ecmascript base) + #:use-module (language ecmascript function) + #:export (*array-prototype* new-array)) + + +(define-class <js-array-object> (<js-object>) + (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector)) + +(define (new-array . vals) + (let ((o (make <js-array-object> #:class "Array" + #:prototype *array-prototype*))) + (pput o 'length (length vals)) + (let ((vect (js-array-vector o))) + (let lp ((i 0) (vals vals)) + (cond ((not (null? vals)) + (vector-set! vect i (car vals)) + (lp (1+ i) (cdr vals))) + (else o)))))) + +(define *array-prototype* (make <js-object> #:class "Array" + #:value new-array + #:constructor new-array)) + +(hashq-set! *program-wrappers* new-array *array-prototype*) + +(pput *array-prototype* 'prototype *array-prototype*) +(pput *array-prototype* 'constructor new-array) + +(define-method (pget (o <js-array-object>) p) + (cond ((and (integer? p) (exact? p) (>= p 0)) + (let ((v (js-array-vector o))) + (if (< p (vector-length v)) + (vector-ref v p) + (next-method)))) + ((or (and (symbol? p) (eq? p 'length)) + (and (string? p) (string=? p "length"))) + (vector-length (js-array-vector o))) + (else (next-method)))) + +(define-method (pput (o <js-array-object>) p v) + (cond ((and (integer? p) (exact? p) (>= 0 p)) + (let ((vect (js-array-vector o))) + (if (< p (vector-length vect)) + (vector-set! vect p) + ;; Fixme: round up to powers of 2? + (let ((new (make-vector (1+ p) 0))) + (vector-move-left! vect 0 (vector-length vect) new 0) + (set! (js-array-vector o) new) + (vector-set! new p))))) + ((or (and (symbol? p) (eq? p 'length)) + (and (string? p) (string=? p "length"))) + (let ((vect (js-array-vector o))) + (let ((new (make-vector (->uint32 v) 0))) + (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v)) + new 0) + (set! (js-array-vector o) new)))) + (else (next-method)))) + +(define-js-method *array-prototype* (toString) + (format #f "~A" (js-array-vector this))) + +(define-js-method *array-prototype* (concat . rest) + (let* ((len (apply + (->uint32 (pget this 'length)) + (map (lambda (x) (->uint32 (pget x 'length))) + rest))) + (rv (make-vector len 0))) + (let lp ((objs (cons this rest)) (i 0)) + (cond ((null? objs) (make <js-array-object> #:class "Array" + #:prototype *array-prototype* + #:vector rv)) + ((is-a? (car objs) <js-array-object>) + (let ((v (js-array-vector (car objs)))) + (vector-move-left! v 0 (vector-length v) + rv i (+ i (vector-length v))) + (lp (cdr objs) (+ i (vector-length v))))) + (else + (error "generic array concats not yet implemented")))))) + +(define-js-method *array-prototype* (join . separator) + (let lp ((i (1- (->uint32 (pget this 'length)))) (l '())) + (if (< i 0) + (string-join l (if separator (->string (car separator)) ",")) + (lp (1+ i) + (cons (->string (pget this i)) l))))) + +(define-js-method *array-prototype* (pop) + (let ((len (->uint32 (pget this 'length)))) + (if (zero? len) + *undefined* + (let ((ret (pget this (1- len)))) + (pput this 'length (1- len)) + ret)))) + +(define-js-method *array-prototype* (push . args) + (let lp ((args args)) + (if (null? args) + (->uint32 (pget this 'length)) + (begin (pput this (->uint32 (pget this 'length)) (car args)) + (lp (cdr args)))))) diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm new file mode 100644 index 000000000..1d031fcde --- /dev/null +++ b/module/language/ecmascript/base.scm @@ -0,0 +1,250 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript base) + #:use-module (oop goops) + #:export (*undefined* *this* + <js-object> *object-prototype* + js-prototype js-props js-prop-attrs js-value js-constructor js-class + pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel + + object->string object->number object->value/string + object->value/number object->value + + ->primitive ->boolean ->number ->integer ->int32 ->uint32 + ->uint16 ->string ->object + + call/this* call/this lambda/this define-js-method + + new-object new)) + +(define *undefined* ((@@ (oop goops) make-unbound))) +(define *this* (make-fluid)) + +(define-class <js-object> () + (prototype #:getter js-prototype #:init-keyword #:prototype + #:init-thunk (lambda () *object-prototype*)) + (props #:getter js-props #:init-form (make-hash-table 7)) + (prop-attrs #:getter js-prop-attrs #:init-value #f) + (value #:getter js-value #:init-value #f #:init-keyword #:value) + (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor) + (class #:getter js-class #:init-value "Object" #:init-keyword #:class)) + +(define-method (prop-keys (o <js-object>)) + (hash-map->list (lambda (k v) k) (js-props o))) + +(define-method (pget (o <js-object>) (p <string>)) + (pget o (string->symbol p))) + +(define-method (pget (o <js-object>) p) + (let ((h (hashq-get-handle (js-props o) p))) + (if h + (cdr h) + (let ((proto (js-prototype o))) + (if proto + (pget proto p) + *undefined*))))) + +(define-method (prop-attrs (o <js-object>) p) + (or (let ((attrs (js-prop-attrs o))) + (and attrs (hashq-ref (js-prop-attrs o) p))) + (let ((proto (js-prototype o))) + (if proto + (prop-attrs proto p) + '())))) + +(define-method (prop-has-attr? (o <js-object>) p attr) + (memq attr (prop-attrs o p))) + +(define-method (pput (o <js-object>) p v) + (if (prop-has-attr? o p 'ReadOnly) + (throw 'ReferenceError o p) + (hashq-set! (js-props o) p v))) + +(define-method (pput (o <js-object>) (p <string>) v) + (pput o (string->symbol p) v)) + +(define-method (pdel (o <js-object>) p) + (if (prop-has-attr? o p 'DontDelete) + #f + (begin + (pput o p *undefined*) + #t))) + +(define-method (pdel (o <js-object>) (p <string>) v) + (pdel o (string->symbol p))) + +(define-method (has-property? (o <js-object>) p) + (if (hashq-get-handle (js-props o) v) + #t + (let ((proto (js-prototype o))) + (if proto + (has-property? proto p) + #f)))) + +(define (call/this* this f) + (with-fluid* *this* this f)) + +(define-macro (call/this this f . args) + `(with-fluid* *this* ,this (lambda () (,f . ,args)))) +(define-macro (lambda/this formals . body) + `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body))) +(define-macro (define-js-method object name-and-args . body) + `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body))) + +(define *object-prototype* #f) +(set! *object-prototype* (make <js-object>)) + +(define-js-method *object-prototype* (toString) + (format #f "[object ~A]" (js-class this))) +(define-js-method *object-prototype* (toLocaleString . args) + ((pget *object-prototype* 'toString))) +(define-js-method *object-prototype* (valueOf) + this) +(define-js-method *object-prototype* (hasOwnProperty p) + (and (hashq-get-handle (js-props this) p) #t)) +(define-js-method *object-prototype* (isPrototypeOf v) + (eq? this (js-prototype v))) +(define-js-method *object-prototype* (propertyIsEnumerable p) + (and (hashq-get-handle (js-props this) p) + (not (prop-has-attr? this p 'DontEnum)))) + +(define (object->string o error?) + (let ((toString (pget o 'toString))) + (if (procedure? toString) + (let ((x (call/this o toString))) + (if (and error? (is-a? x <js-object>)) + (throw 'TypeError o 'default-value) + x)) + (if error? + (throw 'TypeError o 'default-value) + o)))) + +(define (object->number o error?) + (let ((valueOf (pget o 'valueOf))) + (if (procedure? valueOf) + (let ((x (call/this o valueOf))) + (if (and error? (is-a? x <js-object>)) + (throw 'TypeError o 'default-value) + x)) + (if error? + (throw 'TypeError o 'default-value) + o)))) + +(define (object->value/string o) + (let ((v (object->string o #f))) + (if (is-a? x <js-object>) + (object->number o #t) + x))) + +(define (object->value/number o) + (let ((v (object->number o #f))) + (if (is-a? x <js-object>) + (object->string o #t) + x))) + +(define (object->value o) + ;; FIXME: if it's a date, we should try numbers first + (object->value/string o)) + +(define (->primitive x) + (if (is-a? x <js-object>) + (object->value x) + x)) + +(define (->boolean x) + (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x) + (and (string? x) (= (string-length x) 0))))) + +(define (->number x) + (cond ((number? x) x) + ((boolean? x) (if x 1 0)) + ((null? x) 0) + ((eq? x *undefined*) +nan.0) + ((is-a? x <js-object>) (object->number o)) + ((string? x) (string->number x)) + (else (throw 'TypeError o '->number)))) + +(define (->integer x) + (let ((n (->number x))) + (cond ((nan? n) 0) + ((zero? n) n) + ((inf? n) n) + (else (inexact->exact (round n)))))) + +(define (->int32 x) + (let ((n (->number x))) + (if (or (nan? n) (zero? n) (inf? n)) + 0 + (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n))))) + (if (negative? n) + (- m (ash 1 32)) + m))))) + +(define (->uint32 x) + (let ((n (->number x))) + (if (or (nan? n) (zero? n) (inf? n)) + 0 + (logand (1- (ash 1 32)) (inexact->exact (round n)))))) + +(define (->uint16 x) + (let ((n (->number x))) + (if (or (nan? n) (zero? n) (inf? n)) + 0 + (logand (1- (ash 1 16)) (inexact->exact (round n)))))) + +(define (->string x) + (cond ((eq? x *undefined*) "undefined") + ((null? x) "null") + ((boolean? x) (if x "true" "false")) + ((string? x) x) + ((number? x) + (cond ((nan? x) "NaN") + ((zero? x) "0") + ((inf? x) "Infinity") + (else (number->string x)))) + (else (->string (object->value/string x))))) + +(define (->object x) + (cond ((eq? x *undefined*) (throw 'TypeError x '->object)) + ((null? x) (throw 'TypeError x '->object)) + ((boolean? x) (make <js-object> #:prototype Boolean #:value x)) + ((number? x) (make <js-object> #:prototype String #:value x)) + ((string? x) (make <js-object> #:prototype Number #:value x)) + (else x))) + +(define (new-object . pairs) + (let ((o (make <js-object>))) + (map (lambda (pair) + (pput o (car pair) (cdr pair))) + pairs) + o)) +(slot-set! *object-prototype* 'constructor new-object) + +(define-method (new o . initargs) + (let ((ctor (js-constructor o))) + (if (not ctor) + (throw 'TypeError 'new o) + (let ((o (make <js-object> + #:prototype (or (js-prototype o) *object-prototype*)))) + (let ((new-o (call/this o apply ctor initargs))) + (if (is-a? new-o <js-object>) + new-o + o)))))) diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm new file mode 100644 index 000000000..88f3db76f --- /dev/null +++ b/module/language/ecmascript/compile-tree-il.scm @@ -0,0 +1,549 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript compile-tree-il) + #:use-module (language tree-il) + #:use-module (ice-9 receive) + #:use-module (system base pmatch) + #:use-module (srfi srfi-1) + #:export (compile-tree-il)) + +(define-syntax -> + (syntax-rules () + ((_ (type arg ...)) + `(type ,arg ...)))) + +(define-syntax @implv + (syntax-rules () + ((_ sym) + (-> (module-ref '(language ecmascript impl) 'sym #t))))) + +(define-syntax @impl + (syntax-rules () + ((_ sym arg ...) + (-> (apply (@implv sym) arg ...))))) + +(define (empty-lexical-environment) + '()) + +(define (econs name gensym env) + (acons name gensym env)) + +(define (lookup name env) + (or (assq-ref env name) + (-> (toplevel name)))) + +(define (compile-tree-il exp env opts) + (values + (parse-tree-il (comp exp (empty-lexical-environment))) + env + env)) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +;; for emacs: +;; (put 'pmatch/source 'scheme-indent-function 1) + +(define-syntax pmatch/source + (syntax-rules () + ((_ x clause ...) + (let ((x x)) + (let ((res (pmatch x + clause ...))) + (let ((loc (location x))) + (if loc + (set-source-properties! res (location x)))) + res))))) + +(define (comp x e) + (let ((l (location x))) + (define (let1 what proc) + (let ((sym (gensym))) + (-> (let (list sym) (list sym) (list what) + (proc sym))))) + (define (begin1 what proc) + (let1 what (lambda (v) + (-> (begin (proc v) + (-> (lexical v v))))))) + (pmatch/source x + (null + ;; FIXME, null doesn't have much relation to EOL... + (-> (const '()))) + (true + (-> (const #t))) + (false + (-> (const #f))) + ((number ,num) + (-> (const num))) + ((string ,str) + (-> (const str))) + (this + (@impl get-this '())) + ((+ ,a) + (-> (apply (-> (primitive '+)) + (@impl ->number (comp a e)) + (-> (const 0))))) + ((- ,a) + (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e)))) + ((~ ,a) + (@impl bitwise-not (comp a e))) + ((! ,a) + (@impl logical-not (comp a e))) + ((+ ,a ,b) + (-> (apply (-> (primitive '+)) (comp a e) (comp b e)))) + ((- ,a ,b) + (-> (apply (-> (primitive '-)) (comp a e) (comp b e)))) + ((/ ,a ,b) + (-> (apply (-> (primitive '/)) (comp a e) (comp b e)))) + ((* ,a ,b) + (-> (apply (-> (primitive '*)) (comp a e) (comp b e)))) + ((% ,a ,b) + (@impl mod (comp a e) (comp b e))) + ((<< ,a ,b) + (@impl shift (comp a e) (comp b e))) + ((>> ,a ,b) + (@impl shift (comp a e) (comp `(- ,b) e))) + ((< ,a ,b) + (-> (apply (-> (primitive '<)) (comp a e) (comp b e)))) + ((<= ,a ,b) + (-> (apply (-> (primitive '<=)) (comp a e) (comp b e)))) + ((> ,a ,b) + (-> (apply (-> (primitive '>)) (comp a e) (comp b e)))) + ((>= ,a ,b) + (-> (apply (-> (primitive '>=)) (comp a e) (comp b e)))) + ((in ,a ,b) + (@impl has-property? (comp a e) (comp b e))) + ((== ,a ,b) + (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e)))) + ((!= ,a ,b) + (-> (apply (-> (primitive 'not)) + (-> (apply (-> (primitive 'equal?)) + (comp a e) (comp b e)))))) + ((=== ,a ,b) + (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e)))) + ((!== ,a ,b) + (-> (apply (-> (primitive 'not)) + (-> (apply (-> (primitive 'eqv?)) + (comp a e) (comp b e)))))) + ((& ,a ,b) + (@impl band (comp a e) (comp b e))) + ((^ ,a ,b) + (@impl bxor (comp a e) (comp b e))) + ((bor ,a ,b) + (@impl bior (comp a e) (comp b e))) + ((and ,a ,b) + (-> (if (@impl ->boolean (comp a e)) + (comp b e) + (-> (const #f))))) + ((or ,a ,b) + (let1 (comp a e) + (lambda (v) + (-> (if (@impl ->boolean (-> (lexical v v))) + (-> (lexical v v)) + (comp b e)))))) + ((if ,test ,then ,else) + (-> (if (@impl ->boolean (comp test e)) + (comp then e) + (comp else e)))) + ((if ,test ,then ,else) + (-> (if (@impl ->boolean (comp test e)) + (comp then e) + (@implv *undefined*)))) + ((postinc (ref ,foo)) + (begin1 (comp `(ref ,foo) e) + (lambda (var) + (-> (set! (lookup foo e) + (-> (apply (-> (primitive '+)) + (-> (lexical var var)) + (-> (const 1))))))))) + ((postinc (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (apply (-> (primitive '+)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))) + ((postinc (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (apply (-> (primitive '+)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))))) + ((postdec (ref ,foo)) + (begin1 (comp `(ref ,foo) e) + (lambda (var) + (-> (set (lookup foo e) + (-> (apply (-> (primitive '-)) + (-> (lexical var var)) + (-> (const 1))))))))) + ((postdec (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (apply (-> (primitive '-)) + (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))) + ((postdec (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (inline + '- (-> (lexical tmpvar tmpvar)) + (-> (const 1)))))))))))) + ((preinc (ref ,foo)) + (let ((v (lookup foo e))) + (-> (begin + (-> (set! v + (-> (apply (-> (primitive '+)) + v + (-> (const 1)))))) + v)))) + ((preinc (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (-> (apply (-> (primitive '+)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (lexical tmpvar tmpvar)))))))) + ((preinc (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (-> (apply (-> (primitive '+)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (lexical tmpvar tmpvar)))))))))) + ((predec (ref ,foo)) + (let ((v (lookup foo e))) + (-> (begin + (-> (set! v + (-> (apply (-> (primitive '-)) + v + (-> (const 1)))))) + v)))) + ((predec (pref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (begin1 (-> (apply (-> (primitive '-)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (const prop))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (const prop)) + (-> (lexical tmpvar tmpvar)))))))) + ((predec (aref ,obj ,prop)) + (let1 (comp obj e) + (lambda (objvar) + (let1 (comp prop e) + (lambda (propvar) + (begin1 (-> (apply (-> (primitive '-)) + (@impl pget + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar))) + (-> (const 1)))) + (lambda (tmpvar) + (@impl pput + (-> (lexical objvar objvar)) + (-> (lexical propvar propvar)) + (-> (lexical tmpvar tmpvar)))))))))) + ((ref ,id) + (lookup id e)) + ((var . ,forms) + (-> (begin + (map (lambda (form) + (pmatch form + ((,x ,y) + (-> (define x (comp y e)))) + ((,x) + (-> (define x (@implv *undefined*)))) + (else (error "bad var form" form)))) + forms)))) + ((begin . ,forms) + `(begin ,@(map (lambda (x) (comp x e)) forms))) + ((lambda ,formals ,body) + (let ((%args (gensym "%args "))) + (-> (lambda '%args %args '() + (comp-body (econs '%args %args e) body formals '%args))))) + ((call/this ,obj ,prop . ,args) + (@impl call/this* + obj + (-> (lambda '() '() '() + `(apply ,(@impl pget obj prop) ,@args))))) + ((call (pref ,obj ,prop) ,args) + (comp `(call/this ,(comp obj e) + ,(-> (const prop)) + ,@(map (lambda (x) (comp x e)) args)) + e)) + ((call (aref ,obj ,prop) ,args) + (comp `(call/this ,(comp obj e) + ,(comp prop e) + ,@(map (lambda (x) (comp x e)) args)) + e)) + ((call ,proc ,args) + `(apply ,(comp proc e) + ,@(map (lambda (x) (comp x e)) args))) + ((return ,expr) + (-> (apply (-> (primitive 'return)) + (comp expr e)))) + ((array . ,args) + `(apply ,(@implv new-array) + ,@(map (lambda (x) (comp x e)) args))) + ((object . ,args) + (@impl new-object + (map (lambda (x) + (pmatch x + ((,prop ,val) + (-> (apply (-> (primitive 'cons)) + (-> (const prop)) + (comp val e)))) + (else + (error "bad prop-val pair" x)))) + args))) + ((pref ,obj ,prop) + (@impl pget + (comp obj e) + (-> (const prop)))) + ((aref ,obj ,index) + (@impl pget + (comp obj e) + (comp index e))) + ((= (ref ,name) ,val) + (let ((v (lookup name e))) + (-> (begin + (-> (set! v (comp val e))) + v)))) + ((= (pref ,obj ,prop) ,val) + (@impl pput + (comp obj e) + (-> (const prop)) + (comp val e))) + ((= (aref ,obj ,prop) ,val) + (@impl pput + (comp obj e) + (comp prop e) + (comp val e))) + ((+= ,what ,val) + (comp `(= ,what (+ ,what ,val)) e)) + ((-= ,what ,val) + (comp `(= ,what (- ,what ,val)) e)) + ((/= ,what ,val) + (comp `(= ,what (/ ,what ,val)) e)) + ((*= ,what ,val) + (comp `(= ,what (* ,what ,val)) e)) + ((%= ,what ,val) + (comp `(= ,what (% ,what ,val)) e)) + ((>>= ,what ,val) + (comp `(= ,what (>> ,what ,val)) e)) + ((<<= ,what ,val) + (comp `(= ,what (<< ,what ,val)) e)) + ((>>>= ,what ,val) + (comp `(= ,what (>>> ,what ,val)) e)) + ((&= ,what ,val) + (comp `(= ,what (& ,what ,val)) e)) + ((bor= ,what ,val) + (comp `(= ,what (bor ,what ,val)) e)) + ((^= ,what ,val) + (comp `(= ,what (^ ,what ,val)) e)) + ((new ,what ,args) + (@impl new + (map (lambda (x) (comp x e)) + (cons what args)))) + ((delete (pref ,obj ,prop)) + (@impl pdel + (comp obj e) + (-> (const prop)))) + ((delete (aref ,obj ,prop)) + (@impl pdel + (comp obj e) + (comp prop e))) + ((void ,expr) + (-> (begin + (comp expr e) + (@implv *undefined*)))) + ((typeof ,expr) + (@impl typeof + (comp expr e))) + ((do ,statement ,test) + (let ((%loop (gensym "%loop ")) + (%continue (gensym "%continue "))) + (let ((e (econs '%loop %loop (econs '%continue %continue e)))) + (-> (letrec '(%loop %continue) (list %loop %continue) + (list (-> (lambda '() '() '() + (-> (begin + (comp statement e) + (-> (apply (-> (lexical '%continue %continue))) + ))))) + + (-> (lambda '() '() '() + (-> (if (@impl ->boolean (comp test e)) + (-> (apply (-> (lexical '%loop %loop)))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%loop %loop))))))))) + ((while ,test ,statement) + (let ((%continue (gensym "%continue "))) + (let ((e (econs '%continue %continue e))) + (-> (letrec '(%continue) (list %continue) + (list (-> (lambda '() '() '() + (-> (if (@impl ->boolean (comp test e)) + (-> (begin (comp statement e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%continue %continue))))))))) + + ((for ,init ,test ,inc ,statement) + (let ((%continue (gensym "%continue "))) + (let ((e (econs '%continue %continue e))) + (-> (letrec '(%continue) (list %continue) + (list (-> (lambda '() '() '() + (-> (if (if test + (@impl ->boolean (comp test e)) + (comp 'true e)) + (-> (begin (comp statement e) + (comp (or inc '(begin)) e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (begin (comp (or init '(begin)) e) + (-> (apply (-> (lexical '%continue %continue))))))))))) + + ((for-in ,var ,object ,statement) + (let ((%enum (gensym "%enum ")) + (%continue (gensym "%continue "))) + (let ((e (econs '%enum %enum (econs '%continue %continue e)))) + (-> (letrec '(%enum %continue) (list %enum %continue) + (list (@impl make-enumerator (comp object e)) + (-> (lambda '() '() '() + (-> (if (@impl ->boolean + (@impl pget + (-> (lexical '%enum %enum)) + (-> (const 'length)))) + (-> (begin + (comp `(= ,var (call/this ,(-> (lexical '%enum %enum)) + ,(-> (const 'pop)))) + e) + (comp statement e) + (-> (apply (-> (lexical '%continue %continue)))))) + (@implv *undefined*)))))) + (-> (apply (-> (lexical '%continue %continue))))))))) + + ((block ,x) + (comp x e)) + (else + (error "compilation not yet implemented:" x))))) + +(define (comp-body e body formals %args) + (define (process) + (let lp ((in body) (out '()) (rvars (reverse formals))) + (pmatch in + (((var (,x) . ,morevars) . ,rest) + (lp `((var . ,morevars) . ,rest) + out + (if (memq x rvars) rvars (cons x rvars)))) + (((var (,x ,y) . ,morevars) . ,rest) + (lp `((var . ,morevars) . ,rest) + `((= (ref ,x) ,y) . ,out) + (if (memq x rvars) rvars (cons x rvars)))) + (((var) . ,rest) + (lp rest out rvars)) + ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda))) + (lp rest + (cons x out) + rvars)) + ((,x . ,rest) (guard (pair? x)) + (receive (sub-out rvars) + (lp x '() rvars) + (lp rest + (cons sub-out out) + rvars))) + ((,x . ,rest) + (lp rest + (cons x out) + rvars)) + (() + (values (reverse! out) + rvars))))) + (receive (out rvars) + (process) + (let* ((names (reverse rvars)) + (syms (map (lambda (x) + (gensym (string-append (symbol->string x) " "))) + names)) + (e (fold acons e names syms))) + (let ((%argv (lookup %args e))) + (let lp ((names names) (syms syms)) + (if (null? names) + ;; fixme: here check for too many args + (comp out e) + (-> (let (list (car names)) (list (car syms)) + (list (-> (if (-> (apply (-> (primitive 'null?)) %argv)) + (-> (@implv *undefined*)) + (-> (let1 (-> (apply (-> (primitive 'car)) %argv)) + (lambda (v) + (-> (set! %argv + (-> (apply (-> (primitive 'cdr)) %argv)))) + (-> (lexical v v)))))))) + (lp (cdr names) (cdr syms)))))))))) diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm new file mode 100644 index 000000000..710c5cb1c --- /dev/null +++ b/module/language/ecmascript/function.scm @@ -0,0 +1,78 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript function) + #:use-module (oop goops) + #:use-module (language ecmascript base) + #:export (*function-prototype* *program-wrappers*)) + + +(define-class <js-program-wrapper> (<js-object>)) + +(define *program-wrappers* (make-doubly-weak-hash-table 31)) + +(define *function-prototype* (make <js-object> #:class "Function" + #:value (lambda args *undefined*))) + +(define-js-method *function-prototype* (toString) + (format #f "~A" (js-value this))) + +(define-js-method *function-prototype* (apply this-arg array) + (cond ((or (null? array) (eq? array *undefined*)) + (call/this this-arg (js-value this))) + ((is-a? array <js-array-object>) + (call/this this-arg + (lambda () + (apply (js-value this) + (vector->list (js-array-vector array)))))) + (else + (throw 'TypeError 'apply array)))) + +(define-js-method *function-prototype* (call this-arg . args) + (call/this this-arg + (lambda () + (apply (js-value this) args)))) + +(define-method (pget (o <applicable>) p) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (pget wrapper p) + (pget *function-prototype* p)))) + +(define-method (pput (o <applicable>) p v) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (pput wrapper p v) + (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function" + #:prototype *function-prototype*))) + (hashq-set! *program-wrappers* o wrapper) + (pput wrapper p v))))) + +(define-method (js-prototype (o <applicable>)) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (js-prototype wrapper) + #f))) + +(define-method (js-constructor (o <applicable>)) + (let ((wrapper (hashq-ref *program-wrappers* o))) + (if wrapper + (js-constructor wrapper) + #f))) diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm new file mode 100644 index 000000000..27c077aed --- /dev/null +++ b/module/language/ecmascript/impl.scm @@ -0,0 +1,169 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript impl) + #:use-module (oop goops) + #:use-module (language ecmascript base) + #:use-module (language ecmascript function) + #:use-module (language ecmascript array) + #:re-export (*undefined* *this* call/this* + pget pput pdel has-property? + ->boolean ->number + new-object new new-array) + #:export (js-init get-this + typeof + bitwise-not logical-not + shift + mod + band bxor bior + make-enumerator)) + + +(define-class <js-module-object> (<js-object>) + (module #:init-form (current-module) #:init-keyword #:module + #:getter js-module)) +(define-method (pget (o <js-module-object>) (p <string>)) + (pget o (string->symbol p))) +(define-method (pget (o <js-module-object>) (p <symbol>)) + (let ((v (module-variable (js-module o) p))) + (if v + (variable-ref v) + (next-method)))) +(define-method (pput (o <js-module-object>) (p <string>) v) + (pput o (string->symbol p) v)) +(define-method (pput (o <js-module-object>) (p <symbol>) v) + (module-define! (js-module o) p v)) +(define-method (prop-attrs (o <js-module-object>) (p <symbol>)) + (cond ((module-local-variable (js-module o) p) '()) + ((module-variable (js-module o) p) '(DontDelete ReadOnly)) + (else (next-method)))) +(define-method (prop-attrs (o <js-module-object>) (p <string>)) + (prop-attrs o (string->symbol p))) +(define-method (prop-keys (o <js-module-object>)) + (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o))) + (next-method))) + +;; we could make a renamer, but having obj['foo-bar'] should be enough +(define (js-require modstr) + (make <js-module-object> #:module + (resolve-interface (map string->symbol (string-split modstr #\.))))) + +(define-class <js-global-object> (<js-module-object>)) +(define-method (js-module (o <js-global-object>)) + (current-module)) + +(define (init-js-bindings! mod) + (module-define! mod 'NaN +nan.0) + (module-define! mod 'Infinity +inf.0) + (module-define! mod 'undefined *undefined*) + (module-define! mod 'require js-require) + ;; isNAN, isFinite, parseFloat, parseInt, eval + ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent + ;; Object Function Array String Boolean Number Date RegExp Error EvalError + ;; RangeError ReferenceError SyntaxError TypeError URIError + (module-define! mod 'Object *object-prototype*) + (module-define! mod 'Array *array-prototype*)) + +(define (js-init) + (cond ((get-this)) + (else + (fluid-set! *this* (make <js-global-object>)) + (init-js-bindings! (current-module))))) + +(define (get-this) + (fluid-ref *this*)) + +(define (typeof x) + (cond ((eq? x *undefined*) "undefined") + ((null? x) "object") + ((boolean? x) "boolean") + ((number? x) "number") + ((string? x) "string") + ((procedure? x) "function") + ((is-a? x <js-object>) "object") + (else "scm"))) + +(define bitwise-not lognot) +(define (logical-not x) + (not (->boolean (->primitive x)))) + +(define shift ash) + +(define band logand) +(define bxor logxor) +(define bior logior) + +(define mod modulo) + +(define-method (+ (a <string>) (b <string>)) + (string-append a b)) + +(define-method (+ (a <string>) b) + (string-append a (->string b))) + +(define-method (+ a (b <string>)) + (string-append (->string a) b)) + +(define-method (+ a b) + (+ (->number a) (->number b))) + +(define-method (- a b) + (- (->number a) (->number b))) + +(define-method (* a b) + (* (->number a) (->number b))) + +(define-method (/ a b) + (/ (->number a) (->number b))) + +(define-method (< a b) + (< (->number a) (->number b))) +(define-method (< (a <string>) (b <string>)) + (string< a b)) + +(define-method (<= a b) + (<= (->number a) (->number b))) +(define-method (<= (a <string>) (b <string>)) + (string<= a b)) + +(define-method (>= a b) + (>= (->number a) (->number b))) +(define-method (>= (a <string>) (b <string>)) + (string>= a b)) + +(define-method (> a b) + (> (->number a) (->number b))) +(define-method (> (a <string>) (b <string>)) + (string> a b)) + +(define (obj-and-prototypes o) + (if o + (cons o (obj-and-prototypes (js-prototype o))) + '())) + +(define (make-enumerator obj) + (let ((props (make-hash-table 23))) + (for-each (lambda (o) + (for-each (lambda (k) (hashq-set! props k #t)) + (prop-keys o))) + (obj-and-prototypes obj)) + (apply new-array (filter (lambda (p) + (not (prop-has-attr? obj p 'DontEnum))) + (hash-map->list (lambda (k v) k) props))))) diff --git a/module/language/ecmascript/parse-lalr.scm b/module/language/ecmascript/parse-lalr.scm new file mode 100644 index 000000000..b702511ca --- /dev/null +++ b/module/language/ecmascript/parse-lalr.scm @@ -0,0 +1,1731 @@ +;; (language ecmascript parse-lalr) -- yacc's parser generator, in Guile +;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc. +;; Copyright (C) 1996-2002 Dominique Boucher + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +;; ---------------------------------------------------------------------- ;; +#! +;;; Commentary: +This file contains yet another LALR(1) parser generator written in +Scheme. In contrast to other such parser generators, this one +implements a more efficient algorithm for computing the lookahead sets. +The algorithm is the same as used in Bison (GNU yacc) and is described +in the following paper: + +"Efficient Computation of LALR(1) Look-Ahead Set", F. DeRemer and +T. Pennello, TOPLAS, vol. 4, no. 4, october 1982. + +As a consequence, it is not written in a fully functional style. +In fact, much of the code is a direct translation from C to Scheme +of the Bison sources. + +@section Defining a parser + +The module @code{(language ecmascript parse-lalr)} declares a macro +called @code{lalr-parser}: + +@lisp + (lalr-parser tokens rules ...) +@end lisp + +This macro, when given appropriate arguments, generates an LALR(1) +syntax analyzer. The macro accepts at least two arguments. The first +is a list of symbols which represent the terminal symbols of the +grammar. The remaining arguments are the grammar production rules. + +@section Running the parser + +The parser generated by the @code{lalr-parser} macro is a function that +takes two parameters. The first parameter is a lexical analyzer while +the second is an error procedure. + +The lexical analyzer is zero-argument function (a thunk) +invoked each time the parser needs to look-ahead in the token stream. +A token is usually a pair whose @code{car} is the symbol corresponding to +the token (the same symbol as used in the grammar definition). The +@code{cdr} of the pair is the semantic value associated with the token. For +example, a string token would have the @code{car} set to @code{'string} +while the @code{cdr} is set to the string value @code{"hello"}. + +Once the end of file is encountered, the lexical analyzer must always +return the symbol @code{'*eoi*} each time it is invoked. + +The error procedure must be a function that accepts at least two +parameters. + +@section The grammar format + +The grammar is specified by first giving the list of terminals and the +list of non-terminal definitions. Each non-terminal definition +is a list where the first element is the non-terminal and the other +elements are the right-hand sides (lists of grammar symbols). In +addition to this, each rhs can be followed by a semantic action. + +For example, consider the following (yacc) grammar for a very simple +expression language: +@example + e : e '+' t + | e '-' t + | t + ; + t : t '*' f + : t '/' f + | f + ; + f : ID + ; +@end example +The same grammar, written for the scheme parser generator, would look +like this (with semantic actions) +@lisp +(define expr-parser + (lalr-parser + ; Terminal symbols + (ID + - * /) + ; Productions + (e (e + t) -> (+ $1 $3) + (e - t) -> (- $1 $3) + (t) -> $1) + (t (t * f) -> (* $1 $3) + (t / f) -> (/ $1 $3) + (f) -> $1) + (f (ID) -> $1))) +@end lisp +In semantic actions, the symbol @code{$n} refers to the synthesized +attribute value of the nth symbol in the production. The value +associated with the non-terminal on the left is the result of +evaluating the semantic action (it defaults to @code{#f}). + +The above grammar implicitly handles operator precedences. It is also +possible to explicitly assign precedences and associativity to +terminal symbols and productions a la Yacc. Here is a modified +(and augmented) version of the grammar: +@lisp +(define expr-parser + (lalr-parser + ; Terminal symbols + (ID + (left: + -) + (left: * /) + (nonassoc: uminus)) + (e (e + e) -> (+ $1 $3) + (e - e) -> (- $1 $3) + (e * e) -> (* $1 $3) + (e / e) -> (/ $1 $3) + (- e (prec: uminus)) -> (- $2) + (ID) -> $1))) +@end lisp +The @code{left:} directive is used to specify a set of left-associative +operators of the same precedence level, the @code{right:} directive for +right-associative operators, and @code{nonassoc:} for operators that +are not associative. Note the use of the (apparently) useless +terminal @code{uminus}. It is only defined in order to assign to the +penultimate rule a precedence level higher than that of @code{*} and +@code{/}. The @code{prec:} directive can only appear as the last element of a +rule. Finally, note that precedence levels are incremented from +left to right, i.e. the precedence level of @code{+} and @code{-} is less +than the precedence level of @code{*} and @code{/} since the formers appear +first in the list of terminal symbols (token definitions). + +@section A final note on conflict resolution + +Conflicts in the grammar are handled in a conventional way. +In the absence of precedence directives, +Shift/Reduce conflicts are resolved by shifting, and Reduce/Reduce +conflicts are resolved by choosing the rule listed first in the +grammar definition. + +You can print the states of the generated parser by evaluating +@code{(print-states)}. The format of the output is similar to the one +produced by bison when given the -v command-line option. +;;; Code: +!# + +;;; ---------- SYSTEM DEPENDENT SECTION ----------------- +;; put in a module by Richard Todd +(define-module (language ecmascript parse-lalr) + #:export (lalr-parser + print-states)) + +;; this code is by Thien-Thi Nguyen, found in a google search +(begin + (defmacro def-macro (form . body) + `(defmacro ,(car form) ,(cdr form) ,@body)) + (def-macro (BITS-PER-WORD) 28) + (def-macro (lalr-error msg obj) `(throw 'lalr-error ,msg ,obj)) + (def-macro (logical-or x . y) `(logior ,x ,@y))) + +;;; ---------- END OF SYSTEM DEPENDENT SECTION ------------ + +;; - Macros pour la gestion des vecteurs de bits + +(def-macro (set-bit v b) + `(let ((x (quotient ,b (BITS-PER-WORD))) + (y (expt 2 (remainder ,b (BITS-PER-WORD))))) + (vector-set! ,v x (logical-or (vector-ref ,v x) y)))) + +(def-macro (bit-union v1 v2 n) + `(do ((i 0 (+ i 1))) + ((= i ,n)) + (vector-set! ,v1 i (logical-or (vector-ref ,v1 i) + (vector-ref ,v2 i))))) + +;; - Macro pour les structures de donnees + +(def-macro (new-core) `(make-vector 4 0)) +(def-macro (set-core-number! c n) `(vector-set! ,c 0 ,n)) +(def-macro (set-core-acc-sym! c s) `(vector-set! ,c 1 ,s)) +(def-macro (set-core-nitems! c n) `(vector-set! ,c 2 ,n)) +(def-macro (set-core-items! c i) `(vector-set! ,c 3 ,i)) +(def-macro (core-number c) `(vector-ref ,c 0)) +(def-macro (core-acc-sym c) `(vector-ref ,c 1)) +(def-macro (core-nitems c) `(vector-ref ,c 2)) +(def-macro (core-items c) `(vector-ref ,c 3)) + +(def-macro (new-shift) `(make-vector 3 0)) +(def-macro (set-shift-number! c x) `(vector-set! ,c 0 ,x)) +(def-macro (set-shift-nshifts! c x) `(vector-set! ,c 1 ,x)) +(def-macro (set-shift-shifts! c x) `(vector-set! ,c 2 ,x)) +(def-macro (shift-number s) `(vector-ref ,s 0)) +(def-macro (shift-nshifts s) `(vector-ref ,s 1)) +(def-macro (shift-shifts s) `(vector-ref ,s 2)) + +(def-macro (new-red) `(make-vector 3 0)) +(def-macro (set-red-number! c x) `(vector-set! ,c 0 ,x)) +(def-macro (set-red-nreds! c x) `(vector-set! ,c 1 ,x)) +(def-macro (set-red-rules! c x) `(vector-set! ,c 2 ,x)) +(def-macro (red-number c) `(vector-ref ,c 0)) +(def-macro (red-nreds c) `(vector-ref ,c 1)) +(def-macro (red-rules c) `(vector-ref ,c 2)) + + + +(def-macro (new-set nelem) + `(make-vector ,nelem 0)) + + +(def-macro (vector-map f v) + `(let ((vm-n (- (vector-length ,v) 1))) + (let loop ((vm-low 0) (vm-high vm-n)) + (if (= vm-low vm-high) + (vector-set! ,v vm-low (,f (vector-ref ,v vm-low) vm-low)) + (let ((vm-middle (quotient (+ vm-low vm-high) 2))) + (loop vm-low vm-middle) + (loop (+ vm-middle 1) vm-high)))))) + + +;; - Constantes +(define STATE-TABLE-SIZE 1009) + + +;; - Tableaux +(define rrhs #f) +(define rlhs #f) +(define ritem #f) +(define nullable #f) +(define derives #f) +(define fderives #f) +(define firsts #f) +(define kernel-base #f) +(define kernel-end #f) +(define shift-symbol #f) +(define shift-set #f) +(define red-set #f) +(define state-table #f) +(define acces-symbol #f) +(define reduction-table #f) +(define shift-table #f) +(define consistent #f) +(define lookaheads #f) +(define LA #f) +(define LAruleno #f) +(define lookback #f) +(define goto-map #f) +(define from-state #f) +(define to-state #f) +(define includes #f) +(define F #f) +(define action-table #f) + +;; - Variables +(define nitems #f) +(define nrules #f) +(define nvars #f) +(define nterms #f) +(define nsyms #f) +(define nstates #f) +(define first-state #f) +(define last-state #f) +(define final-state #f) +(define first-shift #f) +(define last-shift #f) +(define first-reduction #f) +(define last-reduction #f) +(define nshifts #f) +(define maxrhs #f) +(define ngotos #f) +(define token-set-size #f) + +(define (gen-tables! tokens gram) + (initialize-all) + (rewrite-grammar + tokens + gram + (lambda (terms terms/prec vars gram gram/actions) + (set! the-terminals/prec (list->vector terms/prec)) + (set! the-terminals (list->vector terms)) + (set! the-nonterminals (list->vector vars)) + (set! nterms (length terms)) + (set! nvars (length vars)) + (set! nsyms (+ nterms nvars)) + (let ((no-of-rules (length gram/actions)) + (no-of-items (let loop ((l gram/actions) (count 0)) + (if (null? l) + count + (loop (cdr l) (+ count (length (caar l)))))))) + (pack-grammar no-of-rules no-of-items gram) + (set-derives) + (set-nullable) + (generate-states) + (lalr) + (build-tables) + (compact-action-table terms) + gram/actions)))) + + +(define (initialize-all) + (set! rrhs #f) + (set! rlhs #f) + (set! ritem #f) + (set! nullable #f) + (set! derives #f) + (set! fderives #f) + (set! firsts #f) + (set! kernel-base #f) + (set! kernel-end #f) + (set! shift-symbol #f) + (set! shift-set #f) + (set! red-set #f) + (set! state-table (make-vector STATE-TABLE-SIZE '())) + (set! acces-symbol #f) + (set! reduction-table #f) + (set! shift-table #f) + (set! consistent #f) + (set! lookaheads #f) + (set! LA #f) + (set! LAruleno #f) + (set! lookback #f) + (set! goto-map #f) + (set! from-state #f) + (set! to-state #f) + (set! includes #f) + (set! F #f) + (set! action-table #f) + (set! nstates #f) + (set! first-state #f) + (set! last-state #f) + (set! final-state #f) + (set! first-shift #f) + (set! last-shift #f) + (set! first-reduction #f) + (set! last-reduction #f) + (set! nshifts #f) + (set! maxrhs #f) + (set! ngotos #f) + (set! token-set-size #f) + (set! rule-precedences '())) + + +(define (pack-grammar no-of-rules no-of-items gram) + (set! nrules (+ no-of-rules 1)) + (set! nitems no-of-items) + (set! rlhs (make-vector nrules #f)) + (set! rrhs (make-vector nrules #f)) + (set! ritem (make-vector (+ 1 nitems) #f)) + + (let loop ((p gram) (item-no 0) (rule-no 1)) + (if (not (null? p)) + (let ((nt (caar p))) + (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no)) + (if (null? prods) + (loop (cdr p) it-no2 rl-no2) + (begin + (vector-set! rlhs rl-no2 nt) + (vector-set! rrhs rl-no2 it-no2) + (let loop3 ((rhs (car prods)) (it-no3 it-no2)) + (if (null? rhs) + (begin + (vector-set! ritem it-no3 (- rl-no2)) + (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1))) + (begin + (vector-set! ritem it-no3 (car rhs)) + (loop3 (cdr rhs) (+ it-no3 1)))))))))))) + + +;; Fonction set-derives +;; -------------------- +(define (set-derives) + (define delts (make-vector (+ nrules 1) 0)) + (define dset (make-vector nvars -1)) + + (let loop ((i 1) (j 0)) ; i = 0 + (if (< i nrules) + (let ((lhs (vector-ref rlhs i))) + (if (>= lhs 0) + (begin + (vector-set! delts j (cons i (vector-ref dset lhs))) + (vector-set! dset lhs j) + (loop (+ i 1) (+ j 1))) + (loop (+ i 1) j))))) + + (set! derives (make-vector nvars 0)) + + (let loop ((i 0)) + (if (< i nvars) + (let ((q (let loop2 ((j (vector-ref dset i)) (s '())) + (if (< j 0) + s + (let ((x (vector-ref delts j))) + (loop2 (cdr x) (cons (car x) s))))))) + (vector-set! derives i q) + (loop (+ i 1)))))) + + + +(define (set-nullable) + (set! nullable (make-vector nvars #f)) + (let ((squeue (make-vector nvars #f)) + (rcount (make-vector (+ nrules 1) 0)) + (rsets (make-vector nvars #f)) + (relts (make-vector (+ nitems nvars 1) #f))) + (let loop ((r 0) (s2 0) (p 0)) + (let ((*r (vector-ref ritem r))) + (if *r + (if (< *r 0) + (let ((symbol (vector-ref rlhs (- *r)))) + (if (and (>= symbol 0) + (not (vector-ref nullable symbol))) + (begin + (vector-set! nullable symbol #t) + (vector-set! squeue s2 symbol) + (loop (+ r 1) (+ s2 1) p)))) + (let loop2 ((r1 r) (any-tokens #f)) + (let* ((symbol (vector-ref ritem r1))) + (if (> symbol 0) + (loop2 (+ r1 1) (or any-tokens (>= symbol nvars))) + (if (not any-tokens) + (let ((ruleno (- symbol))) + (let loop3 ((r2 r) (p2 p)) + (let ((symbol (vector-ref ritem r2))) + (if (> symbol 0) + (begin + (vector-set! rcount ruleno + (+ (vector-ref rcount ruleno) 1)) + (vector-set! relts p2 + (cons (vector-ref rsets symbol) + ruleno)) + (vector-set! rsets symbol p2) + (loop3 (+ r2 1) (+ p2 1))) + (loop (+ r2 1) s2 p2))))) + (loop (+ r1 1) s2 p)))))) + (let loop ((s1 0) (s3 s2)) + (if (< s1 s3) + (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3)) + (if p + (let* ((x (vector-ref relts p)) + (ruleno (cdr x)) + (y (- (vector-ref rcount ruleno) 1))) + (vector-set! rcount ruleno y) + (if (= y 0) + (let ((symbol (vector-ref rlhs ruleno))) + (if (and (>= symbol 0) + (not (vector-ref nullable symbol))) + (begin + (vector-set! nullable symbol #t) + (vector-set! squeue s4 symbol) + (loop2 (car x) (+ s4 1))) + (loop2 (car x) s4))) + (loop2 (car x) s4)))) + (loop (+ s1 1) s4))))))))) + + + +; Fonction set-firsts qui calcule un tableau de taille +; nvars et qui donne, pour chaque non-terminal X, une liste des +; non-terminaux pouvant apparaitre au debut d'une derivation a +; partir de X. + +(define (set-firsts) + (set! firsts (make-vector nvars '())) + + ;; -- initialization + (let loop ((i 0)) + (if (< i nvars) + (let loop2 ((sp (vector-ref derives i))) + (if (null? sp) + (loop (+ i 1)) + (let ((sym (vector-ref ritem (vector-ref rrhs (car sp))))) + (if (< -1 sym nvars) + (vector-set! firsts i (sinsert sym (vector-ref firsts i)))) + (loop2 (cdr sp))))))) + + ;; -- reflexive and transitive closure + (let loop ((continue #t)) + (if continue + (let loop2 ((i 0) (cont #f)) + (if (>= i nvars) + (loop cont) + (let* ((x (vector-ref firsts i)) + (y (let loop3 ((l x) (z x)) + (if (null? l) + z + (loop3 (cdr l) + (sunion (vector-ref firsts (car l)) z)))))) + (if (equal? x y) + (loop2 (+ i 1) cont) + (begin + (vector-set! firsts i y) + (loop2 (+ i 1) #t)))))))) + + (let loop ((i 0)) + (if (< i nvars) + (begin + (vector-set! firsts i (sinsert i (vector-ref firsts i))) + (loop (+ i 1)))))) + + + + +; Fonction set-fderives qui calcule un tableau de taille +; nvars et qui donne, pour chaque non-terminal, une liste des regles pouvant +; etre derivees a partir de ce non-terminal. (se sert de firsts) + +(define (set-fderives) + (set! fderives (make-vector nvars #f)) + + (set-firsts) + + (let loop ((i 0)) + (if (< i nvars) + (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '())) + (if (null? l) + fd + (loop2 (cdr l) + (sunion (vector-ref derives (car l)) fd)))))) + (vector-set! fderives i x) + (loop (+ i 1)))))) + + +; Fonction calculant la fermeture d'un ensemble d'items LR0 +; ou core est une liste d'items + +(define (closure core) + ;; Initialization + (define ruleset (make-vector nrules #f)) + + (let loop ((csp core)) + (if (not (null? csp)) + (let ((sym (vector-ref ritem (car csp)))) + (if (< -1 sym nvars) + (let loop2 ((dsp (vector-ref fderives sym))) + (if (not (null? dsp)) + (begin + (vector-set! ruleset (car dsp) #t) + (loop2 (cdr dsp)))))) + (loop (cdr csp))))) + + (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0 + (if (< ruleno nrules) + (if (vector-ref ruleset ruleno) + (let ((itemno (vector-ref rrhs ruleno))) + (let loop2 ((c csp) (itemsetv2 itemsetv)) + (if (and (pair? c) + (< (car c) itemno)) + (loop2 (cdr c) (cons (car c) itemsetv2)) + (loop (+ ruleno 1) c (cons itemno itemsetv2))))) + (loop (+ ruleno 1) csp itemsetv)) + (let loop2 ((c csp) (itemsetv2 itemsetv)) + (if (pair? c) + (loop2 (cdr c) (cons (car c) itemsetv2)) + (reverse itemsetv2)))))) + + + +(define (allocate-item-sets) + (set! kernel-base (make-vector nsyms 0)) + (set! kernel-end (make-vector nsyms #f))) + + +(define (allocate-storage) + (allocate-item-sets) + (set! red-set (make-vector (+ nrules 1) 0))) + +;; -- + + +(define (initialize-states) + (let ((p (new-core))) + (set-core-number! p 0) + (set-core-acc-sym! p #f) + (set-core-nitems! p 1) + (set-core-items! p '(0)) + + (set! first-state (list p)) + (set! last-state first-state) + (set! nstates 1))) + + + +(define (generate-states) + (allocate-storage) + (set-fderives) + (initialize-states) + (let loop ((this-state first-state)) + (if (pair? this-state) + (let* ((x (car this-state)) + (is (closure (core-items x)))) + (save-reductions x is) + (new-itemsets is) + (append-states) + (if (> nshifts 0) + (save-shifts x)) + (loop (cdr this-state)))))) + + +;; Fonction calculant les symboles sur lesquels il faut "shifter" +;; et regroupe les items en fonction de ces symboles + +(define (new-itemsets itemset) + ;; - Initialization + (set! shift-symbol '()) + (let loop ((i 0)) + (if (< i nsyms) + (begin + (vector-set! kernel-end i '()) + (loop (+ i 1))))) + + (let loop ((isp itemset)) + (if (pair? isp) + (let* ((i (car isp)) + (sym (vector-ref ritem i))) + (if (>= sym 0) + (begin + (set! shift-symbol (sinsert sym shift-symbol)) + (let ((x (vector-ref kernel-end sym))) + (if (null? x) + (begin + (vector-set! kernel-base sym (cons (+ i 1) x)) + (vector-set! kernel-end sym (vector-ref kernel-base sym))) + (begin + (set-cdr! x (list (+ i 1))) + (vector-set! kernel-end sym (cdr x))))))) + (loop (cdr isp))))) + + (set! nshifts (length shift-symbol))) + + + +(define (get-state sym) + (let* ((isp (vector-ref kernel-base sym)) + (n (length isp)) + (key (let loop ((isp1 isp) (k 0)) + (if (null? isp1) + (modulo k STATE-TABLE-SIZE) + (loop (cdr isp1) (+ k (car isp1)))))) + (sp (vector-ref state-table key))) + (if (null? sp) + (let ((x (new-state sym))) + (vector-set! state-table key (list x)) + (core-number x)) + (let loop ((sp1 sp)) + (if (and (= n (core-nitems (car sp1))) + (let loop2 ((i1 isp) (t (core-items (car sp1)))) + (if (and (pair? i1) + (= (car i1) + (car t))) + (loop2 (cdr i1) (cdr t)) + (null? i1)))) + (core-number (car sp1)) + (if (null? (cdr sp1)) + (let ((x (new-state sym))) + (set-cdr! sp1 (list x)) + (core-number x)) + (loop (cdr sp1)))))))) + + +(define (new-state sym) + (let* ((isp (vector-ref kernel-base sym)) + (n (length isp)) + (p (new-core))) + (set-core-number! p nstates) + (set-core-acc-sym! p sym) + (if (= sym nvars) (set! final-state nstates)) + (set-core-nitems! p n) + (set-core-items! p isp) + (set-cdr! last-state (list p)) + (set! last-state (cdr last-state)) + (set! nstates (+ nstates 1)) + p)) + + +;; -- + +(define (append-states) + (set! shift-set + (let loop ((l (reverse shift-symbol))) + (if (null? l) + '() + (cons (get-state (car l)) (loop (cdr l))))))) + +;; -- + +(define (save-shifts core) + (let ((p (new-shift))) + (set-shift-number! p (core-number core)) + (set-shift-nshifts! p nshifts) + (set-shift-shifts! p shift-set) + (if last-shift + (begin + (set-cdr! last-shift (list p)) + (set! last-shift (cdr last-shift))) + (begin + (set! first-shift (list p)) + (set! last-shift first-shift))))) + +(define (save-reductions core itemset) + (let ((rs (let loop ((l itemset)) + (if (null? l) + '() + (let ((item (vector-ref ritem (car l)))) + (if (< item 0) + (cons (- item) (loop (cdr l))) + (loop (cdr l)))))))) + (if (pair? rs) + (let ((p (new-red))) + (set-red-number! p (core-number core)) + (set-red-nreds! p (length rs)) + (set-red-rules! p rs) + (if last-reduction + (begin + (set-cdr! last-reduction (list p)) + (set! last-reduction (cdr last-reduction))) + (begin + (set! first-reduction (list p)) + (set! last-reduction first-reduction))))))) + + +;; -- + +(define (lalr) + (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD)))) + (set-accessing-symbol) + (set-shift-table) + (set-reduction-table) + (set-max-rhs) + (initialize-LA) + (set-goto-map) + (initialize-F) + (build-relations) + (digraph includes) + (compute-lookaheads)) + +(define (set-accessing-symbol) + (set! acces-symbol (make-vector nstates #f)) + (let loop ((l first-state)) + (if (pair? l) + (let ((x (car l))) + (vector-set! acces-symbol (core-number x) (core-acc-sym x)) + (loop (cdr l)))))) + +(define (set-shift-table) + (set! shift-table (make-vector nstates #f)) + (let loop ((l first-shift)) + (if (pair? l) + (let ((x (car l))) + (vector-set! shift-table (shift-number x) x) + (loop (cdr l)))))) + +(define (set-reduction-table) + (set! reduction-table (make-vector nstates #f)) + (let loop ((l first-reduction)) + (if (pair? l) + (let ((x (car l))) + (vector-set! reduction-table (red-number x) x) + (loop (cdr l)))))) + +(define (set-max-rhs) + (let loop ((p 0) (curmax 0) (length 0)) + (let ((x (vector-ref ritem p))) + (if x + (if (>= x 0) + (loop (+ p 1) curmax (+ length 1)) + (loop (+ p 1) (max curmax length) 0)) + (set! maxrhs curmax))))) + +(define (initialize-LA) + (define (last l) + (if (null? (cdr l)) + (car l) + (last (cdr l)))) + + (set! consistent (make-vector nstates #f)) + (set! lookaheads (make-vector (+ nstates 1) #f)) + + (let loop ((count 0) (i 0)) + (if (< i nstates) + (begin + (vector-set! lookaheads i count) + (let ((rp (vector-ref reduction-table i)) + (sp (vector-ref shift-table i))) + (if (and rp + (or (> (red-nreds rp) 1) + (and sp + (not + (< (vector-ref acces-symbol + (last (shift-shifts sp))) + nvars))))) + (loop (+ count (red-nreds rp)) (+ i 1)) + (begin + (vector-set! consistent i #t) + (loop count (+ i 1)))))) + + (begin + (vector-set! lookaheads nstates count) + (let ((c (max count 1))) + (set! LA (make-vector c #f)) + (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size))) + (set! LAruleno (make-vector c -1)) + (set! lookback (make-vector c #f))) + (let loop ((i 0) (np 0)) + (if (< i nstates) + (if (vector-ref consistent i) + (loop (+ i 1) np) + (let ((rp (vector-ref reduction-table i))) + (if rp + (let loop2 ((j (red-rules rp)) (np2 np)) + (if (null? j) + (loop (+ i 1) np2) + (begin + (vector-set! LAruleno np2 (car j)) + (loop2 (cdr j) (+ np2 1))))) + (loop (+ i 1) np)))))))))) + + +(define (set-goto-map) + (set! goto-map (make-vector (+ nvars 1) 0)) + (let ((temp-map (make-vector (+ nvars 1) 0))) + (let loop ((ng 0) (sp first-shift)) + (if (pair? sp) + (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng)) + (if (pair? i) + (let ((symbol (vector-ref acces-symbol (car i)))) + (if (< symbol nvars) + (begin + (vector-set! goto-map symbol + (+ 1 (vector-ref goto-map symbol))) + (loop2 (cdr i) (+ ng2 1))) + (loop2 (cdr i) ng2))) + (loop ng2 (cdr sp)))) + + (let loop ((k 0) (i 0)) + (if (< i nvars) + (begin + (vector-set! temp-map i k) + (loop (+ k (vector-ref goto-map i)) (+ i 1))) + + (begin + (do ((i 0 (+ i 1))) + ((>= i nvars)) + (vector-set! goto-map i (vector-ref temp-map i))) + + (set! ngotos ng) + (vector-set! goto-map nvars ngotos) + (vector-set! temp-map nvars ngotos) + (set! from-state (make-vector ngotos #f)) + (set! to-state (make-vector ngotos #f)) + + (do ((sp first-shift (cdr sp))) + ((null? sp)) + (let* ((x (car sp)) + (state1 (shift-number x))) + (do ((i (shift-shifts x) (cdr i))) + ((null? i)) + (let* ((state2 (car i)) + (symbol (vector-ref acces-symbol state2))) + (if (< symbol nvars) + (let ((k (vector-ref temp-map symbol))) + (vector-set! temp-map symbol (+ k 1)) + (vector-set! from-state k state1) + (vector-set! to-state k state2)))))))))))))) + + +(define (map-goto state symbol) + (let loop ((low (vector-ref goto-map symbol)) + (high (- (vector-ref goto-map (+ symbol 1)) 1))) + (if (> low high) + (begin + (display (list "Error in map-goto" state symbol) (current-error-port)) + (newline (current-error-port)) + 0) + (let* ((middle (quotient (+ low high) 2)) + (s (vector-ref from-state middle))) + (cond + ((= s state) + middle) + ((< s state) + (loop (+ middle 1) high)) + (else + (loop low (- middle 1)))))))) + + +(define (initialize-F) + (set! F (make-vector ngotos #f)) + (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size))) + + (let ((reads (make-vector ngotos #f))) + + (let loop ((i 0) (rowp 0)) + (if (< i ngotos) + (let* ((rowf (vector-ref F rowp)) + (stateno (vector-ref to-state i)) + (sp (vector-ref shift-table stateno))) + (if sp + (let loop2 ((j (shift-shifts sp)) (edges '())) + (if (pair? j) + (let ((symbol (vector-ref acces-symbol (car j)))) + (if (< symbol nvars) + (if (vector-ref nullable symbol) + (loop2 (cdr j) (cons (map-goto stateno symbol) + edges)) + (loop2 (cdr j) edges)) + (begin + (set-bit rowf (- symbol nvars)) + (loop2 (cdr j) edges)))) + (if (pair? edges) + (vector-set! reads i (reverse edges)))))) + (loop (+ i 1) (+ rowp 1))))) + (digraph reads))) + +(define (add-lookback-edge stateno ruleno gotono) + (let ((k (vector-ref lookaheads (+ stateno 1)))) + (let loop ((found #f) (i (vector-ref lookaheads stateno))) + (if (and (not found) (< i k)) + (if (= (vector-ref LAruleno i) ruleno) + (loop #t i) + (loop found (+ i 1))) + + (if (not found) + (begin (display "Error in add-lookback-edge : " (current-error-port)) + (display (list stateno ruleno gotono) (current-error-port)) + (newline (current-error-port))) + (vector-set! lookback i + (cons gotono (vector-ref lookback i)))))))) + + +(define (transpose r-arg n) + (let ((new-end (make-vector n #f)) + (new-R (make-vector n #f))) + (do ((i 0 (+ i 1))) + ((= i n)) + (let ((x (list 'bidon))) + (vector-set! new-R i x) + (vector-set! new-end i x))) + (do ((i 0 (+ i 1))) + ((= i n)) + (let ((sp (vector-ref r-arg i))) + (if (pair? sp) + (let loop ((sp2 sp)) + (if (pair? sp2) + (let* ((x (car sp2)) + (y (vector-ref new-end x))) + (set-cdr! y (cons i (cdr y))) + (vector-set! new-end x (cdr y)) + (loop (cdr sp2)))))))) + (do ((i 0 (+ i 1))) + ((= i n)) + (vector-set! new-R i (cdr (vector-ref new-R i)))) + + new-R)) + + + +(define (build-relations) + + (define (get-state stateno symbol) + (let loop ((j (shift-shifts (vector-ref shift-table stateno))) + (stno stateno)) + (if (null? j) + stno + (let ((st2 (car j))) + (if (= (vector-ref acces-symbol st2) symbol) + st2 + (loop (cdr j) st2)))))) + + (set! includes (make-vector ngotos #f)) + (do ((i 0 (+ i 1))) + ((= i ngotos)) + (let ((state1 (vector-ref from-state i)) + (symbol1 (vector-ref acces-symbol (vector-ref to-state i)))) + (let loop ((rulep (vector-ref derives symbol1)) + (edges '())) + (if (pair? rulep) + (let ((*rulep (car rulep))) + (let loop2 ((rp (vector-ref rrhs *rulep)) + (stateno state1) + (states (list state1))) + (let ((*rp (vector-ref ritem rp))) + (if (> *rp 0) + (let ((st (get-state stateno *rp))) + (loop2 (+ rp 1) st (cons st states))) + (begin + + (if (not (vector-ref consistent stateno)) + (add-lookback-edge stateno *rulep i)) + + (let loop2 ((done #f) + (stp (cdr states)) + (rp2 (- rp 1)) + (edgp edges)) + (if (not done) + (let ((*rp (vector-ref ritem rp2))) + (if (< -1 *rp nvars) + (loop2 (not (vector-ref nullable *rp)) + (cdr stp) + (- rp2 1) + (cons (map-goto (car stp) *rp) edgp)) + (loop2 #t stp rp2 edgp))) + + (loop (cdr rulep) edgp)))))))) + (vector-set! includes i edges))))) + (set! includes (transpose includes ngotos))) + + + +(define (compute-lookaheads) + (let ((n (vector-ref lookaheads nstates))) + (let loop ((i 0)) + (if (< i n) + (let loop2 ((sp (vector-ref lookback i))) + (if (pair? sp) + (let ((LA-i (vector-ref LA i)) + (F-j (vector-ref F (car sp)))) + (bit-union LA-i F-j token-set-size) + (loop2 (cdr sp))) + (loop (+ i 1)))))))) + + + +(define (digraph relation) + (define infinity (+ ngotos 2)) + (define INDEX (make-vector (+ ngotos 1) 0)) + (define VERTICES (make-vector (+ ngotos 1) 0)) + (define top 0) + (define R relation) + + (define (traverse i) + (set! top (+ 1 top)) + (vector-set! VERTICES top i) + (let ((height top)) + (vector-set! INDEX i height) + (let ((rp (vector-ref R i))) + (if (pair? rp) + (let loop ((rp2 rp)) + (if (pair? rp2) + (let ((j (car rp2))) + (if (= 0 (vector-ref INDEX j)) + (traverse j)) + (if (> (vector-ref INDEX i) + (vector-ref INDEX j)) + (vector-set! INDEX i (vector-ref INDEX j))) + (let ((F-i (vector-ref F i)) + (F-j (vector-ref F j))) + (bit-union F-i F-j token-set-size)) + (loop (cdr rp2)))))) + (if (= (vector-ref INDEX i) height) + (let loop () + (let ((j (vector-ref VERTICES top))) + (set! top (- top 1)) + (vector-set! INDEX j infinity) + (if (not (= i j)) + (begin + (bit-union (vector-ref F i) + (vector-ref F j) + token-set-size) + (loop))))))))) + + (let loop ((i 0)) + (if (< i ngotos) + (begin + (if (and (= 0 (vector-ref INDEX i)) + (pair? (vector-ref R i))) + (traverse i)) + (loop (+ i 1)))))) + + +;; ---------------------------------------------------------------------- ;; +;; operator precedence management ;; +;; ---------------------------------------------------------------------- ;; + +; a vector of precedence descriptors where each element +; is of the form (terminal type precedence) +(define the-terminals/prec #f) ; terminal symbols with precedence +; the precedence is an integer >= 0 +(define (get-symbol-precedence sym) + (caddr (vector-ref the-terminals/prec sym))) +; the operator type is either 'none, 'left, 'right, or 'nonassoc +(define (get-symbol-assoc sym) + (cadr (vector-ref the-terminals/prec sym))) + +(define rule-precedences '()) +(define (add-rule-precedence! rule sym) + (set! rule-precedences + (cons (cons rule sym) rule-precedences))) + +(define (get-rule-precedence ruleno) + (cond + ((assq ruleno rule-precedences) + => (lambda (p) + (get-symbol-precedence (cdr p)))) + (else + ;; process the rule symbols from left to right + (let loop ((i (vector-ref rrhs ruleno)) + (prec 0)) + (let ((item (vector-ref ritem i))) + ;; end of rule + (if (< item 0) + prec + (let ((i1 (+ i 1))) + (if (>= item nvars) + ;; it's a terminal symbol + (loop i1 (get-symbol-precedence (- item nvars))) + (loop i1 prec))))))))) + +;; ---------------------------------------------------------------------- ;; +;; Build the various tables ;; +;; ---------------------------------------------------------------------- ;; +(define (build-tables) + + (define (resolve-conflict sym rule) + (let ((sym-prec (get-symbol-precedence sym)) + (sym-assoc (get-symbol-assoc sym)) + (rule-prec (get-rule-precedence rule))) + (cond + ((> sym-prec rule-prec) 'shift) + ((< sym-prec rule-prec) 'reduce) + ((eq? sym-assoc 'left) 'reduce) + ((eq? sym-assoc 'right) 'shift) + (else 'shift)))) + + ;; --- Add an action to the action table ------------------------------ ;; + (define (add-action St Sym Act) + (let* ((x (vector-ref action-table St)) + (y (assv Sym x))) + (if y + (if (not (= Act (cdr y))) + ;; -- there is a conflict + (begin + (if (and (<= (cdr y) 0) + (<= Act 0)) + ;; --- reduce/reduce conflict ----------------------- ;; + (begin + (display "%% Reduce/Reduce conflict " (current-error-port)) + (display "(reduce " (current-error-port)) + (display (- Act) (current-error-port)) + (display ", reduce " (current-error-port)) + (display (- (cdr y)) (current-error-port)) + (display ") on " (current-error-port)) + (print-symbol (+ Sym nvars) (current-error-port)) + (display " in state " (current-error-port)) + (display St (current-error-port)) + (newline (current-error-port)) + (set-cdr! y (max (cdr y) Act))) + ;; --- shift/reduce conflict ------------------------ ;; + ;; can we resolve the conflict using precedences? + (case (resolve-conflict Sym (- (cdr y))) + ;; -- shift + ((shift) + (set-cdr! y Act)) + ;; -- reduce + ((reduce) + #f) ; well, nothing to do... + ;; -- signal a conflict! + (else + (display "%% Shift/Reduce conflict " (current-error-port)) + (display "(shift " (current-error-port)) + (display Act (current-error-port)) + (display ", reduce " (current-error-port)) + (display (- (cdr y)) (current-error-port)) + (display ") on " (current-error-port)) + (print-symbol (+ Sym nvars) (current-error-port)) + (display " in state " (current-error-port)) + (display St (current-error-port)) + (newline (current-error-port)) + (set-cdr! y Act)))))) + + (vector-set! action-table St (cons (cons Sym Act) x))))) + + (set! action-table (make-vector nstates '())) + + (do ((i 0 (+ i 1))) ; i = state + ((= i nstates)) + (let ((red (vector-ref reduction-table i))) + (if (and red (>= (red-nreds red) 1)) + (if (and (= (red-nreds red) 1) (vector-ref consistent i)) + (add-action i 'default (- (car (red-rules red)))) + (let ((k (vector-ref lookaheads (+ i 1)))) + (let loop ((j (vector-ref lookaheads i))) + (if (< j k) + (let ((rule (- (vector-ref LAruleno j))) + (lav (vector-ref LA j))) + (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0)) + (if (< token nterms) + (begin + (let ((in-la-set? (modulo x 2))) + (if (= in-la-set? 1) + (add-action i token rule))) + (if (= y (BITS-PER-WORD)) + (loop2 (+ token 1) + (vector-ref lav (+ z 1)) + 1 + (+ z 1)) + (loop2 (+ token 1) (quotient x 2) (+ y 1) z))))) + (loop (+ j 1))))))))) + + (let ((shiftp (vector-ref shift-table i))) + (if shiftp + (let loop ((k (shift-shifts shiftp))) + (if (pair? k) + (let* ((state (car k)) + (symbol (vector-ref acces-symbol state))) + (if (>= symbol nvars) + (add-action i (- symbol nvars) state)) + (loop (cdr k)))))))) + + (add-action final-state 0 'accept)) + +(define (compact-action-table terms) + (define (most-common-action acts) + (let ((accums '())) + (let loop ((l acts)) + (if (pair? l) + (let* ((x (cdar l)) + (y (assv x accums))) + (if (and (number? x) (< x 0)) + (if y + (set-cdr! y (+ 1 (cdr y))) + (set! accums (cons `(,x . 1) accums)))) + (loop (cdr l))))) + + (let loop ((l accums) (max 0) (sym #f)) + (if (null? l) + sym + (let ((x (car l))) + (if (> (cdr x) max) + (loop (cdr l) (cdr x) (car x)) + (loop (cdr l) max sym))))))) + + (define (translate-terms acts) + (map (lambda (act) + (cons (list-ref terms (car act)) + (cdr act))) + acts)) + + (do ((i 0 (+ i 1))) + ((= i nstates)) + (let ((acts (vector-ref action-table i))) + (if (vector? (vector-ref reduction-table i)) + (let ((act (most-common-action acts))) + (vector-set! action-table i + (cons `(*default* . ,(if act act 'error)) + (translate-terms + (lalr-filter (lambda (x) + (not (eq? (cdr x) act))) + acts))))) + (vector-set! action-table i + (cons `(*default* . *error*) + (translate-terms acts))))))) + + + +;; -- + +(define (rewrite-grammar tokens grammar k) + + (define eoi '*eoi*) + + (define (check-terminal term terms) + (cond + ((not (valid-terminal? term)) + (lalr-error "invalid terminal: " term)) + ((member term terms) + (lalr-error "duplicate definition of terminal: " term)))) + + (define (prec->type prec) + (cdr (assq prec '((left: . left) + (right: . right) + (nonassoc: . nonassoc))))) + + (cond + ;; --- a few error conditions ---------------------------------------- ;; + ((not (list? tokens)) + (lalr-error "Invalid token list: " tokens)) + ((not (pair? grammar)) + (lalr-error "Grammar definition must have a non-empty list of productions" '())) + + (else + ;; --- check the terminals ---------------------------------------- ;; + (let loop1 ((lst tokens) + (rev-terms '()) + (rev-terms/prec '()) + (prec-level 0)) + (if (pair? lst) + (let ((term (car lst))) + (cond + ((pair? term) + (if (and (memq (car term) '(left: right: nonassoc:)) + (not (null? (cdr term)))) + (let ((prec (+ prec-level 1)) + (optype (prec->type (car term)))) + (let loop-toks ((l (cdr term)) + (rev-terms rev-terms) + (rev-terms/prec rev-terms/prec)) + (if (null? l) + (loop1 (cdr lst) rev-terms rev-terms/prec prec) + (let ((term (car l))) + (check-terminal term rev-terms) + (loop-toks + (cdr l) + (cons term rev-terms) + (cons (list term optype prec) rev-terms/prec)))))) + + (lalr-error "invalid operator precedence specification: " term))) + + (else + (check-terminal term rev-terms) + (loop1 (cdr lst) + (cons term rev-terms) + (cons (list term 'none 0) rev-terms/prec) + prec-level)))) + + ;; --- check the grammar rules ------------------------------ ;; + (let loop2 ((lst grammar) (rev-nonterm-defs '())) + (if (pair? lst) + (let ((def (car lst))) + (if (not (pair? def)) + (lalr-error "Nonterminal definition must be a non-empty list" '()) + (let ((nonterm (car def))) + (cond ((not (valid-nonterminal? nonterm)) + (lalr-error "Invalid nonterminal:" nonterm)) + ((or (member nonterm rev-terms) + (assoc nonterm rev-nonterm-defs)) + (lalr-error "Nonterminal previously defined:" nonterm)) + (else + (loop2 (cdr lst) + (cons def rev-nonterm-defs))))))) + (let* ((terms (cons eoi (reverse rev-terms))) + (terms/prec (cons '(eoi none 0) (reverse rev-terms/prec))) + (nonterm-defs (reverse rev-nonterm-defs)) + (nonterms (cons '*start* (map car nonterm-defs)))) + (if (= (length nonterms) 1) + (lalr-error "Grammar must contain at least one nonterminal" '()) + (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) -> $1) + nonterm-defs)) + (ruleno 0) + (comp-defs '())) + (if (pair? defs) + (let* ((nonterm-def (car defs)) + (compiled-def (rewrite-nonterm-def + nonterm-def + ruleno + terms nonterms))) + (loop-defs (cdr defs) + (+ ruleno (length compiled-def)) + (cons compiled-def comp-defs))) + + (let ((compiled-nonterm-defs (reverse comp-defs))) + (k terms + terms/prec + nonterms + (map (lambda (x) (cons (caaar x) (map cdar x))) + compiled-nonterm-defs) + (apply append compiled-nonterm-defs)))))))))))))) + + +(define *arrow* '->) + +(define (rewrite-nonterm-def nonterm-def ruleno terms nonterms) + + (define No-NT (length nonterms)) + + (define (encode x) + (let ((PosInNT (pos-in-list x nonterms))) + (if PosInNT + PosInNT + (let ((PosInT (pos-in-list x terms))) + (if PosInT + (+ No-NT PosInT) + (lalr-error "undefined symbol : " x)))))) + + (define (process-prec-directive rhs ruleno) + (let loop ((l rhs)) + (if (null? l) + '() + (let ((first (car l)) + (rest (cdr l))) + (cond + ((or (member first terms) (member first nonterms)) + (cons first (loop rest))) + ((and (pair? first) + (eq? (car first) 'prec:)) + (pair? (cdr first)) + (if (and (pair? (cdr first)) + (member (cadr first) terms)) + (if (null? (cddr first)) + (begin + (add-rule-precedence! ruleno (pos-in-list (cadr first) terms)) + (loop rest)) + (lalr-error "prec: directive should be at end of rule: " rhs)) + (lalr-error "Invalid prec: directive: " first))) + (else + (lalr-error "Invalid terminal or nonterminal: " first))))))) + + + (if (not (pair? (cdr nonterm-def))) + (lalr-error "At least one production needed for nonterminal" (car nonterm-def)) + (let ((name (symbol->string (car nonterm-def)))) + (let loop1 ((lst (cdr nonterm-def)) + (i 1) + (rev-productions-and-actions '())) + (if (not (pair? lst)) + (reverse rev-productions-and-actions) + (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1))) + (rest (cdr lst)) + (prod (map encode (cons (car nonterm-def) rhs)))) + (for-each (lambda (x) + (if (not (or (member x terms) (member x nonterms))) + (lalr-error "Invalid terminal or nonterminal" x))) + rhs) + (if (and (pair? rest) + (eq? (car rest) *arrow*) + (pair? (cdr rest))) + (loop1 (cddr rest) + (+ i 1) + (cons (cons prod (cadr rest)) + rev-productions-and-actions)) + (let* ((rhs-length (length rhs)) + (action + (cons 'vector + (cons (list 'quote (string->symbol + (string-append + name + "-" + (number->string i)))) + (let loop-j ((j 1)) + (if (> j rhs-length) + '() + (cons (string->symbol + (string-append + "$" + (number->string j))) + (loop-j (+ j 1))))))))) + (loop1 rest + (+ i 1) + (cons (cons prod action) + rev-productions-and-actions)))))))))) + +(define (valid-nonterminal? x) + (symbol? x)) + +(define (valid-terminal? x) + (symbol? x)) ; DB + +;; ---------------------------------------------------------------------- ;; +;; Miscellaneous ;; +;; ---------------------------------------------------------------------- ;; +(define (pos-in-list x lst) + (let loop ((lst lst) (i 0)) + (cond ((not (pair? lst)) #f) + ((equal? (car lst) x) i) + (else (loop (cdr lst) (+ i 1)))))) + +(define (sunion lst1 lst2) ; union of sorted lists + (let loop ((L1 lst1) + (L2 lst2)) + (cond ((null? L1) L2) + ((null? L2) L1) + (else + (let ((x (car L1)) (y (car L2))) + (cond + ((> x y) + (cons y (loop L1 (cdr L2)))) + ((< x y) + (cons x (loop (cdr L1) L2))) + (else + (loop (cdr L1) L2)) + )))))) + +(define (sinsert elem lst) + (let loop ((l1 lst)) + (if (null? l1) + (cons elem l1) + (let ((x (car l1))) + (cond ((< elem x) + (cons elem l1)) + ((> elem x) + (cons x (loop (cdr l1)))) + (else + l1)))))) + +(define (lalr-filter p lst) + (let loop ((l lst)) + (if (null? l) + '() + (let ((x (car l)) (y (cdr l))) + (if (p x) + (cons x (loop y)) + (loop y)))))) + +;; ---------------------------------------------------------------------- ;; +;; Debugging tools ... ;; +;; ---------------------------------------------------------------------- ;; +(define the-terminals #f) ; names of terminal symbols +(define the-nonterminals #f) ; non-terminals + +(define (print-item item-no) + (let loop ((i item-no)) + (let ((v (vector-ref ritem i))) + (if (>= v 0) + (loop (+ i 1)) + (let* ((rlno (- v)) + (nt (vector-ref rlhs rlno))) + (display (vector-ref the-nonterminals nt)) (display " --> ") + (let loop ((i (vector-ref rrhs rlno))) + (let ((v (vector-ref ritem i))) + (if (= i item-no) + (display ". ")) + (if (>= v 0) + (begin + (print-symbol v) + (display " ") + (loop (+ i 1))) + (begin + (display " (rule ") + (display (- v)) + (display ")") + (newline)))))))))) + +(define (print-symbol n . port) + (display (if (>= n nvars) + (vector-ref the-terminals (- n nvars)) + (vector-ref the-nonterminals n)) + (if (null? port) + (current-output-port) + (car port)))) + +(define (print-states) +"Print the states of a generated parser." + (define (print-action act) + (cond + ((eq? act '*error*) + (display " : Error")) + ((eq? act 'accept) + (display " : Accept input")) + ((< act 0) + (display " : reduce using rule ") + (display (- act))) + (else + (display " : shift and goto state ") + (display act))) + (newline) + #t) + + (define (print-actions acts) + (let loop ((l acts)) + (if (null? l) + #t + (let ((sym (caar l)) + (act (cdar l))) + (display " ") + (cond + ((eq? sym 'default) + (display "default action")) + (else + (if (number? sym) + (print-symbol (+ sym nvars)) + (display sym)))) + (print-action act) + (loop (cdr l)))))) + + (if (not action-table) + (begin + (display "No generated parser available!") + (newline) + #f) + (begin + (display "State table") (newline) + (display "-----------") (newline) (newline) + + (let loop ((l first-state)) + (if (null? l) + #t + (let* ((core (car l)) + (i (core-number core)) + (items (core-items core)) + (actions (vector-ref action-table i))) + (display "state ") (display i) (newline) + (newline) + (for-each (lambda (x) (display " ") (print-item x)) + items) + (newline) + (print-actions actions) + (newline) + (loop (cdr l)))))))) + + + +;; ---------------------------------------------------------------------- ;; + +(define build-goto-table + (lambda () + `(vector + ,@(map + (lambda (shifts) + (list 'quote + (if shifts + (let loop ((l (shift-shifts shifts))) + (if (null? l) + '() + (let* ((state (car l)) + (symbol (vector-ref acces-symbol state))) + (if (< symbol nvars) + (cons `(,symbol . ,state) + (loop (cdr l))) + (loop (cdr l)))))) + '()))) + (vector->list shift-table))))) + + +(define build-reduction-table + (lambda (gram/actions) + `(vector + '() + ,@(map + (lambda (p) + (let ((act (cdr p))) + `(lambda (___stack ___sp ___goto-table ___k) + ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs))) + `(let* (,@(if act + (let loop ((i 1) (l rhs)) + (if (pair? l) + (let ((rest (cdr l))) + (cons + `(,(string->symbol + (string-append + "$" + (number->string + (+ (- n i) 1)))) + (vector-ref ___stack (- ___sp ,(- (* i 2) 1)))) + (loop (+ i 1) rest))) + '())) + '())) + ,(if (= nt 0) + '$1 + `(___push ___stack (- ___sp ,(* 2 n)) + ,nt ___goto-table ,(cdr p) ___k))))))) + + gram/actions)))) + + +;; @section (api "API") + +(define-macro (lalr-parser tokens . rules) + (let* ((gram/actions (gen-tables! tokens rules)) + (code + `(letrec ((___max-stack-size 500) + + (___atable ',action-table) + (___gtable ,(build-goto-table)) + (___grow-stack (lambda (stack) + ;; make a new stack twice as big as the original + (let ((new-stack (make-vector (* 2 (vector-length stack)) #f))) + ;; then copy the elements... + (let loop ((i (- (vector-length stack) 1))) + (if (< i 0) + new-stack + (begin + (vector-set! new-stack i (vector-ref stack i)) + (loop (- i 1)))))))) + + (___push (lambda (stack sp new-cat goto-table lval k) + (let* ((state (vector-ref stack sp)) + (new-state (cdr (assq new-cat (vector-ref goto-table state)))) + (new-sp (+ sp 2)) + (stack (if (< new-sp (vector-length stack)) + stack + (___grow-stack stack)))) + (vector-set! stack new-sp new-state) + (vector-set! stack (- new-sp 1) lval) + (k stack new-sp)))) + + (___action (lambda (x l) + (let ((y (assq x l))) + (if y (cdr y) (cdar l))))) + + (___rtable ,(build-reduction-table gram/actions))) + + (lambda (lexerp errorp) + + (let ((stack (make-vector ___max-stack-size 0))) + (let loop ((stack stack) (sp 0) (input (lexerp))) + (let* ((state (vector-ref stack sp)) + (i (if (pair? input) (car input) input)) + (attr (if (pair? input) (cdr input) #f)) + (act (___action i (vector-ref ___atable state)))) + + (if (not (symbol? i)) + (errorp "PARSE ERROR: invalid token: " input)) + + (cond + + ;; Input succesfully parsed + ((eq? act 'accept) + (vector-ref stack 1)) + + ;; Syntax error in input + ((eq? act '*error*) + (if (eq? i '*eoi*) + (errorp "PARSE ERROR : unexpected end of input ") + (errorp "PARSE ERROR : unexpected token : " input))) + + ;; Shift current token on top of the stack + ((>= act 0) + (let ((stack (if (< (+ sp 2) (vector-length stack)) + stack + (___grow-stack stack)))) + (vector-set! stack (+ sp 1) attr) + (vector-set! stack (+ sp 2) act) + (loop stack (+ sp 2) (lexerp)))) + + ;; Reduce by rule (- act) + (else + ((vector-ref ___rtable (- act)) + stack sp ___gtable + (lambda (stack sp) + (loop stack sp input)))))))))))) + code)) + +;; arch-tag: 4FE771DE-F56D-11D8-8B77-000A95B4C7DC diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm new file mode 100644 index 000000000..ce731a736 --- /dev/null +++ b/module/language/ecmascript/parse.scm @@ -0,0 +1,337 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript parse) + #:use-module (language ecmascript parse-lalr) + #:use-module (language ecmascript tokenize) + #:export (read-ecmascript read-ecmascript/1 parse-ecmascript)) + +(define (syntax-error message . args) + (apply throw 'SyntaxError message args)) + +(define (read-ecmascript port) + (parse-ecmascript (make-tokenizer port) syntax-error)) + +(define (read-ecmascript/1 port) + (parse-ecmascript (make-tokenizer/1 port) syntax-error)) + +(define *eof-object* + (call-with-input-string "" read-char)) + +(define parse-ecmascript + (lalr-parser + ;; terminal (i.e. input) token types + (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma < + > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ? + colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /= + + break else new var case finally return void catch for switch while + continue function this with default if throw delete in try do + instanceof typeof null true false + + Identifier StringLiteral NumericLiteral RegexpLiteral) + + + (Program (SourceElements) -> $1 + (*eoi*) -> *eof-object*) + + ;; + ;; Verily, here we define statements. Expressions are defined + ;; afterwards. + ;; + + (SourceElement (Statement) -> $1 + (FunctionDeclaration) -> $1) + + (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(var (,$2 (lambda () ,$6))) + (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(var (,$2 (lambda ,$4 ,$7)))) + (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$5) + (function Identifier lparen rparen lbrace FunctionBody rbrace) -> `(lambda () ,$6) + (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$3 ,$6) + (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) -> `(lambda ,$4 ,$7)) + (FormalParameterList (Identifier) -> `(,$1) + (FormalParameterList comma Identifier) -> `(,@$1 ,$3)) + (SourceElements (SourceElement) -> $1 + (SourceElements SourceElement) -> (if (and (pair? $1) (eq? (car $1) 'begin)) + `(begin ,@(cdr $1) ,$2) + `(begin ,$1 ,$2))) + (FunctionBody (SourceElements) -> $1) + + (Statement (Block) -> $1 + (VariableStatement) -> $1 + (EmptyStatement) -> $1 + (ExpressionStatement) -> $1 + (IfStatement) -> $1 + (IterationStatement) -> $1 + (ContinueStatement) -> $1 + (BreakStatement) -> $1 + (ReturnStatement) -> $1 + (WithStatement) -> $1 + (LabelledStatement) -> $1 + (SwitchStatement) -> $1 + (ThrowStatement) -> $1 + (TryStatement) -> $1) + + (Block (lbrace StatementList rbrace) -> `(block ,$2)) + (StatementList (Statement) -> $1 + (StatementList Statement) -> (if (and (pair? $1) (eq? (car $1) 'begin)) + `(begin ,@(cdr $1) ,$2) + `(begin ,$1 ,$2))) + + (VariableStatement (var VariableDeclarationList) -> `(var ,@$2)) + (VariableDeclarationList (VariableDeclaration) -> `(,$1) + (VariableDeclarationList comma VariableDeclaration) -> `(,@$1 ,$2)) + (VariableDeclarationListNoIn (VariableDeclarationNoIn) -> `(,$1) + (VariableDeclarationListNoIn comma VariableDeclarationNoIn) -> `(,@$1 ,$2)) + (VariableDeclaration (Identifier) -> `(,$1) + (Identifier Initialiser) -> `(,$1 ,$2)) + (VariableDeclarationNoIn (Identifier) -> `(,$1) + (Identifier Initialiser) -> `(,$1 ,$2)) + (Initialiser (= AssignmentExpression) -> $2) + (InitialiserNoIn (= AssignmentExpressionNoIn) -> $2) + + (EmptyStatement (semicolon) -> '(begin)) + + (ExpressionStatement (Expression semicolon) -> $1) + + (IfStatement (if lparen Expression rparen Statement else Statement) -> `(if ,$3 ,$5 ,$7) + (if lparen Expression rparen Statement) -> `(if ,$3 ,$5)) + + (IterationStatement (do Statement while lparen Expression rparen semicolon) -> `(do ,$2 ,$5) + + (while lparen Expression rparen Statement) -> `(while ,$3 ,$5) + + (for lparen semicolon semicolon rparen Statement) -> `(for #f #f #f ,$6) + (for lparen semicolon semicolon Expression rparen Statement) -> `(for #f #f ,$5 ,$7) + (for lparen semicolon Expression semicolon rparen Statement) -> `(for #f ,$4 #f ,$7) + (for lparen semicolon Expression semicolon Expression rparen Statement) -> `(for #f ,$4 ,$6 ,$8) + + (for lparen ExpressionNoIn semicolon semicolon rparen Statement) -> `(for ,$3 #f #f ,$7) + (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) -> `(for ,$3 #f ,$6 ,$8) + (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) -> `(for ,$3 ,$5 #f ,$8) + (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for ,$3 ,$5 ,$7 ,$9) + + (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) -> `(for (var ,@$4) #f #f ,$8) + (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) -> `(for (var ,@$4) #f ,$7 ,$9) + (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) -> `(for (var ,@$4) ,$6 #f ,$9) + (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) -> `(for (var ,@$4) ,$6 ,$8 ,$10) + + (for lparen LeftHandSideExpression in Expression rparen Statement) -> `(for-in ,$3 ,$5 ,$7) + (for lparen var VariableDeclarationNoIn in Expression rparen Statement) -> `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8))) + + (ContinueStatement (continue Identifier semicolon) -> `(continue ,$2) + (continue semicolon) -> `(continue)) + + (BreakStatement (break Identifier semicolon) -> `(break ,$2) + (break semicolon) -> `(break)) + + (ReturnStatement (return Expression semicolon) -> `(return ,$2) + (return semicolon) -> `(return)) + + (WithStatement (with lparen Expression rparen Statement) -> `(with ,$3 ,$5)) + + (SwitchStatement (switch lparen Expression rparen CaseBlock) -> `(switch ,$3 ,@$5)) + (CaseBlock (lbrace rbrace) -> '() + (lbrace CaseClauses rbrace) -> $2 + (lbrace CaseClauses DefaultClause rbrace) -> `(,@$2 ,@$3) + (lbrace DefaultClause rbrace) -> `(,$2) + (lbrace DefaultClause CaseClauses rbrace) -> `(,@$2 ,@$3)) + (CaseClauses (CaseClause) -> `(,$1) + (CaseClauses CaseClause) -> `(,@$1 ,$2)) + (CaseClause (case Expression colon) -> `(case ,$2) + (case Expression colon StatementList) -> `(case ,$2 ,$4)) + (DefaultClause (default colon) -> `(default) + (default colon StatementList) -> `(default ,$3)) + + (LabelledStatement (Identifier colon Statement) -> `(label ,$1 ,$3)) + + (ThrowStatement (throw Expression semicolon) -> `(throw ,$2)) + + (TryStatement (try Block Catch) -> `(try ,$2 ,$3 #f) + (try Block Finally) -> `(try ,$2 #f ,$3) + (try Block Catch Finally) -> `(try ,$2 ,$3 ,$4)) + (Catch (catch lparen Identifier rparen Block) -> `(catch ,$3 ,$5)) + (Finally (finally Block) -> `(finally ,$2)) + + ;; + ;; As promised, expressions. We build up to Expression bottom-up, so + ;; as to get operator precedence right. + ;; + + (PrimaryExpression (this) -> 'this + (null) -> 'null + (true) -> 'true + (false) -> 'false + (Identifier) -> `(ref ,$1) + (StringLiteral) -> `(string ,$1) + (RegexpLiteral) -> `(regexp ,$1) + (NumericLiteral) -> `(number ,$1) + (ArrayLiteral) -> $1 + (ObjectLiteral) -> $1 + (lparen Expression rparen) -> $2) + + (ArrayLiteral (lbracket rbracket) -> '(array) + (lbracket Elision rbracket) -> '(array ,@$2) + (lbracket ElementList rbracket) -> `(array ,@$2) + (lbracket ElementList comma rbracket) -> `(array ,@$2) + (lbracket ElementList comma Elision rbracket) -> `(array ,@$2)) + (ElementList (AssignmentExpression) -> `(,$1) + (Elision AssignmentExpression) -> `(,@$1 ,$2) + (ElementList comma AssignmentExpression) -> `(,@$1 ,$3) + (ElementList comma Elision AssignmentExpression) -> `(,@$1 ,@$3 ,$4)) + (Elision (comma) -> '((number 0)) + (Elision comma) -> `(,@$1 (number 0))) + + (ObjectLiteral (lbrace rbrace) -> `(object) + (lbrace PropertyNameAndValueList rbrace) -> `(object ,@$2)) + (PropertyNameAndValueList (PropertyName colon AssignmentExpression) -> `((,$1 ,$3)) + (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) -> `(,@$1 (,$3 ,$5))) + (PropertyName (Identifier) -> $1 + (StringLiteral) -> (string->symbol $1) + (NumericLiteral) -> $1) + + (MemberExpression (PrimaryExpression) -> $1 + (FunctionExpression) -> $1 + (MemberExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3) + (MemberExpression dot Identifier) -> `(pref ,$1 ,$3) + (new MemberExpression Arguments) -> `(new ,$2 ,$3)) + + (NewExpression (MemberExpression) -> $1 + (new NewExpression) -> `(new ,$2 ())) + + (CallExpression (MemberExpression Arguments) -> `(call ,$1 ,$2) + (CallExpression Arguments) -> `(call ,$1 ,$2) + (CallExpression lbracket Expression rbracket) -> `(aref ,$1 ,$3) + (CallExpression dot Identifier) -> `(pref ,$1 ,$3)) + (Arguments (lparen rparen) -> '() + (lparen ArgumentList rparen) -> $2) + (ArgumentList (AssignmentExpression) -> `(,$1) + (ArgumentList comma AssignmentExpression) -> `(,@$1 ,$3)) + + (LeftHandSideExpression (NewExpression) -> $1 + (CallExpression) -> $1) + + (PostfixExpression (LeftHandSideExpression) -> $1 + (LeftHandSideExpression ++) -> `(postinc ,$1) + (LeftHandSideExpression --) -> `(postdec ,$1)) + + (UnaryExpression (PostfixExpression) -> $1 + (delete UnaryExpression) -> `(delete ,$2) + (void UnaryExpression) -> `(void ,$2) + (typeof UnaryExpression) -> `(typeof ,$2) + (++ UnaryExpression) -> `(preinc ,$2) + (-- UnaryExpression) -> `(predec ,$2) + (+ UnaryExpression) -> `(+ ,$2) + (- UnaryExpression) -> `(- ,$2) + (~ UnaryExpression) -> `(~ ,$2) + (! UnaryExpression) -> `(! ,$2)) + + (MultiplicativeExpression (UnaryExpression) -> $1 + (MultiplicativeExpression * UnaryExpression) -> `(* ,$1 ,$3) + (MultiplicativeExpression / UnaryExpression) -> `(/ ,$1 ,$3) + (MultiplicativeExpression % UnaryExpression) -> `(% ,$1 ,$3)) + + (AdditiveExpression (MultiplicativeExpression) -> $1 + (AdditiveExpression + MultiplicativeExpression) -> `(+ ,$1 ,$3) + (AdditiveExpression - MultiplicativeExpression) -> `(- ,$1 ,$3)) + + (ShiftExpression (AdditiveExpression) -> $1 + (ShiftExpression << MultiplicativeExpression) -> `(<< ,$1 ,$3) + (ShiftExpression >> MultiplicativeExpression) -> `(>> ,$1 ,$3) + (ShiftExpression >>> MultiplicativeExpression) -> `(>>> ,$1 ,$3)) + + (RelationalExpression (ShiftExpression) -> $1 + (RelationalExpression < ShiftExpression) -> `(< ,$1 ,$3) + (RelationalExpression > ShiftExpression) -> `(> ,$1 ,$3) + (RelationalExpression <= ShiftExpression) -> `(<= ,$1 ,$3) + (RelationalExpression >= ShiftExpression) -> `(>= ,$1 ,$3) + (RelationalExpression instanceof ShiftExpression) -> `(instanceof ,$1 ,$3) + (RelationalExpression in ShiftExpression) -> `(in ,$1 ,$3)) + + (RelationalExpressionNoIn (ShiftExpression) -> $1 + (RelationalExpressionNoIn < ShiftExpression) -> `(< ,$1 ,$3) + (RelationalExpressionNoIn > ShiftExpression) -> `(> ,$1 ,$3) + (RelationalExpressionNoIn <= ShiftExpression) -> `(<= ,$1 ,$3) + (RelationalExpressionNoIn >= ShiftExpression) -> `(>= ,$1 ,$3) + (RelationalExpressionNoIn instanceof ShiftExpression) -> `(instanceof ,$1 ,$3)) + + (EqualityExpression (RelationalExpression) -> $1 + (EqualityExpression == RelationalExpression) -> `(== ,$1 ,$3) + (EqualityExpression != RelationalExpression) -> `(!= ,$1 ,$3) + (EqualityExpression === RelationalExpression) -> `(=== ,$1 ,$3) + (EqualityExpression !== RelationalExpression) -> `(!== ,$1 ,$3)) + + (EqualityExpressionNoIn (RelationalExpressionNoIn) -> $1 + (EqualityExpressionNoIn == RelationalExpressionNoIn) -> `(== ,$1 ,$3) + (EqualityExpressionNoIn != RelationalExpressionNoIn) -> `(!= ,$1 ,$3) + (EqualityExpressionNoIn === RelationalExpressionNoIn) -> `(=== ,$1 ,$3) + (EqualityExpressionNoIn !== RelationalExpressionNoIn) -> `(!== ,$1 ,$3)) + + (BitwiseANDExpression (EqualityExpression) -> $1 + (BitwiseANDExpression & EqualityExpression) -> `(& ,$1 ,$3)) + (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) -> $1 + (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) -> `(& ,$1 ,$3)) + + (BitwiseXORExpression (BitwiseANDExpression) -> $1 + (BitwiseXORExpression ^ BitwiseANDExpression) -> `(^ ,$1 ,$3)) + (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) -> $1 + (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) -> `(^ ,$1 ,$3)) + + (BitwiseORExpression (BitwiseXORExpression) -> $1 + (BitwiseORExpression bor BitwiseXORExpression) -> `(bor ,$1 ,$3)) + (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) -> $1 + (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) -> `(bor ,$1 ,$3)) + + (LogicalANDExpression (BitwiseORExpression) -> $1 + (LogicalANDExpression && BitwiseORExpression) -> `(and ,$1 ,$3)) + (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) -> $1 + (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) -> `(and ,$1 ,$3)) + + (LogicalORExpression (LogicalANDExpression) -> $1 + (LogicalORExpression or LogicalANDExpression) -> `(or ,$1 ,$3)) + (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) -> $1 + (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) -> `(or ,$1 ,$3)) + + (ConditionalExpression (LogicalORExpression) -> $1 + (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) -> `(if ,$1 ,$3 ,$5)) + (ConditionalExpressionNoIn (LogicalORExpressionNoIn) -> $1 + (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) -> `(if ,$1 ,$3 ,$5)) + + (AssignmentExpression (ConditionalExpression) -> $1 + (LeftHandSideExpression AssignmentOperator AssignmentExpression) -> `(,$2 ,$1 ,$3)) + (AssignmentExpressionNoIn (ConditionalExpressionNoIn) -> $1 + (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) -> `(,$2 ,$1 ,$3)) + (AssignmentOperator (=) -> '= + (*=) -> '*= + (/=) -> '/= + (%=) -> '%= + (+=) -> '+= + (-=) -> '-= + (<<=) -> '<<= + (>>=) -> '>>= + (>>>=) -> '>>>= + (&=) -> '&= + (^=) -> '^= + (bor=) -> 'bor=) + + (Expression (AssignmentExpression) -> $1 + (Expression comma AssignmentExpression) -> `(begin ,$1 ,$3)) + (ExpressionNoIn (AssignmentExpressionNoIn) -> $1 + (ExpressionNoIn comma AssignmentExpressionNoIn) -> `(begin ,$1 ,$3)))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm new file mode 100644 index 000000000..7a1ea465c --- /dev/null +++ b/module/language/ecmascript/spec.scm @@ -0,0 +1,38 @@ +;;; ECMAScript specification for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript spec) + #:use-module (system base language) + #:use-module (language ecmascript parse) + #:use-module (language ecmascript compile-tree-il) + #:export (ecmascript)) + +;;; +;;; Language definition +;;; + +(define-language ecmascript + #:title "Guile ECMAScript" + #:version "3.0" + #:reader (lambda () (read-ecmascript/1 (current-input-port))) + #:compilers `((tree-il . ,compile-tree-il)) + ;; a pretty-printer would be interesting. + #:printer write + ) diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm new file mode 100644 index 000000000..1b6a7eeaf --- /dev/null +++ b/module/language/ecmascript/tokenize.scm @@ -0,0 +1,479 @@ +;;; ECMAScript for Guile + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ecmascript tokenize) + #:use-module (ice-9 rdelim) + #:use-module ((srfi srfi-1) #:select (unfold-right)) + #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1)) + +(define (syntax-error message . args) + (apply throw 'SyntaxError message args)) + +;; taken from SSAX, sorta +(define (read-until delims port) + (if (eof-object? (peek-char port)) + (syntax-error "EOF while reading a token") + (let ((token (read-delimited delims port 'peek))) + (if (eof-object? (peek-char port)) + (syntax-error "EOF while reading a token") + token)))) + +(define (char-hex? c) + (and (not (eof-object? c)) + (or (char-numeric? c) + (memv c '(#\a #\b #\c #\d #\e #\f)) + (memv c '(#\A #\B #\C #\D #\E #\F))))) + +(define (digit->number c) + (- (char->integer c) (char->integer #\0))) + +(define (hex->number c) + (if (char-numeric? c) + (digit->number c) + (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a))))) + +(define (read-slash port div?) + (let* ((c0 (read-char port)) + (c1 (peek-char port))) + (cond + ((eof-object? c1) + ;; hmm. error if we're not looking for a div? ? + '(/ . #f)) + ((char=? c1 #\/) + (read-line port) + (next-token port div?)) + ((char=? c1 #\*) + (read-char port) + (let lp ((c (read-char port))) + (cond + ((eof-object? c) (syntax-error "EOF while in multi-line comment")) + ((char=? c #\*) + (if (eqv? (peek-char port) #\/) + (begin + (read-char port) + (next-token port div?)) + (lp (read-char port)))) + (else + (lp (read-char port)))))) + (div? + (case c1 + ((#\=) (read-char port) `(/= . #f)) + (else `(/ . #f)))) + (else + (read-regexp port))))) + +(define (read-regexp port) + ;; first slash already read + (let ((terms (string #\/ #\\ #\nl #\cr))) + (let lp ((str (read-until terms port)) (head "")) + (let ((terminator (peek-char port))) + (cond + ((char=? terminator #\/) + (read-char port) + ;; flags + (let lp ((c (peek-char port)) (flags '())) + (if (or (eof-object? c) + (not (or (char-alphabetic? c) + (char-numeric? c) + (char=? c #\$) + (char=? c #\_)))) + `(RegexpLiteral . (,(string-append head str) . ,(reverse flags))) + (begin (read-char port) + (lp (peek-char port) (cons c flags)))))) + ((char=? terminator #\\) + (read-char port) + (let ((echar (read-char port))) + (lp (read-until terms port) + (string-append head str (string #\\ echar))))) + (else + (syntax-error "regexp literals may not contain newlines" str))))))) + +(define (read-string port) + (let ((c (read-char port))) + (let ((terms (string c #\\ #\nl #\cr))) + (define (read-escape port) + (let ((c (read-char port))) + (case c + ((#\' #\" #\\) c) + ((#\b) #\bs) + ((#\f) #\np) + ((#\n) #\nl) + ((#\r) #\cr) + ((#\t) #\tab) + ((#\v) #\vt) + ((#\0) + (let ((next (peek-char port))) + (cond ((eof-object? next) #\nul) + ((char-numeric? next) + (syntax-error "octal escape sequences are not supported")) + (else #\nul)))) + ((#\x) + (let* ((a (read-char port)) + (b (read-char port))) + (cond + ((and (char-hex? a) (char-hex? b)) + (integer->char (+ (* 16 (hex->number a)) (hex->number b)))) + (else + (syntax-error "bad hex character escape" a b))))) + ((#\u) + (syntax-error "unicode not supported")) + (else + c)))) + (let lp ((str (read-until terms port))) + (let ((terminator (peek-char port))) + (cond + ((char=? terminator c) + (read-char port) + str) + ((char=? terminator #\\) + (read-char port) + (let ((echar (read-escape port))) + (lp (string-append str (string echar) + (read-until terms port))))) + (else + (syntax-error "string literals may not contain newlines" str)))))))) + +(define *keywords* + '(("break" . break) + ("else" . else) + ("new" . new) + ("var" . var) + ("case" . case) + ("finally" . finally) + ("return" . return) + ("void" . void) + ("catch" . catch) + ("for" . for) + ("switch" . switch) + ("while" . while) + ("continue" . continue) + ("function" . function) + ("this" . this) + ("with" . with) + ("default" . default) + ("if" . if) + ("throw" . throw) + ("delete" . delete) + ("in" . in) + ("try" . try) + ("do" . do) + ("instanceof" . instanceof) + ("typeof" . typeof) + + ;; these aren't exactly keywords, but hey + ("null" . null) + ("true" . true) + ("false" . false))) + +(define *future-reserved-words* + '(("abstract" . abstract) + ("enum" . enum) + ("int" . int) + ("short" . short) + ("boolean" . boolean) + ("export" . export) + ("interface" . interface) + ("static" . static) + ("byte" . byte) + ("extends" . extends) + ("long" . long) + ("super" . super) + ("char" . char) + ("final" . final) + ("native" . native) + ("synchronized" . synchronized) + ("class" . class) + ("float" . float) + ("package" . package) + ("throws" . throws) + ("const" . const) + ("goto" . goto) + ("private" . private) + ("transient" . transient) + ("debugger" . debugger) + ("implements" . implements) + ("protected" . protected) + ("volatile" . volatile) + ("double" . double) + ("import" . import) + ("public" . public))) + +(define (read-identifier port) + (let lp ((c (peek-char port)) (chars '())) + (if (or (eof-object? c) + (not (or (char-alphabetic? c) + (char-numeric? c) + (char=? c #\$) + (char=? c #\_)))) + (let ((word (list->string (reverse chars)))) + (cond ((assoc-ref *keywords* word) + => (lambda (x) `(,x . #f))) + ((assoc-ref *future-reserved-words* word) + (syntax-error "word is reserved for the future, dude." word)) + (else `(Identifier . ,(string->symbol word))))) + (begin (read-char port) + (lp (peek-char port) (cons c chars)))))) + +(define (read-numeric port) + (let* ((c0 (if (char=? (peek-char port) #\.) + #\0 + (read-char port))) + (c1 (peek-char port))) + (cond + ((eof-object? c1) (digit->number c0)) + ((and (char=? c0 #\0) (char=? c1 #\x)) + (read-char port) + (let ((c (peek-char port))) + (if (not (char-hex? c)) + (syntax-error "bad digit reading hexadecimal number" c)) + (let lp ((c c) (acc 0)) + (cond ((char-hex? c) + (read-char port) + (lp (peek-char port) + (+ (* 16 acc) (hex->number c)))) + (else + acc))))) + ((and (char=? c0 #\0) (char-numeric? c1)) + (let lp ((c c1) (acc 0)) + (cond ((eof-object? c) acc) + ((char-numeric? c) + (if (or (char=? c #\8) (char=? c #\9)) + (syntax-error "invalid digit in octal sequence" c)) + (read-char port) + (lp (peek-char port) + (+ (* 8 acc) (digit->number c)))) + (else + acc)))) + (else + (let lp ((c1 c1) (acc (digit->number c0))) + (cond + ((eof-object? c1) acc) + ((char-numeric? c1) + (read-char port) + (lp (peek-char port) + (+ (* 10 acc) (digit->number c1)))) + ((or (char=? c1 #\e) (char=? c1 #\E)) + (read-char port) + (let ((add (let ((c (peek-char port))) + (cond ((eof-object? c) (syntax-error "error reading exponent: EOF")) + ((char=? c #\+) (read-char port) +) + ((char=? c #\-) (read-char port) -) + ((char-numeric? c) +) + (else (syntax-error "error reading exponent: non-digit" + c)))))) + (let lp ((c (peek-char port)) (e 0)) + (cond ((and (not (eof-object? c)) (char-numeric? c)) + (read-char port) + (lp (peek-char port) (add (* 10 e) (digit->number c)))) + (else + (* (if (negative? e) (* acc 1.0) acc) (expt 10 e))))))) + ((char=? c1 #\.) + (read-char port) + (let lp2 ((c (peek-char port)) (dec 0.0) (n -1)) + (cond ((and (not (eof-object? c)) (char-numeric? c)) + (read-char port) + (lp2 (peek-char port) + (+ dec (* (digit->number c) (expt 10 n))) + (1- n))) + (else + ;; loop back to catch an exponential part + (lp c (+ acc dec)))))) + (else + acc))))))) + +(define *punctuation* + '(("{" . lbrace) + ("}" . rbrace) + ("(" . lparen) + (")" . rparen) + ("[" . lbracket) + ("]" . rbracket) + ("." . dot) + (";" . semicolon) + ("," . comma) + ("<" . <) + (">" . >) + ("<=" . <=) + (">=" . >=) + ("==" . ==) + ("!=" . !=) + ("===" . ===) + ("!==" . !==) + ("+" . +) + ("-" . -) + ("*" . *) + ("%" . %) + ("++" . ++) + ("--" . --) + ("<<" . <<) + (">>" . >>) + (">>>" . >>>) + ("&" . &) + ("|" . bor) + ("^" . ^) + ("!" . !) + ("~" . ~) + ("&&" . &&) + ("||" . or) + ("?" . ?) + (":" . colon) + ("=" . =) + ("+=" . +=) + ("-=" . -=) + ("*=" . *=) + ("%=" . %=) + ("<<=" . <<=) + (">>=" . >>=) + (">>>=" . >>>=) + ("&=" . &=) + ("|=" . bor=) + ("^=" . ^=))) + +(define *div-punctuation* + '(("/" . /) + ("/=" . /=))) + +;; node ::= (char (symbol | #f) node*) +(define read-punctuation + (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*)) + (cond ((null? puncs) + nodes) + ((assv-ref nodes (string-ref (caar puncs) 0)) + => (lambda (node-tail) + (if (= (string-length (caar puncs)) 1) + (set-car! node-tail (cdar puncs)) + (set-cdr! node-tail + (lp (cdr node-tail) + `((,(substring (caar puncs) 1) + . ,(cdar puncs)))))) + (lp nodes (cdr puncs)))) + (else + (lp (cons (list (string-ref (caar puncs) 0) #f) nodes) + puncs)))))) + (lambda (port) + (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f)) + (cond + ((assv-ref tree c) + => (lambda (node-tail) + (read-char port) + (lp (peek-char port) (cdr node-tail) (car node-tail)))) + (candidate + `(,candidate . #f)) + (else + (syntax-error "bad syntax: character not allowed" c))))))) + +(define (next-token port div?) + (let ((c (peek-char port)) + (props `((filename . ,(port-filename port)) + (line . ,(port-line port)) + (column . ,(port-column port))))) + (let ((tok + (case c + ((#\ht #\vt #\np #\space) + ; whitespace + (read-char port) + (next-token port div?)) + ((#\newline #\cr) + ; line break + (read-char port) + (next-token port div?)) + ((#\/) + ;; division, single comment, double comment, or regexp + (read-slash port div?)) + ((#\" #\') + ; string literal + `(StringLiteral . ,(read-string port))) + (else + (cond + ((eof-object? c) + '*eoi*) + ((or (char-alphabetic? c) + (char=? c #\$) + (char=? c #\_)) + ;; reserved word or identifier + (read-identifier port)) + ((char-numeric? c) + ;; numeric -- also accept . FIXME, requires lookahead + `(NumericLiteral . ,(read-numeric port))) + (else + ;; punctuation + (read-punctuation port))))))) + (if (pair? tok) + (set-source-properties! tok props)) + tok))) + +(define (make-tokenizer port) + (let ((div? #f)) + (lambda () + (let ((tok (next-token port div?))) + (set! div? (and (pair? tok) (eq? (car tok) 'identifier))) + tok)))) + +(define (make-tokenizer/1 port) + (let ((div? #f) + (eoi? #f) + (stack '())) + (lambda () + (if eoi? + '*eoi* + (let ((tok (next-token port div?))) + (case (if (pair? tok) (car tok) tok) + ((lparen) + (set! stack (cons 'lparen stack))) + ((rparen) + (if (and (pair? stack) (eq? (car stack) 'lparen)) + (set! stack (cdr stack)) + (syntax-error "unexpected right parenthesis"))) + ((lbracket) + (set! stack (cons 'lbracket stack))) + ((rbracket) + (if (and (pair? stack) (eq? (car stack) 'lbracket)) + (set! stack (cdr stack)) + (syntax-error "unexpected right bracket" stack))) + ((lbrace) + (set! stack (cons 'lbrace stack))) + ((rbrace) + (if (and (pair? stack) (eq? (car stack) 'lbrace)) + (set! stack (cdr stack)) + (syntax-error "unexpected right brace" stack))) + ((semicolon) + (set! eoi? (null? stack)))) + (set! div? (and (pair? tok) + (or (eq? (car tok) 'Identifier) + (eq? (car tok) 'NumericLiteral) + (eq? (car tok) 'StringLiteral)))) + tok))))) + +(define (tokenize port) + (let ((next (make-tokenizer port))) + (let lp ((out '())) + (let ((tok (next))) + (if (eq? tok '*eoi*) + (reverse! out) + (lp (cons tok out))))))) + +(define (tokenize/1 port) + (let ((next (make-tokenizer/1 port))) + (let lp ((out '())) + (let ((tok (next))) + (if (eq? tok '*eoi*) + (reverse! out) + (lp (cons tok out))))))) + diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm new file mode 100644 index 000000000..617e4e3c5 --- /dev/null +++ b/module/language/elisp/spec.scm @@ -0,0 +1,62 @@ +;;; Guile Emac Lisp + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (lang elisp spec) + #:use-module (system lang language) + #:export (elisp)) + + +;;; +;;; Translator +;;; + +(define (translate x) + (if (pair? x) + (translate-pair x) + x)) + +(define (translate-pair x) + (let ((name (car x)) (args (cdr x))) + (case name + ((quote) `(@quote ,@args)) + ((defvar) `(@define ,@(map translate args))) + ((setq) `(@set! ,@(map translate args))) + ((if) `(@if ,(translate (car args)) + (@begin ,@(map translate (cdr args))))) + ((and) `(@and ,@(map translate args))) + ((or) `(@or ,@(map translate args))) + ((progn) `(@begin ,@(map translate args))) + ((defun) `(@define ,(car args) + (@lambda ,(cadr args) ,@(map translate (cddr args))))) + ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args)))) + (else x)))) + + +;;; +;;; Language definition +;;; + +(define-language elisp + #:title "Emacs Lisp" + #:version "0.0" + #:reader read + #:expander id + #:translator translate + ) diff --git a/module/language/ghil.scm b/module/language/ghil.scm new file mode 100644 index 000000000..84cc83de5 --- /dev/null +++ b/module/language/ghil.scm @@ -0,0 +1,478 @@ +;;; Guile High Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ghil) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (ice-9 regex) + #:export + (ghil-env ghil-loc + + <ghil-void> make-ghil-void ghil-void? + ghil-void-env ghil-void-loc + + <ghil-quote> make-ghil-quote ghil-quote? + ghil-quote-env ghil-quote-loc ghil-quote-obj + + <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote? + ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp + + <ghil-unquote> make-ghil-unquote ghil-unquote? + ghil-unquote-env ghil-unquote-loc ghil-unquote-exp + + <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing? + ghil-unquote-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-exp + + <ghil-ref> make-ghil-ref ghil-ref? + ghil-ref-env ghil-ref-loc ghil-ref-var + + <ghil-set> make-ghil-set ghil-set? + ghil-set-env ghil-set-loc ghil-set-var ghil-set-val + + <ghil-define> make-ghil-define ghil-define? + ghil-define-env ghil-define-loc ghil-define-var ghil-define-val + + <ghil-if> make-ghil-if ghil-if? + ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else + + <ghil-and> make-ghil-and ghil-and? + ghil-and-env ghil-and-loc ghil-and-exps + + <ghil-or> make-ghil-or ghil-or? + ghil-or-env ghil-or-loc ghil-or-exps + + <ghil-begin> make-ghil-begin ghil-begin? + ghil-begin-env ghil-begin-loc ghil-begin-exps + + <ghil-bind> make-ghil-bind ghil-bind? + ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body + + <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind? + ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body + + <ghil-lambda> make-ghil-lambda ghil-lambda? + ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest + ghil-lambda-meta ghil-lambda-body + + <ghil-inline> make-ghil-inline ghil-inline? + ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args + + <ghil-call> make-ghil-call ghil-call? + ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args + + <ghil-mv-call> make-ghil-mv-call ghil-mv-call? + ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer + + <ghil-values> make-ghil-values ghil-values? + ghil-values-env ghil-values-loc ghil-values-values + + <ghil-values*> make-ghil-values* ghil-values*? + ghil-values*-env ghil-values*-loc ghil-values*-values + + <ghil-var> make-ghil-var ghil-var? + ghil-var-env ghil-var-name ghil-var-kind ghil-var-index + + <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env? + ghil-toplevel-env-table + + <ghil-env> make-ghil-env ghil-env? + ghil-env-parent ghil-env-table ghil-env-variables + + <ghil-reified-env> make-ghil-reified-env ghil-reified-env? + ghil-reified-env-env ghil-reified-env-loc + + ghil-env-add! + ghil-env-reify ghil-env-dereify + ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define! + ghil-var-at-module! + call-with-ghil-environment call-with-ghil-bindings + + parse-ghil unparse-ghil)) + + +;;; +;;; Parse tree +;;; + +(define (print-ghil x port) + (format port "#<ghil ~s>" (unparse-ghil x))) + +(define-type (<ghil> #:printer print-ghil + #:common-slots (env loc)) + ;; Objects + (<ghil-void>) + (<ghil-quote> obj) + (<ghil-quasiquote> exp) + (<ghil-unquote> exp) + (<ghil-unquote-splicing> exp) + ;; Variables + (<ghil-ref> var) + (<ghil-set> var val) + (<ghil-define> var val) + ;; Controls + (<ghil-if> test then else) + (<ghil-and> exps) + (<ghil-or> exps) + (<ghil-begin> exps) + (<ghil-bind> vars vals body) + (<ghil-mv-bind> producer vars rest body) + (<ghil-lambda> vars rest meta body) + (<ghil-call> proc args) + (<ghil-mv-call> producer consumer) + (<ghil-inline> inline args) + (<ghil-values> values) + (<ghil-values*> values) + (<ghil-reified-env>)) + + + +;;; +;;; Variables +;;; + +(define-record <ghil-var> env name kind (index #f)) + + +;;; +;;; Modules +;;; + + +;;; +;;; Environments +;;; + +(define-record <ghil-env> parent (table '()) (variables '())) +(define-record <ghil-toplevel-env> (table '())) + +(define (ghil-env-ref env sym) + (assq-ref (ghil-env-table env) sym)) + +(define-macro (push! item loc) + `(set! ,loc (cons ,item ,loc))) +(define-macro (apush! k v loc) + `(set! ,loc (acons ,k ,v ,loc))) +(define-macro (apopq! k loc) + `(set! ,loc (assq-remove! ,loc ,k))) + +(define (ghil-env-add! env var) + (apush! (ghil-var-name var) var (ghil-env-table env)) + (push! var (ghil-env-variables env))) + +(define (ghil-env-remove! env var) + (apopq! (ghil-var-name var) (ghil-env-table env))) + +(define (force-heap-allocation! var) + (set! (ghil-var-kind var) 'external)) + + + +;;; +;;; Public interface +;;; + +;; The following four functions used to be one, in ghil-lookup. Now they +;; are four, to reflect the different intents. A bit of duplication, but +;; that's OK. The common current is to find out where a variable will be +;; stored at runtime. +;; +;; These functions first search the lexical environments. If the +;; variable is not in the innermost environment, make sure the variable +;; is marked as being "external" so that it goes on the heap. If the +;; variable is being modified (via a set!), also make sure it's on the +;; heap, so that other continuations see the changes to the var. +;; +;; If the variable is not found lexically, it is a toplevel variable, +;; which will be looked up at runtime with respect to the module that +;; was current when the lambda was bound, at runtime. The variable will +;; be resolved when it is first used. +(define (ghil-var-is-bound? env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (assoc-ref table key))) + ((<ghil-env> parent table variables) + (and (not (assq-ref table sym)) + (loop parent)))))) + +(define (ghil-var-for-ref! env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (cond + ((assq-ref table sym) + => (lambda (var) + (or (eq? e env) + (force-heap-allocation! var)) + var)) + (else + (loop parent))))))) + +(define (ghil-var-for-set! env sym) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (cond + ((assq-ref table sym) + => (lambda (var) + (force-heap-allocation! var) + var)) + (else + (loop parent))))))) + +(define (ghil-var-at-module! env modname sym interface?) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (list modname sym interface?))) + (or (assoc-ref table key) + (let ((var (make-ghil-var modname sym + (if interface? 'public 'private)))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (loop parent))))) + +(define (ghil-var-define! toplevel sym) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref (ghil-toplevel-env-table toplevel) key) + (let ((var (make-ghil-var (car key) (cdr key) 'toplevel))) + (apush! key var (ghil-toplevel-env-table toplevel)) + var)))) + +(define (call-with-ghil-environment e syms func) + (let* ((e (make-ghil-env e)) + (vars (map (lambda (s) + (let ((v (make-ghil-var e s 'argument))) + (ghil-env-add! e v) v)) + syms))) + (func e vars))) + +(define (call-with-ghil-bindings e syms func) + (let* ((vars (map (lambda (s) + (let ((v (make-ghil-var e s 'local))) + (ghil-env-add! e v) v)) + syms)) + (ret (func vars))) + (for-each (lambda (v) (ghil-env-remove! e v)) vars) + ret)) + +(define (ghil-env-reify env) + (let loop ((e env) (out '())) + (record-case e + ((<ghil-toplevel-env> table) + (map (lambda (v) + (cons (ghil-var-name v) + (or (ghil-var-index v) + (error "reify called before indices finalized")))) + out)) + ((<ghil-env> parent table variables) + (loop parent + (append out + (filter (lambda (v) (eq? (ghil-var-kind v) 'external)) + variables))))))) + +(define (ghil-env-dereify name-index-alist) + (let* ((e (make-ghil-env (make-ghil-toplevel-env))) + (vars (map (lambda (pair) + (make-ghil-var e (car pair) 'external (cdr pair))) + name-index-alist))) + (set! (ghil-env-table e) + (map (lambda (v) (cons (ghil-var-name v) v)) vars)) + (set! (ghil-env-variables e) vars) + e)) + + +;;; +;;; Parser +;;; + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + (vector (assq-ref props 'line) + (assq-ref props 'column) + (assq-ref props 'filename)))))) + +(define (parse-quasiquote e x level) + (cond ((not (pair? x)) x) + ((memq (car x) '(unquote unquote-splicing)) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) + (cond + ((zero? level) + (if (eq? (car x) 'unquote) + (make-ghil-unquote e l (parse-ghil e obj)) + (make-ghil-unquote-splicing e l (parse-ghil e obj)))) + (else + (list (car x) (parse-quasiquote e obj (1- level)))))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + ((eq? (car x) 'quasiquote) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (parse-quasiquote e (car x) level) + (parse-quasiquote e (cdr x) level))))) + +(define (parse-ghil env exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-ghil env x)))) + (pmatch exp + ((ref ,sym) (guard (symbol? sym)) + (make-ghil-ref env #f (ghil-var-for-ref! env sym))) + + (('quote ,exp) (make-ghil-quote env loc exp)) + + ((void) (make-ghil-void env loc)) + + ((lambda ,syms ,rest ,meta . ,body) + (call-with-ghil-environment env syms + (lambda (env vars) + (make-ghil-lambda env loc vars rest meta + (parse-ghil env `(begin ,@body)))))) + + ((begin . ,body) + (make-ghil-begin env loc (map retrans body))) + + ((bind ,syms ,exprs . ,body) + (let ((vals (map retrans exprs))) + (call-with-ghil-bindings env syms + (lambda (vars) + (make-ghil-bind env loc vars vals (retrans `(begin ,@body))))))) + + ((bindrec ,syms ,exprs . ,body) + (call-with-ghil-bindings env syms + (lambda (vars) + (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs))) + (make-ghil-bind env loc vars vals (retrans `(begin ,@body))))))) + + ((set ,sym ,val) + (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val))) + + ((define ,sym ,val) + (make-ghil-define env loc (ghil-var-define! env sym) (retrans val))) + + ((if ,test ,then ,else) + (make-ghil-if env loc (retrans test) (retrans then) (retrans else))) + + ((and . ,exps) + (make-ghil-and env loc (map retrans exps))) + + ((or . ,exps) + (make-ghil-or env loc (map retrans exps))) + + ((mv-bind ,syms ,rest ,producer . ,body) + (call-with-ghil-bindings env syms + (lambda (vars) + (make-ghil-mv-bind env loc (retrans producer) vars rest + (map retrans body))))) + + ((call ,proc . ,args) + (make-ghil-call env loc (retrans proc) (map retrans args))) + + ((mv-call ,producer ,consumer) + (make-ghil-mv-call env loc (retrans producer) (retrans consumer))) + + ((inline ,op . ,args) + (make-ghil-inline env loc op (map retrans args))) + + ((values . ,values) + (make-ghil-values env loc (map retrans values))) + + ((values* . ,values) + (make-ghil-values* env loc (map retrans values))) + + ((compile-time-environment) + (make-ghil-reified-env env loc)) + + ((quasiquote ,exp) + (make-ghil-quasiquote env loc (parse-quasiquote env exp 0))) + + (else + (error "unrecognized GHIL" exp))))) + +(define (unparse-ghil ghil) + (record-case ghil + ((<ghil-void> env loc) + '(void)) + ((<ghil-quote> env loc obj) + `(,'quote ,obj)) + ((<ghil-quasiquote> env loc exp) + `(,'quasiquote ,(let lp ((x exp)) + (cond ((struct? x) (unparse-ghil x)) + ((pair? x) (cons (lp (car x)) (lp (cdr x)))) + (else x))))) + ((<ghil-unquote> env loc exp) + `(,'unquote ,(unparse-ghil exp))) + ((<ghil-unquote-splicing> env loc exp) + `(,'unquote-splicing ,(unparse-ghil exp))) + ;; Variables + ((<ghil-ref> env loc var) + `(ref ,(ghil-var-name var))) + ((<ghil-set> env loc var val) + `(set ,(ghil-var-name var) ,(unparse-ghil val))) + ((<ghil-define> env loc var val) + `(define ,(ghil-var-name var) ,(unparse-ghil val))) + ;; Controls + ((<ghil-if> env loc test then else) + `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else))) + ((<ghil-and> env loc exps) + `(and ,@(map unparse-ghil exps))) + ((<ghil-or> env loc exps) + `(or ,@(map unparse-ghil exps))) + ((<ghil-begin> env loc exps) + `(begin ,@(map unparse-ghil exps))) + ((<ghil-bind> env loc vars vals body) + `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals) + ,(unparse-ghil body))) + ((<ghil-mv-bind> env loc producer vars rest body) + `(mv-bind ,(map ghil-var-name vars) ,rest + ,(unparse-ghil producer) ,(unparse-ghil body))) + ((<ghil-lambda> env loc vars rest meta body) + `(lambda ,(map ghil-var-name vars) ,rest ,meta + ,(unparse-ghil body))) + ((<ghil-call> env loc proc args) + `(call ,(unparse-ghil proc) ,@(map unparse-ghil args))) + ((<ghil-mv-call> env loc producer consumer) + `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer))) + ((<ghil-inline> env loc inline args) + `(inline ,inline ,@(map unparse-ghil args))) + ((<ghil-values> env loc values) + `(values ,@(map unparse-ghil values))) + ((<ghil-values*> env loc values) + `(values* ,@(map unparse-ghil values))) + ((<ghil-reified-env> env loc) + `(compile-time-environment)))) diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm new file mode 100644 index 000000000..47e15c797 --- /dev/null +++ b/module/language/ghil/compile-glil.scm @@ -0,0 +1,592 @@ +;;; GHIL -> GLIL compiler + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ghil compile-glil) + #:use-module (system base syntax) + #:use-module (language glil) + #:use-module (language ghil) + #:use-module (ice-9 common-list) + #:export (compile-glil)) + +(define (compile-glil x e opts) + (if (memq #:O opts) (set! x (optimize x))) + (values (codegen x) + (and e (cons (car e) (cddr e))) + e)) + + +;;; +;;; Stage 2: Optimization +;;; + +(define (lift-variables! env) + (let ((parent-env (ghil-env-parent env))) + (for-each (lambda (v) + (case (ghil-var-kind v) + ((argument) (set! (ghil-var-kind v) 'local))) + (set! (ghil-var-env v) parent-env) + (ghil-env-add! parent-env v)) + (ghil-env-variables env)))) + +;; The premise of this, unused, approach to optimization is that you can +;; determine the environment of a variable lexically, because they have +;; been alpha-renamed. It makes the transformations *much* easier. +;; Unfortunately it doesn't work yet. +(define (optimize* x) + (transform-record (<ghil> env loc) x + ((quasiquote exp) + (define (optimize-qq x) + (cond ((list? x) (map optimize-qq x)) + ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x)))) + ((record? x) (optimize x)) + (else x))) + (-> (quasiquote (optimize-qq x)))) + + ((unquote exp) + (-> (unquote (optimize exp)))) + + ((unquote-splicing exp) + (-> (unquote-splicing (optimize exp)))) + + ((set var val) + (-> (set var (optimize val)))) + + ((define var val) + (-> (define var (optimize val)))) + + ((if test then else) + (-> (if (optimize test) (optimize then) (optimize else)))) + + ((and exps) + (-> (and (map optimize exps)))) + + ((or exps) + (-> (or (map optimize exps)))) + + ((begin exps) + (-> (begin (map optimize exps)))) + + ((bind vars vals body) + (-> (bind vars (map optimize vals) (optimize body)))) + + ((mv-bind producer vars rest body) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((inline inst args) + (-> (inline inst (map optimize args)))) + + ((call (proc (lambda vars (rest #f) meta body)) args) + (-> (bind vars (optimize args) (optimize body)))) + + ((call proc args) + (-> (call (optimize proc) (map optimize args)))) + + ((lambda vars rest meta body) + (-> (lambda vars rest meta (optimize body)))) + + ((mv-call producer (consumer (lambda vars rest meta body))) + (-> (mv-bind (optimize producer) vars rest (optimize body)))) + + ((mv-call producer consumer) + (-> (mv-call (optimize producer) (optimize consumer)))) + + ((values values) + (-> (values (map optimize values)))) + + ((values* values) + (-> (values* (map optimize values)))) + + (else + (error "unrecognized GHIL" x)))) + +(define (optimize x) + (record-case x + ((<ghil-set> env loc var val) + (make-ghil-set env var (optimize val))) + + ((<ghil-define> env loc var val) + (make-ghil-define env var (optimize val))) + + ((<ghil-if> env loc test then else) + (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) + + ((<ghil-and> env loc exps) + (make-ghil-and env loc (map optimize exps))) + + ((<ghil-or> env loc exps) + (make-ghil-or env loc (map optimize exps))) + + ((<ghil-begin> env loc exps) + (make-ghil-begin env loc (map optimize exps))) + + ((<ghil-bind> env loc vars vals body) + (make-ghil-bind env loc vars (map optimize vals) (optimize body))) + + ((<ghil-lambda> env loc vars rest meta body) + (make-ghil-lambda env loc vars rest meta (optimize body))) + + ((<ghil-inline> env loc instruction args) + (make-ghil-inline env loc instruction (map optimize args))) + + ((<ghil-call> env loc proc args) + (let ((parent-env env)) + (record-case proc + ;; ((@lambda (VAR...) BODY...) ARG...) => + ;; (@let ((VAR ARG) ...) BODY...) + ((<ghil-lambda> env loc vars rest meta body) + (cond + ((not rest) + (lift-variables! env) + (make-ghil-bind parent-env loc (map optimize args))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) + (else + (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) + + ((<ghil-mv-call> env loc producer consumer) + (record-case consumer + ;; (mv-call PRODUCER (lambda ARGS BODY...)) => + ;; (mv-let PRODUCER ARGS BODY...) + ((<ghil-lambda> env loc vars rest meta body) + (lift-variables! env) + (make-ghil-mv-bind producer vars rest body)) + (else + (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) + + (else x))) + + +;;; +;;; Stage 3: Code generation +;;; + +(define *ia-void* (make-glil-void)) +(define *ia-drop* (make-glil-call 'drop 1)) +(define *ia-return* (make-glil-call 'return 1)) + +(define (make-label) (gensym ":L")) + +(define (make-glil-var op env var) + (case (ghil-var-kind var) + ((argument) + (make-glil-local op (ghil-var-index var))) + ((local) + (make-glil-local op (ghil-var-index var))) + ((external) + (do ((depth 0 (1+ depth)) + (e env (ghil-env-parent e))) + ((eq? e (ghil-var-env var)) + (make-glil-external op depth (ghil-var-index var))))) + ((toplevel) + (make-glil-toplevel op (ghil-var-name var))) + ((public private) + (make-glil-module op (ghil-var-env var) (ghil-var-name var) + (eq? (ghil-var-kind var) 'public))) + (else (error "Unknown kind of variable:" var)))) + +(define (constant? x) + (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) + ((pair? x) (and (constant? (car x)) + (constant? (cdr x)))) + ((vector? x) (let lp ((i (vector-length x))) + (or (zero? i) + (and (constant? (vector-ref x (1- i))) + (lp (1- i)))))))) + +(define (codegen ghil) + (let ((stack '())) + (define (push-code! loc code) + (set! stack (cons code stack)) + (if loc (set! stack (cons (make-glil-source loc) stack)))) + (define (var->binding var) + (list (ghil-var-name var) (let ((kind (ghil-var-kind var))) + (case kind ((argument) 'local) (else kind))) + (ghil-var-index var))) + (define (push-bindings! loc vars) + (if (not (null? vars)) + (push-code! loc (make-glil-bind (map var->binding vars))))) + (define (comp tree tail drop) + (define (push-label! label) + (push-code! #f (make-glil-label label))) + (define (push-branch! loc inst label) + (push-code! loc (make-glil-branch inst label))) + (define (push-call! loc inst args) + (for-each comp-push args) + (push-code! loc (make-glil-call inst (length args)))) + ;; possible tail position + (define (comp-tail tree) (comp tree tail drop)) + ;; push the result + (define (comp-push tree) (comp tree #f #f)) + ;; drop the result + (define (comp-drop tree) (comp tree #f #t)) + ;; drop the result if unnecessary + (define (maybe-drop) + (if drop (push-code! #f *ia-drop*))) + ;; return here if necessary + (define (maybe-return) + (if tail (push-code! #f *ia-return*))) + ;; return this code if necessary + (define (return-code! loc code) + (if (not drop) (push-code! loc code)) + (maybe-return)) + ;; return void if necessary + (define (return-void!) + (return-code! #f *ia-void*)) + ;; return object if necessary + (define (return-object! loc obj) + (return-code! loc (make-glil-const obj))) + ;; + ;; dispatch + (record-case tree + ((<ghil-void>) + (return-void!)) + + ((<ghil-quote> env loc obj) + (return-object! loc obj)) + + ((<ghil-quasiquote> env loc exp) + (let loop ((x exp) (in-car? #f)) + (cond + ((list? x) + (push-call! #f 'mark '()) + (for-each (lambda (x) (loop x #t)) x) + (push-call! #f 'list-mark '())) + ((pair? x) + (push-call! #f 'mark '()) + (loop (car x) #t) + (loop (cdr x) #f) + (push-call! #f 'cons-mark '())) + ((record? x) + (record-case x + ((<ghil-unquote> env loc exp) + (comp-push exp)) + ((<ghil-unquote-splicing> env loc exp) + (if (not in-car?) + (error "unquote-splicing in the cdr of a pair" exp)) + (comp-push exp) + (push-call! #f 'list-break '())))) + ((constant? x) + (push-code! #f (make-glil-const x))) + (else + (error "element of quasiquote can't be compiled" x)))) + (maybe-drop) + (maybe-return)) + + ((<ghil-unquote> env loc exp) + (error "unquote outside of quasiquote" exp)) + + ((<ghil-unquote-splicing> env loc exp) + (error "unquote-splicing outside of quasiquote" exp)) + + ((<ghil-ref> env loc var) + (return-code! loc (make-glil-var 'ref env var))) + + ((<ghil-set> env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'set env var)) + (return-void!)) + + ((<ghil-define> env loc var val) + (comp-push val) + (push-code! loc (make-glil-var 'define env var)) + (return-void!)) + + ((<ghil-if> env loc test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (push-branch! loc 'br-if-not L1) + (comp-tail then) + (if (not tail) (push-branch! #f 'br L2)) + (push-label! L1) + (comp-tail else) + (if (not tail) (push-label! L2)))) + + ((<ghil-and> env loc exps) + ;; EXP + ;; (br-if-not L1) + ;; ... + ;; TAIL + ;; (br L2) + ;; L1: (const #f) + ;; L2: + (cond ((null? exps) (return-object! loc #t)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label)) (L2 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-branch! #f 'br L2) + (push-label! L1) + (return-object! #f #f) + (push-label! L2) + (maybe-return)) + (else + (comp-push (car exps)) + (push-branch! #f 'br-if-not L1) + (lp (cdr exps))))))))) + + ((<ghil-or> env loc exps) + ;; EXP + ;; (dup) + ;; (br-if L1) + ;; (drop) + ;; ... + ;; TAIL + ;; L1: + (cond ((null? exps) (return-object! loc #f)) + ((null? (cdr exps)) (comp-tail (car exps))) + (else + (let ((L1 (make-label))) + (let lp ((exps exps)) + (cond ((null? (cdr exps)) + (comp-tail (car exps)) + (push-label! L1) + (maybe-return)) + (else + (comp-push (car exps)) + (if (not drop) + (push-call! #f 'dup '())) + (push-branch! #f 'br-if L1) + (if (not drop) + (push-code! loc (make-glil-call 'drop 1))) + (lp (cdr exps))))))))) + + ((<ghil-begin> env loc exps) + ;; EXPS... + ;; TAIL + (if (null? exps) + (return-void!) + (do ((exps exps (cdr exps))) + ((null? (cdr exps)) + (comp-tail (car exps))) + (comp-drop (car exps))))) + + ((<ghil-bind> env loc vars vals body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (for-each comp-push vals) + (push-bindings! loc vars) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars)) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + ((<ghil-mv-bind> env loc producer vars rest body) + ;; VALS... + ;; (set VARS)... + ;; BODY + (let ((MV (make-label))) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! #f (make-glil-const 1)) + (push-label! MV) + (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) + (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) + (reverse vars))) + (comp-tail body) + (push-code! #f (make-glil-unbind))) + + ((<ghil-lambda> env loc vars rest meta body) + (return-code! loc (codegen tree))) + + ((<ghil-inline> env loc inline args) + ;; ARGS... + ;; (INST NARGS) + (let ((tail-table '((call . goto/args) + (apply . goto/apply) + (call/cc . goto/cc)))) + (cond ((and tail (assq-ref tail-table inline)) + => (lambda (tail-inst) + (push-call! loc tail-inst args))) + (else + (push-call! loc inline args) + (maybe-drop) + (maybe-return))))) + + ((<ghil-values> env loc values) + (cond (tail ;; (lambda () (values 1 2)) + (push-call! loc 'return/values values)) + (drop ;; (lambda () (values 1 2) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (values 10 12) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'call values)))) + + ((<ghil-values*> env loc values) + (cond (tail ;; (lambda () (apply values '(1 2))) + (push-call! loc 'return/values* values)) + (drop ;; (lambda () (apply values '(1 2)) 3) + (for-each comp-drop values)) + (else ;; (lambda () (list (apply values '(10 12)) 1)) + (push-code! #f (make-glil-const 'values)) + (push-code! #f (make-glil-call 'link-now 1)) + (push-code! #f (make-glil-call 'variable-ref 0)) + (push-call! loc 'apply values)))) + + ((<ghil-call> env loc proc args) + ;; PROC + ;; ARGS... + ;; ([tail-]call NARGS) + (comp-push proc) + (let ((nargs (length args))) + (cond ((< nargs 255) + (push-call! loc (if tail 'goto/args 'call) args)) + (else + (push-call! loc 'mark '()) + (for-each comp-push args) + (push-call! loc 'list-mark '()) + (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2))))) + (maybe-drop)) + + ((<ghil-mv-call> env loc producer consumer) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label))) + (comp-push consumer) + (comp-push producer) + (push-code! loc (make-glil-mv-call 0 MV)) + (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) + (cond ((not tail) + (push-branch! #f 'br POST))) + (push-label! MV) + (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) + (cond ((not tail) + (push-label! POST) + (maybe-drop))))) + + ((<ghil-reified-env> env loc) + (return-object! loc (ghil-env-reify env))))) + + ;; + ;; main + (record-case ghil + ((<ghil-lambda> env loc vars rest meta body) + (let* ((evars (ghil-env-variables env)) + (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) + (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) + (nargs (allocate-indices-linearly! vars)) + (nlocs (allocate-locals! locs body nargs)) + (nexts (allocate-indices-linearly! exts))) + ;; meta bindings + (push-bindings! #f vars) + ;; push on definition source location + (if loc (set! stack (cons (make-glil-source loc) stack))) + ;; copy args to the heap if they're marked as external + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l)) + (let ((v (car l))) + (case (ghil-var-kind v) + ((external) + (push-code! #f (make-glil-local 'ref n)) + (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) + ;; compile body + (comp body #t #f) + ;; create GLIL + (make-glil-program nargs (if rest 1 0) nlocs nexts meta + (reverse! stack))))))) + +(define (allocate-indices-linearly! vars) + (do ((n 0 (1+ n)) + (l vars (cdr l))) + ((null? l) n) + (let ((v (car l))) (set! (ghil-var-index v) n)))) + +(define (allocate-locals! vars body nargs) + (let ((free '()) (nlocs nargs)) + (define (allocate! var) + (cond + ((pair? free) + (set! (ghil-var-index var) (car free)) + (set! free (cdr free))) + (else + (set! (ghil-var-index var) nlocs) + (set! nlocs (1+ nlocs))))) + (define (deallocate! var) + (set! free (cons (ghil-var-index var) free))) + (let lp ((x body)) + (record-case x + ((<ghil-void>)) + ((<ghil-quote>)) + ((<ghil-quasiquote> exp) + (let qlp ((x exp)) + (cond ((list? x) (for-each qlp x)) + ((pair? x) (qlp (car x)) (qlp (cdr x))) + ((record? x) + (record-case x + ((<ghil-unquote> exp) (lp exp)) + ((<ghil-unquote-splicing> exp) (lp exp))))))) + ((<ghil-unquote> exp) + (lp exp)) + ((<ghil-unquote-splicing> exp) + (lp exp)) + ((<ghil-reified-env>)) + ((<ghil-set> val) + (lp val)) + ((<ghil-ref>)) + ((<ghil-define> val) + (lp val)) + ((<ghil-if> test then else) + (lp test) (lp then) (lp else)) + ((<ghil-and> exps) + (for-each lp exps)) + ((<ghil-or> exps) + (for-each lp exps)) + ((<ghil-begin> exps) + (for-each lp exps)) + ((<ghil-bind> vars vals body) + (for-each allocate! vars) + (for-each lp vals) + (lp body) + (for-each deallocate! vars)) + ((<ghil-mv-bind> vars producer body) + (lp producer) + (for-each allocate! vars) + (lp body) + (for-each deallocate! vars)) + ((<ghil-inline> args) + (for-each lp args)) + ((<ghil-call> proc args) + (lp proc) + (for-each lp args)) + ((<ghil-lambda>)) + ((<ghil-mv-call> producer consumer) + (lp producer) + (lp consumer)) + ((<ghil-values> values) + (for-each lp values)) + ((<ghil-values*> values) + (for-each lp values)))) + nlocs)) diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm new file mode 100644 index 000000000..f2bc19b61 --- /dev/null +++ b/module/language/ghil/spec.scm @@ -0,0 +1,62 @@ +;;; Guile High Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language ghil spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language ghil) + #:use-module (language ghil compile-glil) + #:export (ghil)) + +(define (write-ghil exp . port) + (apply write (unparse-ghil exp) port)) + +(define (parse x) + (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '() + (lambda (env vars) + (make-ghil-lambda env #f vars #f '() (parse-ghil env x))))) + +(define (join exps env) + (if (or-map (lambda (x) + (or (not (ghil-lambda? x)) + (ghil-lambda-rest x) + (memq 'argument + (map ghil-var-kind + (ghil-env-variables (ghil-lambda-env x)))))) + exps) + (error "GHIL expressions to join must be thunks")) + + (let ((env (make-ghil-env env '() + (apply append + (map ghil-env-variables + (map ghil-lambda-env exps)))))) + (make-ghil-lambda env #f '() #f '() + (make-ghil-begin env #f + (map ghil-lambda-body exps))))) + +(define-language ghil + #:title "Guile High Intermediate Language (GHIL)" + #:version "0.3" + #:reader read + #:printer write-ghil + #:parser parse + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) diff --git a/module/language/glil.scm b/module/language/glil.scm new file mode 100644 index 000000000..0777073f6 --- /dev/null +++ b/module/language/glil.scm @@ -0,0 +1,137 @@ +;;; Guile Low Intermediate Language + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language glil) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module ((srfi srfi-1) #:select (fold)) + #:export + (<glil-program> make-glil-program glil-program? + glil-program-nargs glil-program-nrest glil-program-nlocs + glil-program-meta glil-program-body + + <glil-bind> make-glil-bind glil-bind? + glil-bind-vars + + <glil-mv-bind> make-glil-mv-bind glil-mv-bind? + glil-mv-bind-vars glil-mv-bind-rest + + <glil-unbind> make-glil-unbind glil-unbind? + + <glil-source> make-glil-source glil-source? + glil-source-props + + <glil-void> make-glil-void glil-void? + + <glil-const> make-glil-const glil-const? + glil-const-obj + + <glil-lexical> make-glil-lexical glil-lexical? + glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index + + <glil-toplevel> make-glil-toplevel glil-toplevel? + glil-toplevel-op glil-toplevel-name + + <glil-module> make-glil-module glil-module? + glil-module-op glil-module-mod glil-module-name glil-module-public? + + <glil-label> make-glil-label glil-label? + glil-label-label + + <glil-branch> make-glil-branch glil-branch? + glil-branch-inst glil-branch-label + + <glil-call> make-glil-call glil-call? + glil-call-inst glil-call-nargs + + <glil-mv-call> make-glil-mv-call glil-mv-call? + glil-mv-call-nargs glil-mv-call-ra + + parse-glil unparse-glil)) + +(define (print-glil x port) + (format port "#<glil ~s>" (unparse-glil x))) + +(define-type (<glil> #:printer print-glil) + ;; Meta operations + (<glil-program> nargs nrest nlocs meta body) + (<glil-bind> vars) + (<glil-mv-bind> vars rest) + (<glil-unbind>) + (<glil-source> props) + ;; Objects + (<glil-void>) + (<glil-const> obj) + ;; Variables + (<glil-lexical> local? boxed? op index) + (<glil-toplevel> op name) + (<glil-module> op mod name public?) + ;; Controls + (<glil-label> label) + (<glil-branch> inst label) + (<glil-call> inst nargs) + (<glil-mv-call> nargs ra)) + + + +(define (parse-glil x) + (pmatch x + ((program ,nargs ,nrest ,nlocs ,meta . ,body) + (make-glil-program nargs nrest nlocs meta (map parse-glil body))) + ((bind . ,vars) (make-glil-bind vars)) + ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) + ((unbind) (make-glil-unbind)) + ((source ,props) (make-glil-source props)) + ((void) (make-glil-void)) + ((const ,obj) (make-glil-const obj)) + ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index)) + ((toplevel ,op ,name) (make-glil-toplevel op name)) + ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) + ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) + ((label ,label) (make-label label)) + ((branch ,inst ,label) (make-glil-branch inst label)) + ((call ,inst ,nargs) (make-glil-call inst nargs)) + ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) + (else (error "invalid glil" x)))) + +(define (unparse-glil glil) + (record-case glil + ;; meta + ((<glil-program> nargs nrest nlocs meta body) + `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) + ((<glil-bind> vars) `(bind ,@vars)) + ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest)) + ((<glil-unbind>) `(unbind)) + ((<glil-source> props) `(source ,props)) + ;; constants + ((<glil-void>) `(void)) + ((<glil-const> obj) `(const ,obj)) + ;; variables + ((<glil-lexical> local? boxed? op index) + `(lexical ,local? ,boxed? ,op ,index)) + ((<glil-toplevel> op name) + `(toplevel ,op ,name)) + ((<glil-module> op mod name public?) + `(module ,(if public? 'public 'private) ,op ,mod ,name)) + ;; controls + ((<glil-label> label) `(label ,label)) + ((<glil-branch> inst label) `(branch ,inst ,label)) + ((<glil-call> inst nargs) `(call ,inst ,nargs)) + ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra)))) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm new file mode 100644 index 000000000..121d9db9f --- /dev/null +++ b/module/language/glil/compile-assembly.scm @@ -0,0 +1,446 @@ +;;; Guile VM assembler + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language glil compile-assembly) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (language glil) + #:use-module (language assembly) + #:use-module (system vm instruction) + #:use-module ((system vm program) #:select (make-binding)) + #:use-module (ice-9 receive) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (rnrs bytevector) + #:export (compile-assembly)) + +;; Variable cache cells go in the object table, and serialize as their +;; keys. The reason we wrap the keys in these records is so they don't +;; compare as `equal?' to other objects in the object table. +;; +;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?) + +(define-record <variable-cache-cell> key) + +;; Subprograms can be loaded into an object table as well. We need a +;; disjoint type here too. (Subprograms have their own object tables -- +;; though probably we should just make one table per compilation unit.) + +(define-record <subprogram> table prog) + + +(define (limn-sources sources) + (let lp ((in sources) (out '()) (filename #f)) + (if (null? in) + (reverse! out) + (let ((addr (caar in)) + (new-filename (assq-ref (cdar in ) 'filename)) + (line (assq-ref (cdar in) 'line)) + (column (assq-ref (cdar in) 'column))) + (cond + ((not (equal? new-filename filename)) + (lp (cdr in) + `((,addr . (,line . ,column)) + (filename . ,new-filename) + . ,out) + new-filename)) + ((or (null? out) (not (equal? (cdar out) `(,line . ,column)))) + (lp (cdr in) + `((,addr . (,line . ,column)) + . ,out) + filename)) + (else + (lp (cdr in) out filename))))))) + +(define (make-meta bindings sources tail) + (if (and (null? bindings) (null? sources) (null? tail)) + #f + (compile-assembly + (make-glil-program 0 0 0 '() + (list + (make-glil-const `(,bindings ,sources ,@tail)) + (make-glil-call 'return 1)))))) + +;; A functional stack of names of live variables. +(define (make-open-binding name boxed? index) + (list name boxed? index)) +(define (make-closed-binding open-binding start end) + (make-binding (car open-binding) (cadr open-binding) + (caddr open-binding) start end)) +(define (open-binding bindings vars start) + (cons + (acons start + (map + (lambda (v) + (pmatch v + ((,name ,boxed? ,i) + (make-open-binding name boxed? i)) + (else (error "unknown binding type" v)))) + vars) + (car bindings)) + (cdr bindings))) +(define (close-binding bindings end) + (pmatch bindings + ((((,start . ,closing) . ,open) . ,closed) + (cons open + (fold (lambda (o tail) + ;; the cons is for dsu sort + (acons start (make-closed-binding o start end) + tail)) + closed + closing))) + (else (error "broken bindings" bindings)))) +(define (close-all-bindings bindings end) + (if (null? (car bindings)) + (map cdr + (stable-sort (reverse (cdr bindings)) + (lambda (x y) (< (car x) (car y))))) + (close-all-bindings (close-binding bindings end) end))) + +;; A functional object table. +(define *module* 1) +(define (assoc-ref-or-acons alist x make-y) + (cond ((assoc-ref alist x) + => (lambda (y) (values y alist))) + (else + (let ((y (make-y x alist))) + (values y (acons x y alist)))))) +(define (object-index-and-alist x alist) + (assoc-ref-or-acons alist x + (lambda (x alist) + (+ (length alist) *module*)))) + +(define (compile-assembly glil) + (receive (code . _) + (glil->assembly glil #t '(()) '() '() #f -1) + (car code))) +(define (make-object-table objects) + (and (not (null? objects)) + (list->vector (cons #f objects)))) + +(define (glil->assembly glil toplevel? bindings + source-alist label-alist object-alist addr) + (define (emit-code x) + (values x bindings source-alist label-alist object-alist)) + (define (emit-code/object x object-alist) + (values x bindings source-alist label-alist object-alist)) + + (record-case glil + ((<glil-program> nargs nrest nlocs meta body) + (define (process-body) + (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) + (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) + (cond + ((null? body) + (values (reverse code) + (close-all-bindings bindings addr) + (limn-sources (reverse! source-alist)) + (reverse label-alist) + (and object-alist (map car (reverse object-alist))) + addr)) + (else + (receive (subcode bindings source-alist label-alist object-alist) + (glil->assembly (car body) #f bindings + source-alist label-alist object-alist addr) + (lp (cdr body) (append (reverse subcode) code) + bindings source-alist label-alist object-alist + (addr+ addr subcode))))))) + + (receive (code bindings sources labels objects len) + (process-body) + (let* ((meta (make-meta bindings sources meta)) + (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)) + (prog `(load-program ,nargs ,nrest ,nlocs ,labels + ,(+ len meta-pad) + ,meta + ,@code + ,@(if meta + (make-list meta-pad '(nop)) + '())))) + (cond + (toplevel? + ;; toplevel bytecode isn't loaded by the vm, no way to do + ;; object table or closure capture (not in the bytecode, + ;; anyway) + (emit-code (align-program prog addr))) + (else + (let ((table (make-object-table objects))) + (cond + (object-alist + ;; if we are being compiled from something with an object + ;; table, cache the program there + (receive (i object-alist) + (object-index-and-alist (make-subprogram table prog) + object-alist) + (emit-code/object `(,(if (< i 256) + `(object-ref ,i) + `(long-object-ref ,(quotient i 256) + ,(modulo i 256)))) + object-alist))) + (else + ;; otherwise emit a load directly + (let ((table-code (dump-object table addr))) + (emit-code + `(,@table-code + ,@(align-program prog (addr+ addr table-code))))))))))))) + + ((<glil-bind> vars) + (values '() + (open-binding bindings vars addr) + source-alist + label-alist + object-alist)) + + ((<glil-mv-bind> vars rest) + (values `((truncate-values ,(length vars) ,(if rest 1 0))) + (open-binding bindings vars addr) + source-alist + label-alist + object-alist)) + + ((<glil-unbind>) + (values '() + (close-binding bindings addr) + source-alist + label-alist + object-alist)) + + ((<glil-source> props) + (values '() + bindings + (acons addr props source-alist) + label-alist + object-alist)) + + ((<glil-void>) + (emit-code '((void)))) + + ((<glil-const> obj) + (cond + ((object->assembly obj) + => (lambda (code) + (emit-code (list code)))) + ((not object-alist) + (emit-code (dump-object obj addr))) + (else + (receive (i object-alist) + (object-index-and-alist obj object-alist) + (emit-code/object (if (< i 256) + `((object-ref ,i)) + `((long-object-ref ,(quotient i 256) + ,(modulo i 256)))) + object-alist))))) + + ((<glil-lexical> local? boxed? op index) + (emit-code + (if local? + (if (< index 256) + (case op + ((ref) (if boxed? + `((local-boxed-ref ,index)) + `((local-ref ,index)))) + ((set) (if boxed? + `((local-boxed-set ,index)) + `((local-set ,index)))) + ((box) `((box ,index))) + ((empty-box) `((empty-box ,index))) + ((fix) `((fix-closure 0 ,index))) + (else (error "what" op))) + (let ((a (quotient i 256)) + (b (modulo i 256))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + ((fix) + `((fix-closure ,a ,b))) + (else (error "what" op))) + ,index)))) + `((,(case op + ((ref) (if boxed? 'free-boxed-ref 'free-ref)) + ((set) (if boxed? 'free-boxed-set (error "what." glil))) + (else (error "what" op))) + ,index))))) + + ((<glil-toplevel> op name) + (case op + ((ref set) + (cond + ((not object-alist) + (emit-code `(,@(dump-object name addr) + (link-now) + ,(case op + ((ref) '(variable-ref)) + ((set) '(variable-set)))))) + (else + (receive (i object-alist) + (object-index-and-alist (make-variable-cache-cell name) + object-alist) + (emit-code/object (if (< i 256) + `((,(case op + ((ref) 'toplevel-ref) + ((set) 'toplevel-set)) + ,i)) + `((,(case op + ((ref) 'long-toplevel-ref) + ((set) 'long-toplevel-set)) + ,(quotient i 256) + ,(modulo i 256)))) + object-alist))))) + ((define) + (emit-code `(,@(dump-object name addr) + (define)))) + (else + (error "unknown toplevel var kind" op name)))) + + ((<glil-module> op mod name public?) + (let ((key (list mod name public?))) + (case op + ((ref set) + (cond + ((not object-alist) + (emit-code `(,@(dump-object key addr) + (link-now) + ,(case op + ((ref) '(variable-ref)) + ((set) '(variable-set)))))) + (else + (receive (i object-alist) + (object-index-and-alist (make-variable-cache-cell key) + object-alist) + (emit-code/object (case op + ((ref) `((toplevel-ref ,i))) + ((set) `((toplevel-set ,i)))) + object-alist))))) + (else + (error "unknown module var kind" op key))))) + + ((<glil-label> label) + (let ((code (align-block addr))) + (values code + bindings + source-alist + (acons label (addr+ addr code) label-alist) + object-alist))) + + ((<glil-branch> inst label) + (emit-code `((,inst ,label)))) + + ;; nargs is number of stack args to insn. probably should rename. + ((<glil-call> inst nargs) + (if (not (instruction? inst)) + (error "Unknown instruction:" inst)) + (let ((pops (instruction-pops inst))) + (cond ((< pops 0) + (case (instruction-length inst) + ((1) (emit-code `((,inst ,nargs)))) + ((2) (emit-code `((,inst ,(quotient nargs 256) + ,(modulo nargs 256))))) + (else (error "Unknown length for variable-arg instruction:" + inst (instruction-length inst))))) + ((= pops nargs) + (emit-code `((,inst)))) + (else + (error "Wrong number of stack arguments to instruction:" inst nargs))))) + + ((<glil-mv-call> nargs ra) + (emit-code `((mv-call ,nargs ,ra)))))) + +(define (dump-object x addr) + (define (too-long x) + (error (string-append x " too long"))) + + (cond + ((object->assembly x) => list) + ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr)) + ((subprogram? x) + (let ((table-code (dump-object (subprogram-table x) addr))) + `(,@table-code + ,@(align-program (subprogram-prog x) + (addr+ addr table-code))))) + ((number? x) + `((load-number ,(number->string x)))) + ((string? x) + (case (string-bytes-per-char x) + ((1) `((load-string ,x))) + ((4) (align-code `(load-wide-string ,x) addr 4 4)) + (else (error "bad string bytes per char" x)))) + ((symbol? x) + (let ((str (symbol->string x))) + (case (string-bytes-per-char str) + ((1) `((load-symbol ,str))) + ((4) `(,@(dump-object str addr) + (make-symbol))) + (else (error "bad string bytes per char" str))))) + ((keyword? x) + `(,@(dump-object (keyword->symbol x) addr) + (make-keyword))) + ((list? x) + (let ((tail (let ((len (length x))) + (if (>= len 65536) (too-long "list")) + `((list ,(quotient len 256) ,(modulo len 256)))))) + (let dump-objects ((objects x) (codes '()) (addr addr)) + (if (null? objects) + (fold append tail codes) + (let ((code (dump-object (car objects) addr))) + (dump-objects (cdr objects) (cons code codes) + (addr+ addr code))))))) + ((pair? x) + (let ((kar (dump-object (car x) addr))) + `(,@kar + ,@(dump-object (cdr x) (addr+ addr kar)) + (cons)))) + ((vector? x) + (let* ((len (vector-length x)) + (tail (if (>= len 65536) + (too-long "vector") + `((vector ,(quotient len 256) ,(modulo len 256)))))) + (let dump-objects ((i 0) (codes '()) (addr addr)) + (if (>= i len) + (fold append tail codes) + (let ((code (dump-object (vector-ref x i) addr))) + (dump-objects (1+ i) (cons code codes) + (addr+ addr code))))))) + ((and (array? x) (symbol? (array-type x))) + (let* ((type (dump-object (array-type x) addr)) + (shape (dump-object (array-shape x) (addr+ addr type)))) + `(,@type + ,@shape + ,@(align-code + `(load-array ,(uniform-array->bytevector x)) + (addr+ (addr+ addr type) shape) + 8 + 4)))) + (else + (error "assemble: unrecognized object" x)))) + diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm new file mode 100644 index 000000000..3cb887d44 --- /dev/null +++ b/module/language/glil/decompile-assembly.scm @@ -0,0 +1,190 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language glil decompile-assembly) + #:use-module (system base pmatch) + #:use-module (system vm program) + #:use-module (language assembly) + #:use-module (language glil) + #:export (decompile-assembly)) + +(define (decompile-assembly x env opts) + (values (decompile-toplevel x) + env)) + +(define (decompile-toplevel x) + (pmatch x + ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body) + (decompile-load-program nargs nrest nlocs + (decompile-meta meta) + body labels #f)) + (else + (error "invalid assembly" x)))) + +(define (decompile-meta meta) + (and meta + (let ((prog (decompile-toplevel meta))) + (if (and (glil-program? prog) + (= (length (glil-program-body prog)) 2) + (glil-const? (car (glil-program-body prog)))) + (glil-const-obj (car (glil-program-body prog))) + (error "metadata not a thunk returning a const" prog))))) + +(define *placeholder* (list 'placeholder)) + +(define (emit-constants l out) + (let lp ((in (reverse l)) (out out)) + (cond ((null? in) out) + ((eq? (car in) *placeholder*) (lp (cdr in) out)) + ((glil-program? (car in)) (lp (cdr in) (cons (car in) out))) + (else (lp (cdr in) (cons (make-glil-const (car l)) out)))))) + +(define (decompile-load-program nargs nrest nlocs meta body labels + objects) + (let ((glil-labels (sort (map (lambda (x) + (cons (cdr x) (make-glil-label (car x)))) + labels) + (lambda (x y) (< (car x) (car y))))) + (bindings (sort (if meta (car meta) '()) + (lambda (x y) (< (binding:start x) (binding:start y))))) + (unbindings (sort (if meta (car meta) '()) + (lambda (x y) (< (binding:end x) (binding:end y))))) + (sources (if meta (cadr meta) '())) + (filename #f) + (props (if meta (cddr meta) '()))) + (define (pop-bindings! addr) + (let lp ((in bindings) (out '())) + (if (or (null? in) (> (binding:start (car in)) addr)) + (begin + (set! bindings in) + (if (null? out) #f (reverse out))) + (lp (cdr in) (cons (car in) out))))) + (define (pop-unbindings! addr) + (let lp ((in unbindings) (out '())) + (if (or (null? in) (> (binding:end (car in)) addr)) + (begin + (set! unbindings in) + (if (null? out) #f (reverse out))) + (lp (cdr in) (cons (car in) out))))) + (define (pop-source! addr) + ;; a fragile algorithm. + (cond ((null? sources) #f) + ((eq? (caar sources) 'filename) + (set! filename (cdar sources)) + (pop-source! addr)) + ((eqv? (caar sources) addr) + (let ((x (car sources))) + (set! sources (cdr sources)) + `((filename . ,filename) + (line . ,(cadr x)) + (column . ,(cddr x))))) + (else #f))) + (let lp ((in body) (stack '()) (out '()) (pos 0)) + (cond + ((null? in) + (or (null? stack) (error "leftover stack insts" stack body)) + (make-glil-program nargs nrest nlocs props (reverse out) #f)) + ((pop-bindings! pos) + => (lambda (bindings) + (lp in stack + (cons (make-glil-bind bindings) + out) + pos))) + ((pop-unbindings! pos) + => (lambda (bindings) + (lp in stack (cons (make-glil-unbind) out) pos))) + ((pop-source! pos) + => (lambda (s) + (lp in stack (cons (make-glil-source s) out) pos))) + ((and (or (null? out) (not (glil-label? (car out)))) + (assv-ref glil-labels pos)) + => (lambda (label) + (lp in stack (cons label out) pos))) + (else + (pmatch (car in) + ((nop) + (lp (cdr in) stack out (1+ pos))) + ((make-false) + (lp (cdr in) (cons #f stack) out (1+ pos))) + ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body) + (lp (cdr in) + (cons (decompile-load-program a b c d (decompile-meta meta) + body labels (car stack)) + (cdr stack)) + out + (+ pos (byte-length (car in))))) + ((load-symbol ,str) + (lp (cdr in) (cons (string->symbol str) stack) out + (+ pos 1 (string-length str)))) + ((make-int8:0) + (lp (cdr in) (cons 0 stack) out (1+ pos))) + ((make-int8:1) + (lp (cdr in) (cons 1 stack) out (1+ pos))) + ((make-int8 ,n) + (lp (cdr in) (cons n stack) out (+ pos 2))) + ((cons) + (let ((head (list-head stack 2)) + (stack (list-tail stack 2))) + (if (memq *placeholder* head) + (lp (cdr in) (cons *placeholder* stack) + (cons (make-glil-call 'cons 2) (emit-constants head out)) + (+ pos 1)) + (lp (cdr in) (cons (cons (cadr head) (car head)) stack) + out (+ pos 3))))) + ((list ,a ,b) + (let* ((len (+ (ash a 8) b)) + (head (list-head stack len)) + (stack (list-tail stack len))) + (if (memq *placeholder* head) + (lp (cdr in) (cons *placeholder* stack) + (cons (make-glil-call 'list len) (emit-constants head out)) + (+ pos 3)) + (lp (cdr in) (cons (reverse head) stack) out (+ pos 3))))) + ((make-eol) + (lp (cdr in) (cons '() stack) out (1+ pos))) + ((return) + (lp (cdr in) (cdr stack) + (cons (make-glil-call 'return 1) + (emit-constants (list-head stack 1) out)) + (1+ pos))) + ((local-ref ,n) + (lp (cdr in) (cons *placeholder* stack) + (cons (make-glil-local 'ref n) + out) (+ pos 2))) + ((local-set ,n) + (lp (cdr in) (cdr stack) + (cons (make-glil-local 'set n) + (emit-constants (list-head stack 1) out)) + (+ pos 2))) + ((br-if-not ,l) + (lp (cdr in) (cdr stack) + (cons (make-glil-branch 'br-if-not l) out) + (+ pos 3))) + ((mul) + (lp (cdr in) (cons *placeholder* (cddr stack)) + (cons (make-glil-call 'mul 2) + (emit-constants (list-head stack 2) out)) + (+ pos 1))) + ((goto/args ,n) + (lp (cdr in) (list-tail stack (1+ n)) + (cons (make-glil-call 'goto/args n) + (emit-constants (list-head stack (1+ n)) out)) + (+ pos 2))) + (else (error "unsupported decompilation" (car in))))))))) diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm new file mode 100644 index 000000000..d5291a211 --- /dev/null +++ b/module/language/glil/spec.scm @@ -0,0 +1,41 @@ +;;; Guile Lowlevel Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language glil spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language glil compile-assembly) + #:use-module (language glil decompile-assembly) + #:export (glil)) + +(define (write-glil exp . port) + (apply write (unparse-glil exp) port)) + +(define (compile-asm x e opts) + (values (compile-assembly x) e e)) + +(define-language glil + #:title "Guile Lowlevel Intermediate Language (GLIL)" + #:version "0.3" + #:reader read + #:printer write-glil + #:parser parse-glil + #:compilers `((assembly . ,compile-asm)) + #:decompilers `((assembly . ,decompile-assembly))) diff --git a/module/language/objcode.scm b/module/language/objcode.scm new file mode 100644 index 000000000..d8bcda879 --- /dev/null +++ b/module/language/objcode.scm @@ -0,0 +1,51 @@ +;;; Guile Virtual Machine Object Code + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language objcode) + #:export (encode-length decode-length)) + + +;;; +;;; Variable-length interface +;;; + +;; NOTE: decoded in vm_fetch_length in vm.c as well. + +(define (encode-length len) + (cond ((< len 254) (u8vector len)) + ((< len (* 256 256)) + (u8vector 254 (quotient len 256) (modulo len 256))) + ((< len most-positive-fixnum) + (u8vector 255 + (quotient len (* 256 256 256)) + (modulo (quotient len (* 256 256)) 256) + (modulo (quotient len 256) 256) + (modulo len 256))) + (else (error "Too long code length:" len)))) + +(define (decode-length pop) + (let ((x (pop))) + (cond ((< x 254) x) + ((= x 254) (+ (ash x 8) (pop))) + (else + (let* ((b2 (pop)) + (b3 (pop)) + (b4 (pop))) + (+ (ash x 24) (ash b2 16) (ash b3 8) b4)))))) diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm new file mode 100644 index 000000000..4cb600f1d --- /dev/null +++ b/module/language/objcode/spec.scm @@ -0,0 +1,92 @@ +;;; Guile Lowlevel Intermediate Language + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language objcode spec) + #:use-module (system base language) + #:use-module (system vm objcode) + #:use-module (system vm program) + #:export (objcode make-objcode-env)) + +(define (make-objcode-env module externals) + (cons module externals)) + +(define (objcode-env-module env) + (if env (car env) (current-module))) + +(define (objcode-env-externals env) + (and env (vector? (cdr env)) (cdr env))) + +(define (objcode->value x e opts) + (let ((thunk (make-program x #f (objcode-env-externals e)))) + (if e + (save-module-excursion + (lambda () + (set-current-module (objcode-env-module e)) + (values (thunk) #f e))) + (values (thunk) #f e)))) + +;; since locals are allocated on the stack and can have limited scope, +;; in many cases we use one local for more than one lexical variable. so +;; the returned locals set is a list, where element N of the list is +;; itself a list of bindings for local variable N. +(define (collapse-locals locs) + (let lp ((ret '()) (locs locs)) + (if (null? locs) + (map cdr (sort! ret + (lambda (x y) (< (car x) (car y))))) + (let ((b (car locs))) + (cond + ((assv-ref ret (binding:index b)) + => (lambda (bindings) + (append! bindings (list b)) + (lp ret (cdr locs)))) + (else + (lp (acons (binding:index b) (list b) ret) + (cdr locs)))))))) + +(define (decompile-value x env opts) + (cond + ((program? x) + (let ((objs (program-objects x)) + (meta (program-meta x)) + (free-vars (program-free-variables x)) + (binds (program-bindings x)) + (srcs (program-sources x)) + (nargs (arity:nargs (program-arity x)))) + (let ((blocs (and binds (collapse-locals binds)))) + (values (program-objcode x) + `((objects . ,objs) + (meta . ,(and meta (meta))) + (free-vars . ,free-vars) + (blocs . ,blocs) + (sources . ,srcs)))))) + ((objcode? x) + (values x #f)) + (else + (error "can't decompile ~A: not a program or objcode" x)))) + +(define-language objcode + #:title "Guile Object Code" + #:version "0.3" + #:reader #f + #:printer write-objcode + #:compilers `((value . ,objcode->value)) + #:decompilers `((value . ,decompile-value)) + ) diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il new file mode 100644 index 000000000..c614a6fe2 --- /dev/null +++ b/module/language/r5rs/core.il @@ -0,0 +1,324 @@ +;;; R5RS core environment + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +;; Non standard procedures + +(@define void (@lambda () (@void))) + +;; 6. Standard procedures + +;;; 6.1 Equivalence predicates + +(@define eq? (@lambda (x y) (@eq? x y))) +(@define eqv? (@ Core::eqv?)) +(@define equal? (@ Core::equal?)) + +;;; 6.2 Numbers + +(@define number? (@ Core::number?)) +(@define complex? (@ Core::complex?)) +(@define real? (@ Core::real?)) +(@define rational? (@ Core::rational?)) +(@define integer? (@ Core::integer?)) + +(@define exact? (@ Core::exact?)) +(@define inexact? (@ Core::inexact?)) + +(@define = (@ Core::=)) +(@define < (@ Core::<)) +(@define > (@ Core::>)) +(@define <= (@ Core::<=)) +(@define >= (@ Core::>=)) + +(@define zero? (@ Core::zero?)) +(@define positive? (@ Core::positive?)) +(@define negative? (@ Core::negative?)) +(@define odd? (@ Core::odd?)) +(@define even? (@ Core::even?)) + +(@define max (@ Core::max)) +(@define min (@ Core::min)) + +(@define + (@ Core::+)) +(@define * (@ Core::*)) +(@define - (@ Core::-)) +(@define / (@ Core::/)) + +(@define abs (@ Core::abs)) + +(@define quotient (@ Core::quotient)) +(@define remainder (@ Core::remainder)) +(@define modulo (@ Core::modulo)) + +(@define gcd (@ Core::gcd)) +(@define lcm (@ Core::lcm)) + +;; (@define numerator (@ Core::numerator)) +;; (@define denominator (@ Core::denominator)) + +(@define floor (@ Core::floor)) +(@define ceiling (@ Core::ceiling)) +(@define truncate (@ Core::truncate)) +(@define round (@ Core::round)) + +;; (@define rationalize (@ Core::rationalize)) + +(@define exp (@ Core::exp)) +(@define log (@ Core::log)) +(@define sin (@ Core::sin)) +(@define cos (@ Core::cos)) +(@define tan (@ Core::tan)) +(@define asin (@ Core::asin)) +(@define acos (@ Core::acos)) +(@define atan (@ Core::atan)) + +(@define sqrt (@ Core::sqrt)) +(@define expt (@ Core::expt)) + +(@define make-rectangular (@ Core::make-rectangular)) +(@define make-polar (@ Core::make-polar)) +(@define real-part (@ Core::real-part)) +(@define imag-part (@ Core::imag-part)) +(@define magnitude (@ Core::magnitude)) +(@define angle (@ Core::angle)) + +(@define exact->inexact (@ Core::exact->inexact)) +(@define inexact->exact (@ Core::inexact->exact)) + +(@define number->string (@ Core::number->string)) +(@define string->number (@ Core::string->number)) + +;;; 6.3 Other data types + +;;;; 6.3.1 Booleans + +(@define not (@lambda (x) (@not x))) +(@define boolean? (@ Core::boolean?)) + +;;;; 6.3.2 Pairs and lists + +(@define pair? (@lambda (x) (@pair? x))) +(@define cons (@lambda (x y) (@cons x y))) + +(@define car (@lambda (x) (@car x))) +(@define cdr (@lambda (x) (@cdr x))) +(@define set-car! (@ Core::set-car!)) +(@define set-cdr! (@ Core::set-cdr!)) + +(@define caar (@lambda (x) (@caar x))) +(@define cadr (@lambda (x) (@cadr x))) +(@define cdar (@lambda (x) (@cdar x))) +(@define cddr (@lambda (x) (@cddr x))) +(@define caaar (@lambda (x) (@caaar x))) +(@define caadr (@lambda (x) (@caadr x))) +(@define cadar (@lambda (x) (@cadar x))) +(@define caddr (@lambda (x) (@caddr x))) +(@define cdaar (@lambda (x) (@cdaar x))) +(@define cdadr (@lambda (x) (@cdadr x))) +(@define cddar (@lambda (x) (@cddar x))) +(@define cdddr (@lambda (x) (@cdddr x))) +(@define caaaar (@lambda (x) (@caaaar x))) +(@define caaadr (@lambda (x) (@caaadr x))) +(@define caadar (@lambda (x) (@caadar x))) +(@define caaddr (@lambda (x) (@caaddr x))) +(@define cadaar (@lambda (x) (@cadaar x))) +(@define cadadr (@lambda (x) (@cadadr x))) +(@define caddar (@lambda (x) (@caddar x))) +(@define cadddr (@lambda (x) (@cadddr x))) +(@define cdaaar (@lambda (x) (@cdaaar x))) +(@define cdaadr (@lambda (x) (@cdaadr x))) +(@define cdadar (@lambda (x) (@cdadar x))) +(@define cdaddr (@lambda (x) (@cdaddr x))) +(@define cddaar (@lambda (x) (@cddaar x))) +(@define cddadr (@lambda (x) (@cddadr x))) +(@define cdddar (@lambda (x) (@cdddar x))) +(@define cddddr (@lambda (x) (@cddddr x))) + +(@define null? (@lambda (x) (@null? x))) +(@define list? (@lambda (x) (@list? x))) + +(@define list (@lambda x x)) + +(@define length (@ Core::length)) +(@define append (@ Core::append)) +(@define reverse (@ Core::reverse)) +(@define list-tail (@ Core::list-tail)) +(@define list-ref (@ Core::list-ref)) + +(@define memq (@ Core::memq)) +(@define memv (@ Core::memv)) +(@define member (@ Core::member)) + +(@define assq (@ Core::assq)) +(@define assv (@ Core::assv)) +(@define assoc (@ Core::assoc)) + +;;;; 6.3.3 Symbols + +(@define symbol? (@ Core::symbol?)) +(@define symbol->string (@ Core::symbol->string)) +(@define string->symbol (@ Core::string->symbol)) + +;;;; 6.3.4 Characters + +(@define char? (@ Core::char?)) +(@define char=? (@ Core::char=?)) +(@define char<? (@ Core::char<?)) +(@define char>? (@ Core::char>?)) +(@define char<=? (@ Core::char<=?)) +(@define char>=? (@ Core::char>=?)) +(@define char-ci=? (@ Core::char-ci=?)) +(@define char-ci<? (@ Core::char-ci<?)) +(@define char-ci>? (@ Core::char-ci>?)) +(@define char-ci<=? (@ Core::char-ci<=?)) +(@define char-ci>=? (@ Core::char-ci>=?)) +(@define char-alphabetic? (@ Core::char-alphabetic?)) +(@define char-numeric? (@ Core::char-numeric?)) +(@define char-whitespace? (@ Core::char-whitespace?)) +(@define char-upper-case? (@ Core::char-upper-case?)) +(@define char-lower-case? (@ Core::char-lower-case?)) +(@define char->integer (@ Core::char->integer)) +(@define integer->char (@ Core::integer->char)) +(@define char-upcase (@ Core::char-upcase)) +(@define char-downcase (@ Core::char-downcase)) + +;;;; 6.3.5 Strings + +(@define string? (@ Core::string?)) +(@define make-string (@ Core::make-string)) +(@define string (@ Core::string)) +(@define string-length (@ Core::string-length)) +(@define string-ref (@ Core::string-ref)) +(@define string-set! (@ Core::string-set!)) + +(@define string=? (@ Core::string=?)) +(@define string-ci=? (@ Core::string-ci=?)) +(@define string<? (@ Core::string<?)) +(@define string>? (@ Core::string>?)) +(@define string<=? (@ Core::string<=?)) +(@define string>=? (@ Core::string>=?)) +(@define string-ci<? (@ Core::string-ci<?)) +(@define string-ci>? (@ Core::string-ci>?)) +(@define string-ci<=? (@ Core::string-ci<=?)) +(@define string-ci>=? (@ Core::string-ci>=?)) + +(@define substring (@ Core::substring)) +(@define string-append (@ Core::string-append)) +(@define string->list (@ Core::string->list)) +(@define list->string (@ Core::list->string)) +(@define string-copy (@ Core::string-copy)) +(@define string-fill! (@ Core::string-fill!)) + +;;;; 6.3.6 Vectors + +(@define vector? (@ Core::vector?)) +(@define make-vector (@ Core::make-vector)) +(@define vector (@ Core::vector)) +(@define vector-length (@ Core::vector-length)) +(@define vector-ref (@ Core::vector-ref)) +(@define vector-set! (@ Core::vector-set!)) +(@define vector->list (@ Core::vector->list)) +(@define list->vector (@ Core::list->vector)) +(@define vector-fill! (@ Core::vector-fill!)) + +;;; 6.4 Control features + +(@define procedure? (@ Core::procedure?)) +(@define apply (@ Core::apply)) +(@define map (@ Core::map)) +(@define for-each (@ Core::for-each)) +(@define force (@ Core::force)) + +(@define call-with-current-continuation (@ Core::call-with-current-continuation)) +(@define values (@ Core::values)) +(@define call-with-values (@ Core::call-with-values)) +(@define dynamic-wind (@ Core::dynamic-wind)) + +;;; 6.5 Eval + +(@define eval + (@let ((l (@ Language::r5rs::spec::r5rs))) + (@lambda (x e) + (((@ System::Base::language::compile-in) x e l))))) + +;; (@define scheme-report-environment +;; (@lambda (version) +;; (@if (@= version 5) +;; (@ Language::R5RS::Core) +;; (@error "Unsupported environment version" version)))) +;; +;; (@define null-environment +;; (@lambda (version) +;; (@if (@= version 5) +;; (@ Language::R5RS::Null) +;; (@error "Unsupported environment version" version)))) + +(@define interaction-environment (@lambda () (@current-module))) + +;;; 6.6 Input and output + +;;;; 6.6.1 Ports + +(@define call-with-input-file (@ Core::call-with-input-file)) +(@define call-with-output-file (@ Core::call-with-output-file)) + +(@define input-port? (@ Core::input-port?)) +(@define output-port? (@ Core::output-port?)) +(@define current-input-port (@ Core::current-input-port)) +(@define current-output-port (@ Core::current-output-port)) + +(@define with-input-from-file (@ Core::with-input-from-file)) +(@define with-output-to-file (@ Core::with-output-to-file)) + +(@define open-input-file (@ Core::open-input-file)) +(@define open-output-file (@ Core::open-output-file)) +(@define close-input-port (@ Core::close-input-port)) +(@define close-output-port (@ Core::close-output-port)) + +;;;; 6.6.2 Input + +(@define read (@ Core::read)) +(@define read-char (@ Core::read-char)) +(@define peek-char (@ Core::peek-char)) +(@define eof-object? (@ Core::eof-object?)) +(@define char-ready? (@ Core::char-ready?)) + +;;;; 6.6.3 Output + +(@define write (@ Core::write)) +(@define display (@ Core::display)) +(@define newline (@ Core::newline)) +(@define write-char (@ Core::write-char)) + +;;;; 6.6.4 System interface + +(@define load + (@lambda (file) + (call-with-input-file file + (@lambda (port) + (@let ((loop (@lambda (x) + (@if (@not (eof-object? x)) + (@begin + (eval x (interaction-environment)) + (loop (read port))))))) + (loop (read port))))))) + +;; transcript-on +;; transcript-off diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm new file mode 100644 index 000000000..e8910ae1b --- /dev/null +++ b/module/language/r5rs/expand.scm @@ -0,0 +1,80 @@ +;;; R5RS syntax expander + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language r5rs expand) + #:export (expand void + identifier? free-identifier=? bound-identifier=? + generate-temporaries datum->syntax-object syntax-object->datum)) + +(define sc-expand #f) +(define $sc-put-cte #f) +(define $syntax-dispatch #f) +(define syntax-rules #f) +(define syntax-error #f) +(define identifier? #f) +(define free-identifier=? #f) +(define bound-identifier=? #f) +(define generate-temporaries #f) +(define datum->syntax-object #f) +(define syntax-object->datum #f) + +(define void (lambda () (if #f #f))) + +(define andmap + (lambda (f first . rest) + (or (null? first) + (if (null? rest) + (let andmap ((first first)) + (let ((x (car first)) (first (cdr first))) + (if (null? first) + (f x) + (and (f x) (andmap first))))) + (let andmap ((first first) (rest rest)) + (let ((x (car first)) + (xr (map car rest)) + (first (cdr first)) + (rest (map cdr rest))) + (if (null? first) + (apply f (cons x xr)) + (and (apply f (cons x xr)) (andmap first rest))))))))) + +(define ormap + (lambda (proc list1) + (and (not (null? list1)) + (or (proc (car list1)) (ormap proc (cdr list1)))))) + +(define putprop set-symbol-property!) +(define getprop symbol-property) +(define remprop symbol-property-remove!) + +(define syncase-module (current-module)) +(define guile-eval eval) +(define (eval x) + (if (and (pair? x) (equal? (car x) "noexpand")) + (cdr x) + (guile-eval x syncase-module))) + +(define guile-error error) +(define (error who format-string why what) + (guile-error why what)) + +(load "psyntax.pp") + +(define expand sc-expand) diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il new file mode 100644 index 000000000..a290025de --- /dev/null +++ b/module/language/r5rs/null.il @@ -0,0 +1,19 @@ +;;; R5RS null environment + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: diff --git a/module/language/r5rs/psyntax.pp b/module/language/r5rs/psyntax.pp new file mode 100644 index 000000000..ef9ca0aa9 --- /dev/null +++ b/module/language/r5rs/psyntax.pp @@ -0,0 +1,14552 @@ +;;; psyntax.pp +;;; automatically generated from psyntax.ss +;;; Wed Aug 30 12:24:52 EST 2000 +;;; see copyright notice in psyntax.ss + +((lambda () + (letrec ((g452 + (lambda (g1823) + ((letrec ((g1824 + (lambda (g1827 g1825 g1826) + (if (pair? g1827) + (g1824 + (cdr g1827) + (cons (g393 (car g1827) g1826) g1825) + g1826) + (if (g256 g1827) + (cons (g393 g1827 g1826) g1825) + (if (null? g1827) + g1825 + (if (g204 g1827) + (g1824 + (g205 g1827) + g1825 + (g371 g1826 (g206 g1827))) + (if (g90 g1827) + (g1824 + (annotation-expression + g1827) + g1825 + g1826) + (cons g1827 g1825))))))))) + g1824) + g1823 + '() + '(())))) + (g451 + (lambda (g833) + ((lambda (g834) (if (g90 g834) (gensym) (gensym))) + (if (g204 g833) (g205 g833) g833)))) + (g450 + (lambda (g1820 g1819) + (g449 g1820 + g1819 + (lambda (g1821) + (if ((lambda (g1822) + (if g1822 + g1822 + (if (pair? g1821) + (g90 (car g1821)) + '#f))) + (g90 g1821)) + (g448 g1821 '#f) + g1821))))) + (g449 + (lambda (g837 g835 g836) + (if (memq 'top (g264 g835)) + (g836 g837) + ((letrec ((g838 + (lambda (g839) + (if (g204 g839) + (g449 (g205 g839) (g206 g839) g836) + (if (pair? g839) + ((lambda (g841 g840) + (if (if (eq? g841 (car g839)) + (eq? g840 (cdr g839)) + '#f) + g839 + (cons g841 g840))) + (g838 (car g839)) + (g838 (cdr g839))) + (if (vector? g839) + ((lambda (g842) + ((lambda (g843) + (if (andmap + eq? + g842 + g843) + g839 + (list->vector g843))) + (map g838 g842))) + (vector->list g839)) + g839)))))) + g838) + g837)))) + (g448 + (lambda (g1813 g1812) + (if (pair? g1813) + ((lambda (g1814) + (begin (if g1812 + (set-annotation-stripped! g1812 g1814) + (void)) + (set-car! g1814 (g448 (car g1813) '#f)) + (set-cdr! g1814 (g448 (cdr g1813) '#f)) + g1814)) + (cons '#f '#f)) + (if (g90 g1813) + ((lambda (g1815) + (if g1815 + g1815 + (g448 (annotation-expression g1813) g1813))) + (annotation-stripped g1813)) + (if (vector? g1813) + ((lambda (g1816) + (begin (if g1812 + (set-annotation-stripped! + g1812 + g1816) + (void)) + ((letrec ((g1817 + (lambda (g1818) + (if (not (< g1818 '0)) + (begin (vector-set! + g1816 + g1818 + (g448 (vector-ref + g1813 + g1818) + '#f)) + (g1817 + (- g1818 + '1))) + (void))))) + g1817) + (- (vector-length g1813) '1)) + g1816)) + (make-vector (vector-length g1813))) + g1813))))) + (g447 + (lambda (g844) + (if (g255 g844) + (g378 g844 + '#(syntax-object + ... + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage ((import-token . *top*)) () ()) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g446 (lambda () (list 'void))) + (g445 + (lambda (g850 g845 g849 g846 g848 g847) + ((lambda (g851) + ((lambda (g852) + (if g852 + (apply + (lambda (g857 g853 g856 g854 g855) + ((lambda (g858) + (if (not (g389 g858)) + (g391 (map (lambda (g859) + (g393 g859 g846)) + g858) + (g394 g845 g846 g848) + '"keyword") + ((lambda (g860) + ((lambda (g861) + (g847 (cons g854 g855) + (g247 g860 + ((lambda (g863 g862) + (map (lambda (g865) + (g231 'deferred + (g432 g865 + g862 + g863))) + g856)) + (if g850 g861 g846) + (g249 g849)) + g849) + g861 + g848)) + (g368 g858 g860 g846))) + (g299 g858)))) + g853)) + g852) + ((lambda (g868) + (syntax-error (g394 g845 g846 g848))) + g851))) + ($syntax-dispatch + g851 + '(any #(each (any any)) any . each-any)))) + g845))) + (g444 + (lambda (g1789 g1785 g1788 g1786 g1787) + ((lambda (g1790) + ((lambda (g1791) + (if g1791 + (apply + (lambda (g1794 g1792 g1793) + ((lambda (g1795) + (if (not (g389 g1795)) + (syntax-error + g1789 + '"invalid parameter list in") + ((lambda (g1797 g1796) + (g1787 + g1796 + (g437 (cons g1792 g1793) + g1789 + (g248 g1797 g1796 g1788) + (g368 g1795 g1797 g1786)))) + (g299 g1795) + (map g451 g1795)))) + g1794)) + g1791) + ((lambda (g1800) + (if g1800 + (apply + (lambda (g1803 g1801 g1802) + ((lambda (g1804) + (if (not (g389 g1804)) + (syntax-error + g1789 + '"invalid parameter list in") + ((lambda (g1806 g1805) + (g1787 + ((letrec ((g1808 + (lambda (g1810 + g1809) + (if (null? + g1810) + g1809 + (g1808 + (cdr g1810) + (cons (car g1810) + g1809)))))) + g1808) + (cdr g1805) + (car g1805)) + (g437 (cons g1801 g1802) + g1789 + (g248 g1806 + g1805 + g1788) + (g368 g1804 + g1806 + g1786)))) + (g299 g1804) + (map g451 g1804)))) + (g452 g1803))) + g1800) + ((lambda (g1811) (syntax-error g1789)) + g1790))) + ($syntax-dispatch g1790 '(any any . each-any))))) + ($syntax-dispatch g1790 '(each-any any . each-any)))) + g1785))) + (g443 + (lambda (g872 g869 g871 g870) + ((lambda (g873) + ((lambda (g874) + (if (if g874 + (apply + (lambda (g877 g875 g876) (g256 g875)) + g874) + '#f) + (apply + (lambda (g880 g878 g879) (g870 g878 g879 g869)) + g874) + ((lambda (g881) + (syntax-error (g394 g872 g869 g871))) + g873))) + ($syntax-dispatch g873 '(any any any)))) + g872))) + (g442 + (lambda (g1758 g1755 g1757 g1756) + ((lambda (g1759) + ((lambda (g1760) + (if (if g1760 + (apply + (lambda (g1763 g1761 g1762) (g256 g1761)) + g1760) + '#f) + (apply + (lambda (g1766 g1764 g1765) + (g1756 g1764 g1765 g1755)) + g1760) + ((lambda (g1767) + (if (if g1767 + (apply + (lambda (g1772 + g1768 + g1771 + g1769 + g1770) + (if (g256 g1768) + (g389 (g452 g1771)) + '#f)) + g1767) + '#f) + (apply + (lambda (g1777 g1773 g1776 g1774 g1775) + (g1756 + (g393 g1773 g1755) + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ name args e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(e w s k) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()) + #(ribcage + ((import-token . *top*)) + () + ()))) + (g393 (cons g1776 + (cons g1774 g1775)) + g1755)) + '(()))) + g1767) + ((lambda (g1779) + (if (if g1779 + (apply + (lambda (g1781 g1780) + (g256 g1780)) + g1779) + '#f) + (apply + (lambda (g1783 g1782) + (g1756 + (g393 g1782 g1755) + '(#(syntax-object + void + ((top) + #(ribcage + #(_ name) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(e w s k) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + '(()))) + g1779) + ((lambda (g1784) + (syntax-error + (g394 g1758 g1755 g1757))) + g1759))) + ($syntax-dispatch g1759 '(any any))))) + ($syntax-dispatch + g1759 + '(any (any . any) any . each-any))))) + ($syntax-dispatch g1759 '(any any any)))) + g1758))) + (g441 + (lambda (g885 g882 g884 g883) + ((lambda (g886) + ((lambda (g887) + (if (if g887 + (apply (lambda (g889 g888) (g256 g888)) g887) + '#f) + (apply + (lambda (g891 g890) (g883 (g393 g890 g882))) + g887) + ((lambda (g892) + (syntax-error (g394 g885 g882 g884))) + g886))) + ($syntax-dispatch g886 '(any any)))) + g885))) + (g440 + (lambda (g1723 g1719 g1722 g1720 g1721) + (letrec ((g1725 + (lambda (g1753 g1751 g1752) + (g1721 + g1753 + (g1724 g1751) + (map (lambda (g1754) (g393 g1754 g1720)) + g1752)))) + (g1724 + (lambda (g1745) + (if (null? g1745) + '() + (cons ((lambda (g1746) + ((lambda (g1747) + (if g1747 + (apply + (lambda (g1748) + (g1724 g1748)) + g1747) + ((lambda (g1750) + (if (g256 g1750) + (g393 g1750 g1720) + (syntax-error + (g394 g1723 + g1719 + g1722) + '"invalid exports list in"))) + g1746))) + ($syntax-dispatch + g1746 + 'each-any))) + (car g1745)) + (g1724 (cdr g1745))))))) + ((lambda (g1726) + ((lambda (g1727) + (if g1727 + (apply + (lambda (g1730 g1728 g1729) + (g1725 '#f g1728 g1729)) + g1727) + ((lambda (g1733) + (if (if g1733 + (apply + (lambda (g1737 g1734 g1736 g1735) + (g256 g1734)) + g1733) + '#f) + (apply + (lambda (g1741 g1738 g1740 g1739) + (g1725 + (g393 g1738 g1719) + g1740 + g1739)) + g1733) + ((lambda (g1744) + (syntax-error + (g394 g1723 g1719 g1722))) + g1726))) + ($syntax-dispatch + g1726 + '(any any each-any . each-any))))) + ($syntax-dispatch g1726 '(any each-any . each-any)))) + g1723)))) + (g439 + (lambda (g894 g893) + ((lambda (g895) + (if g895 + (g366 g893 g895) + (g429 (lambda (g896) + ((lambda (g897) + (begin (if (not g897) + (syntax-error + g896 + '"exported identifier not visible") + (void)) + (g363 g893 g896 g897))) + (g376 g896 '(())))) + (g404 g894)))) + (g405 g894)))) + (g438 + (lambda (g1652 g1648 g1651 g1649 g1650) + (letrec ((g1653 + (lambda (g1718 g1714 g1717 g1715 g1716) + (begin (g426 g1648 g1714) + (g1650 g1718 g1714 g1717 g1715 g1716))))) + ((letrec ((g1654 + (lambda (g1659 g1655 g1658 g1656 g1657) + (if (null? g1659) + (g1653 g1659 g1655 g1658 g1656 g1657) + ((lambda (g1661 g1660) + (call-with-values + (lambda () + (g398 g1661 + g1660 + '(()) + '#f + g1652)) + (lambda (g1666 + g1662 + g1665 + g1663 + g1664) + ((lambda (g1667) + (if (memv g1667 '(define-form)) + (g442 g1665 + g1663 + g1664 + (lambda (g1670 + g1668 + g1669) + ((lambda (g1672 + g1671) + ((lambda (g1673) + (begin (g363 g1652 + g1672 + g1671) + (g424 g1649 + g1671 + (g231 'lexical + g1673)) + (g1654 + (cdr g1659) + (cons g1672 + g1655) + (cons g1673 + g1658) + (cons (cons g1660 + (g393 g1668 + g1669)) + g1656) + g1657))) + (g451 g1672))) + (g393 g1670 g1669) + (g297)))) + (if (memv g1667 + '(define-syntax-form)) + (g443 g1665 + g1663 + g1664 + (lambda (g1676 + g1674 + g1675) + ((lambda (g1679 + g1677 + g1678) + (begin (g363 g1652 + g1679 + g1677) + (g424 g1649 + g1677 + (g231 'deferred + g1678)) + (g1654 + (cdr g1659) + (cons g1679 + g1655) + g1658 + g1656 + g1657))) + (g393 g1676 + g1675) + (g297) + (g432 g1674 + (g249 g1660) + g1675)))) + (if (memv g1667 + '(module-form)) + ((lambda (g1680) + ((lambda (g1681) + ((lambda () + (g440 g1665 + g1663 + g1664 + g1681 + (lambda (g1684 + g1682 + g1683) + (g438 g1680 + (g394 g1665 + g1663 + g1664) + (map (lambda (g1695) + (cons g1660 + g1695)) + g1683) + g1649 + (lambda (g1689 + g1685 + g1688 + g1686 + g1687) + (begin (g425 g1648 + (g401 g1682) + g1685) + ((lambda (g1693 + g1690 + g1692 + g1691) + (if g1684 + ((lambda (g1694) + (begin (g363 g1652 + g1684 + g1694) + (g424 g1649 + g1694 + (g231 'module + g1693)) + (g1654 + (cdr g1659) + (cons g1684 + g1655) + g1690 + g1692 + g1691))) + (g297)) + ((lambda () + (begin (g439 g1693 + g1652) + (g1654 + (cdr g1659) + (cons g1693 + g1655) + g1690 + g1692 + g1691)))))) + (g408 g1682) + (append + g1688 + g1658) + (append + g1686 + g1656) + (append + g1657 + g1687 + g1689)))))))))) + (g263 (g264 g1663) + (cons g1680 + (g265 g1663))))) + (g304 '() + '() + '())) + (if (memv g1667 + '(import-form)) + (g441 g1665 + g1663 + g1664 + (lambda (g1696) + ((lambda (g1697) + ((lambda (g1698) + ((lambda (g1699) + (if (memv g1699 + '(module)) + ((lambda (g1700) + (begin (if g1662 + (g364 g1652 + g1662) + (void)) + (g439 g1700 + g1652) + (g1654 + (cdr g1659) + (cons g1700 + g1655) + g1658 + g1656 + g1657))) + (cdr g1698)) + (if (memv g1699 + '(displaced-lexical)) + (g250 g1696) + (syntax-error + g1696 + '"import from unknown module")))) + (car g1698))) + (g253 g1697 + g1649))) + (g377 g1696 + '(()))))) + (if (memv g1667 + '(begin-form)) + ((lambda (g1701) + ((lambda (g1702) + (if g1702 + (apply + (lambda (g1704 + g1703) + (g1654 + ((letrec ((g1705 + (lambda (g1706) + (if (null? + g1706) + (cdr g1659) + (cons (cons g1660 + (g393 (car g1706) + g1663)) + (g1705 + (cdr g1706))))))) + g1705) + g1703) + g1655 + g1658 + g1656 + g1657)) + g1702) + (syntax-error + g1701))) + ($syntax-dispatch + g1701 + '(any . + each-any)))) + g1665) + (if (memv g1667 + '(local-syntax-form)) + (g445 g1662 + g1665 + g1660 + g1663 + g1664 + (lambda (g1711 + g1708 + g1710 + g1709) + (g1654 + ((letrec ((g1712 + (lambda (g1713) + (if (null? + g1713) + (cdr g1659) + (cons (cons g1708 + (g393 (car g1713) + g1710)) + (g1712 + (cdr g1713))))))) + g1712) + g1711) + g1655 + g1658 + g1656 + g1657))) + (g1653 + (cons (cons g1660 + (g394 g1665 + g1663 + g1664)) + (cdr g1659)) + g1655 + g1658 + g1656 + g1657)))))))) + g1666)))) + (cdar g1659) + (caar g1659)))))) + g1654) + g1651 + '() + '() + '() + '())))) + (g437 + (lambda (g901 g898 g900 g899) + ((lambda (g902) + ((lambda (g903) + ((lambda (g904) + ((lambda (g905) + ((lambda () + (g438 g903 + g898 + g905 + g902 + (lambda (g910 g906 g909 g907 g908) + (begin (if (null? g910) + (syntax-error + g898 + '"no expressions in body") + (void)) + (g191 '#f + g909 + (map (lambda (g912) + (g432 (cdr g912) + (car g912) + '(()))) + g907) + (g190 '#f + (map (lambda (g911) + (g432 (cdr g911) + (car g911) + '(()))) + (append + g908 + g910)))))))))) + (map (lambda (g913) (cons g902 (g393 g913 g904))) + g901))) + (g263 (g264 g899) (cons g903 (g265 g899))))) + (g304 '() '() '()))) + (cons '("placeholder" placeholder) g900)))) + (g436 + (lambda (g1635 g1630 g1634 g1631 g1633 g1632) + (letrec ((g1636 + (lambda (g1640 g1639) + (if (pair? g1640) + (cons (g1636 (car g1640) g1639) + (g1636 (cdr g1640) g1639)) + (if (g204 g1640) + ((lambda (g1641) + ((lambda (g1643 g1642) + (g203 (g205 g1640) + (if (if (pair? g1643) + (eq? (car g1643) + '#f) + '#f) + (g263 (cdr g1643) + (if g1632 + (cons g1632 + (cdr g1642)) + (cdr g1642))) + (g263 (cons g1639 g1643) + (if g1632 + (cons g1632 + (cons 'shift + g1642)) + (cons 'shift + g1642)))))) + (g264 g1641) + (g265 g1641))) + (g206 g1640)) + (if (vector? g1640) + ((lambda (g1644) + ((lambda (g1645) + ((lambda () + ((letrec ((g1646 + (lambda (g1647) + (if (= g1647 + g1644) + g1645 + (begin (vector-set! + g1645 + g1647 + (g1636 + (vector-ref + g1640 + g1647) + g1639)) + (g1646 + (+ g1647 + '1))))))) + g1646) + '0)))) + (make-vector g1644))) + (vector-length g1640)) + (if (symbol? g1640) + (syntax-error + (g394 g1630 g1631 g1633) + '"encountered raw symbol " + (format '"~s" g1640) + '" in output of macro") + g1640))))))) + (g1636 + ((lambda (g1637) + (if (procedure? g1637) + (g1637 + (lambda (g1638) + (begin (if (not (identifier? g1638)) + (syntax-error + g1638 + '"environment argument is not an identifier") + (void)) + (g253 (g377 g1638 '(())) g1634)))) + g1637)) + (g1635 (g394 g1630 (g349 g1631) g1633))) + (string '#\m))))) + (g435 + (lambda (g918 g914 g917 g915 g916) + ((lambda (g919) + ((lambda (g920) + (if (if g920 + (apply + (lambda (g923 g921 g922) (g256 g921)) + g920) + '#f) + (apply + (lambda (g926 g924 g925) + ((lambda (g927) + ((lambda (g928) + ((lambda (g929) + (if (memv g929 '(macro!)) + ((lambda (g931 g930) + (g398 (g436 (g233 g928) + (list '#(syntax-object + set! + ((top) + #(ribcage + () + () + ()) + #(ribcage + #(id + val) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(t) + #(("m" top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(b) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(n) + #((top)) + #("i")) + #(ribcage + #(_ + id + val) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(e + r + w + s + rib) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g931 + g930) + g914 + '(()) + g915 + g916) + g914 + '(()) + g915 + g916)) + (g393 g924 g917) + (g393 g925 g917)) + (values + 'core + (lambda (g935 g932 g934 g933) + ((lambda (g937 g936) + ((lambda (g938) + ((lambda (g939) + (if (memv g939 + '(lexical)) + (list 'set! + (g233 g938) + g937) + (if (memv g939 + '(global)) + (list 'set! + (g233 g938) + g937) + (if (memv g939 + '(displaced-lexical)) + (syntax-error + (g393 g924 + g934) + '"identifier out of context") + (syntax-error + (g394 g935 + g934 + g933)))))) + (g232 g938))) + (g253 g936 g932))) + (g432 g925 g932 g934) + (g377 g924 g934))) + g918 + g917 + g915))) + (g232 g928))) + (g253 g927 g914))) + (g377 g924 g917))) + g920) + ((lambda (g940) + (syntax-error (g394 g918 g917 g915))) + g919))) + ($syntax-dispatch g919 '(any any any)))) + g918))) + (g434 + (lambda (g1622 g1618 g1621 g1619 g1620) + ((lambda (g1623) + ((lambda (g1624) + (if g1624 + (apply + (lambda (g1626 g1625) + (cons g1622 + (map (lambda (g1628) + (g432 g1628 g1621 g1619)) + g1625))) + g1624) + ((lambda (g1629) + (syntax-error (g394 g1618 g1619 g1620))) + g1623))) + ($syntax-dispatch g1623 '(any . each-any)))) + g1618))) + (g433 + (lambda (g946 g941 g945 g942 g944 g943) + ((lambda (g947) + (if (memv g947 '(lexical)) + g941 + (if (memv g947 '(core)) + (g941 g945 g942 g944 g943) + (if (memv g947 '(lexical-call)) + (g434 g941 g945 g942 g944 g943) + (if (memv g947 '(constant)) + (list 'quote + (g450 (g394 g945 g944 g943) '(()))) + (if (memv g947 '(global)) + g941 + (if (memv g947 '(call)) + (g434 (g432 (car g945) g942 g944) + g945 + g942 + g944 + g943) + (if (memv g947 '(begin-form)) + ((lambda (g948) + ((lambda (g949) + (if g949 + (apply + (lambda (g952 + g950 + g951) + (g395 (cons g950 + g951) + g942 + g944 + g943)) + g949) + (syntax-error + g948))) + ($syntax-dispatch + g948 + '(any any + . + each-any)))) + g945) + (if (memv g947 + '(local-syntax-form)) + (g445 g941 + g945 + g942 + g944 + g943 + g395) + (if (memv g947 + '(eval-when-form)) + ((lambda (g954) + ((lambda (g955) + (if g955 + (apply + (lambda (g959 + g956 + g958 + g957) + ((lambda (g960) + (if (memq 'eval + g960) + (g395 (cons g958 + g957) + g942 + g944 + g943) + (g446))) + (g397 g945 + g956 + g944))) + g955) + (syntax-error + g954))) + ($syntax-dispatch + g954 + '(any each-any + any + . + each-any)))) + g945) + (if (memv g947 + '(define-form + define-syntax-form + module-form + import-form)) + (syntax-error + (g394 g945 + g944 + g943) + '"invalid context for definition") + (if (memv g947 + '(syntax)) + (syntax-error + (g394 g945 + g944 + g943) + '"reference to pattern variable outside syntax form") + (if (memv g947 + '(displaced-lexical)) + (g250 (g394 g945 + g944 + g943)) + (syntax-error + (g394 g945 + g944 + g943))))))))))))))) + g946))) + (g432 + (lambda (g1612 g1610 g1611) + (call-with-values + (lambda () (g398 g1612 g1610 g1611 '#f '#f)) + (lambda (g1617 g1613 g1616 g1614 g1615) + (g433 g1617 g1613 g1616 g1610 g1614 g1615))))) + (g431 + (lambda (g965 g963 g964) + ((lambda (g966) + (if (memv g966 '(c)) + (if (memq 'compile g963) + ((lambda (g967) + (begin (g91 g967) + (if (memq 'load g963) g967 (g446)))) + (g964)) + (if (memq 'load g963) (g964) (g446))) + (if (memv g966 '(c&e)) + ((lambda (g968) (begin (g91 g968) g968)) (g964)) + (begin (if (memq 'eval g963) (g91 (g964)) (void)) + (g446))))) + g965))) + (g430 + (lambda (g1609 g1608) + (list '$sc-put-cte + (list 'quote g1609) + (list 'quote (g231 'do-import g1608))))) + (g429 + (lambda (g970 g969) + ((lambda (g971) + ((letrec ((g972 + (lambda (g973) + (if (not (= g973 g971)) + (begin (g970 (vector-ref g969 g973)) + (g972 (+ g973 '1))) + (void))))) + g972) + '0)) + (vector-length g969)))) + (g428 + (lambda (g1604 g1603) + ((letrec ((g1605 + (lambda (g1607 g1606) + (if (< g1607 '0) + g1606 + (g1605 + (- g1607 '1) + (cons (g1604 (vector-ref g1603 g1607)) + g1606)))))) + g1605) + (- (vector-length g1603) '1) + '()))) + (g427 + (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978) + (letrec ((g985 + (lambda (g1050 g1049) + ((lambda (g1051) + (map (lambda (g1052) + ((lambda (g1053) + (if (not (g392 g1053 g1051)) + g1052 + (g410 (g412 g1052) + g1053 + (g414 g1052) + (append + (g984 g1053) + (g415 g1052)) + (g416 g1052)))) + (g413 g1052))) + g1050)) + (map (lambda (g1054) + (if (pair? g1054) (car g1054) g1054)) + g1049)))) + (g984 + (lambda (g1043) + ((letrec ((g1044 + (lambda (g1045) + (if (null? g1045) + '() + (if (if (pair? (car g1045)) + (g388 g1043 + (caar g1045)) + '#f) + (g401 (cdar g1045)) + (g1044 (cdr g1045))))))) + g1044) + g980))) + (g983 + (lambda (g1048 g1046 g1047) + (begin (g426 g974 g1046) + (g425 g974 g976 g1046) + (g978 g1048 g1047))))) + ((letrec ((g986 + (lambda (g990 g987 g989 g988) + (if (null? g990) + (g983 g989 g987 g988) + ((lambda (g992 g991) + (call-with-values + (lambda () + (g398 g992 g991 '(()) '#f g982)) + (lambda (g997 g993 g996 g994 g995) + ((lambda (g998) + (if (memv g998 '(define-form)) + (g442 g996 + g994 + g995 + (lambda (g1001 + g999 + g1000) + ((lambda (g1002) + ((lambda (g1003) + ((lambda (g1004) + ((lambda () + (begin (g363 g982 + g1002 + g1003) + (g986 (cdr g990) + (cons g1002 + g987) + (cons (g410 g997 + g1002 + g1003 + g1004 + (cons g991 + (g393 g999 + g1000))) + g989) + g988))))) + (g984 g1002))) + (g300))) + (g393 g1001 + g1000)))) + (if (memv g998 + '(define-syntax-form)) + (g443 g996 + g994 + g995 + (lambda (g1007 + g1005 + g1006) + ((lambda (g1008) + ((lambda (g1009) + ((lambda (g1010) + ((lambda (g1011) + ((lambda () + (begin (g424 g975 + (g302 g1009) + (cons 'deferred + g1011)) + (g363 g982 + g1008 + g1009) + (g986 (cdr g990) + (cons g1008 + g987) + (cons (g410 g997 + g1008 + g1009 + g1010 + g1011) + g989) + g988))))) + (g432 g1005 + (g249 g991) + g1006))) + (g984 g1008))) + (g300))) + (g393 g1007 + g1006)))) + (if (memv g998 + '(module-form)) + ((lambda (g1012) + ((lambda (g1013) + ((lambda () + (g440 g996 + g994 + g995 + g1013 + (lambda (g1016 + g1014 + g1015) + (g427 g1012 + (g394 g996 + g994 + g995) + (map (lambda (g1024) + (cons g991 + g1024)) + g1015) + g975 + g1014 + (g401 g1014) + g979 + g977 + (lambda (g1018 + g1017) + ((lambda (g1019) + ((lambda (g1020) + ((lambda (g1021) + ((lambda () + (if g1016 + ((lambda (g1023 + g1022) + (begin (g424 g975 + (g302 g1023) + (g231 'module + g1019)) + (g363 g982 + g1016 + g1023) + (g986 (cdr g990) + (cons g1016 + g987) + (cons (g410 g997 + g1016 + g1023 + g1022 + g1014) + g1020) + g1021))) + (g300) + (g984 g1016)) + ((lambda () + (begin (g439 g1019 + g982) + (g986 (cdr g990) + (cons g1019 + g987) + g1020 + g1021)))))))) + (append + g988 + g1017))) + (append + (if g1016 + g1018 + (g985 g1018 + g1014)) + g989))) + (g408 g1014))))))))) + (g263 (g264 g994) + (cons g1012 + (g265 g994))))) + (g304 '() + '() + '())) + (if (memv g998 + '(import-form)) + (g441 g996 + g994 + g995 + (lambda (g1025) + ((lambda (g1026) + ((lambda (g1027) + ((lambda (g1028) + (if (memv g1028 + '(module)) + ((lambda (g1029) + (begin (if g993 + (g364 g982 + g993) + (void)) + (g439 g1029 + g982) + (g986 (cdr g990) + (cons g1029 + g987) + (g985 g989 + (vector->list + (g404 g1029))) + g988))) + (g233 g1027)) + (if (memv g1028 + '(displaced-lexical)) + (g250 g1025) + (syntax-error + g1025 + '"import from unknown module")))) + (g232 g1027))) + (g253 g1026 + g975))) + (g377 g1025 + '(()))))) + (if (memv g998 + '(begin-form)) + ((lambda (g1030) + ((lambda (g1031) + (if g1031 + (apply + (lambda (g1033 + g1032) + (g986 ((letrec ((g1034 + (lambda (g1035) + (if (null? + g1035) + (cdr g990) + (cons (cons g991 + (g393 (car g1035) + g994)) + (g1034 + (cdr g1035))))))) + g1034) + g1032) + g987 + g989 + g988)) + g1031) + (syntax-error + g1030))) + ($syntax-dispatch + g1030 + '(any . + each-any)))) + g996) + (if (memv g998 + '(local-syntax-form)) + (g445 g993 + g996 + g991 + g994 + g995 + (lambda (g1040 + g1037 + g1039 + g1038) + (g986 ((letrec ((g1041 + (lambda (g1042) + (if (null? + g1042) + (cdr g990) + (cons (cons g1037 + (g393 (car g1042) + g1039)) + (g1041 + (cdr g1042))))))) + g1041) + g1040) + g987 + g989 + g988))) + (g983 g989 + g987 + (append + g988 + (cons (cons g991 + (g394 g996 + g994 + g995)) + (cdr g990))))))))))) + g997)))) + (cdar g990) + (caar g990)))))) + g986) + g981 + '() + '() + '())))) + (g426 + (lambda (g1560 g1559) + (letrec ((g1564 + (lambda (g1597 g1595 g1596) + ((lambda (g1598) + (if g1598 + (if (g367 ((lambda (g1599) + ((lambda (g1600) + (if (g90 g1600) + (annotation-expression + g1600) + g1600)) + (if (g204 g1599) + (g205 g1599) + g1599))) + g1597) + g1598 + (if (symbol? g1597) + (g264 '((top))) + (g264 (g206 g1597)))) + (cons g1597 g1596) + g1596) + (g1562 + (g404 g1595) + (lambda (g1602 g1601) + (if (g1561 g1602 g1597) + (cons g1602 g1601) + g1601)) + g1596))) + (g405 g1595)))) + (g1563 + (lambda (g1575 g1573 g1574) + (if (g403 g1575) + (if (g403 g1573) + (call-with-values + (lambda () + ((lambda (g1581 g1580) + (if (fx> (vector-length g1581) + (vector-length g1580)) + (values g1575 g1580) + (values g1573 g1581))) + (g404 g1575) + (g404 g1573))) + (lambda (g1577 g1576) + (g1562 + g1576 + (lambda (g1579 g1578) + (g1564 g1579 g1577 g1578)) + g1574))) + (g1564 g1573 g1575 g1574)) + (if (g403 g1573) + (g1564 g1575 g1573 g1574) + (if (g1561 g1575 g1573) + (cons g1575 g1574) + g1574))))) + (g1562 + (lambda (g1590 g1588 g1589) + ((lambda (g1591) + ((letrec ((g1592 + (lambda (g1594 g1593) + (if (= g1594 g1591) + g1593 + (g1592 + (+ g1594 '1) + (g1588 + (vector-ref g1590 g1594) + g1593)))))) + g1592) + '0 + g1589)) + (vector-length g1590)))) + (g1561 + (lambda (g1583 g1582) + (if (symbol? g1583) + (if (symbol? g1582) + (eq? g1583 g1582) + (if (eq? g1583 + ((lambda (g1584) + ((lambda (g1585) + (if (g90 g1585) + (annotation-expression + g1585) + g1585)) + (if (g204 g1584) + (g205 g1584) + g1584))) + g1582)) + (g373 (g264 (g206 g1582)) + (g264 '((top)))) + '#f)) + (if (symbol? g1582) + (if (eq? g1582 + ((lambda (g1586) + ((lambda (g1587) + (if (g90 g1587) + (annotation-expression + g1587) + g1587)) + (if (g204 g1586) + (g205 g1586) + g1586))) + g1583)) + (g373 (g264 (g206 g1583)) + (g264 '((top)))) + '#f) + (g388 g1583 g1582)))))) + (if (not (null? g1559)) + ((letrec ((g1565 + (lambda (g1568 g1566 g1567) + (if (null? g1566) + (if (not (null? g1567)) + ((lambda (g1569) + (syntax-error + g1560 + '"duplicate definition for " + (symbol->string (car g1569)) + '" in")) + (syntax-object->datum g1567)) + (void)) + ((letrec ((g1570 + (lambda (g1572 g1571) + (if (null? g1572) + (g1565 + (car g1566) + (cdr g1566) + g1571) + (g1570 + (cdr g1572) + (g1563 + g1568 + (car g1572) + g1571)))))) + g1570) + g1566 + g1567))))) + g1565) + (car g1559) + (cdr g1559) + '()) + (void))))) + (g425 + (lambda (g1057 g1055 g1056) + (letrec ((g1058 + (lambda (g1065 g1064) + (ormap + (lambda (g1066) + (if (g403 g1066) + ((lambda (g1067) + (if g1067 + (g367 ((lambda (g1068) + ((lambda (g1069) + (if (g90 g1069) + (annotation-expression + g1069) + g1069)) + (if (g204 g1068) + (g205 g1068) + g1068))) + g1065) + g1067 + (g264 (g206 g1065))) + ((lambda (g1070) + ((letrec ((g1071 + (lambda (g1072) + (if (fx>= g1072 + '0) + ((lambda (g1073) + (if g1073 + g1073 + (g1071 + (- g1072 + '1)))) + (g388 g1065 + (vector-ref + g1070 + g1072))) + '#f)))) + g1071) + (- (vector-length g1070) + '1))) + (g404 g1066)))) + (g405 g1066)) + (g388 g1065 g1066))) + g1064)))) + ((letrec ((g1059 + (lambda (g1061 g1060) + (if (null? g1061) + (if (not (null? g1060)) + (syntax-error + g1060 + '"missing definition for export(s)") + (void)) + ((lambda (g1063 g1062) + (if (g1058 g1063 g1056) + (g1059 g1062 g1060) + (g1059 g1062 (cons g1063 g1060)))) + (car g1061) + (cdr g1061)))))) + g1059) + g1055 + '())))) + (g424 + (lambda (g1558 g1556 g1557) + (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558))))) + (g423 + (lambda (g1075 g1074) + (if (null? g1075) + '() + (if (g392 (car g1075) g1074) + (g423 (cdr g1075) g1074) + (cons (car g1075) (g423 (cdr g1075) g1074)))))) + (g422 + (lambda (g1491 + g1482 + g1490 + g1483 + g1489 + g1484 + g1488 + g1485 + g1487 + g1486) + ((lambda (g1492) + (g427 g1490 + (g394 g1491 g1483 g1489) + (map (lambda (g1555) (cons g1482 g1555)) g1486) + g1482 + g1487 + g1492 + g1484 + g1488 + (lambda (g1494 g1493) + ((letrec ((g1495 + (lambda (g1500 + g1496 + g1499 + g1497 + g1498) + (if (null? g1500) + ((letrec ((g1501 + (lambda (g1504 + g1502 + g1503) + (if (null? g1504) + ((lambda (g1507 + g1505 + g1506) + (begin (for-each + (lambda (g1523) + (apply + (lambda (g1527 + g1524 + g1526 + g1525) + (if g1524 + (g303 g1524 + g1526) + (void))) + g1523)) + g1498) + (g190 '#f + (list (g431 g1484 + g1488 + (lambda () + (if (null? + g1498) + (g446) + (g190 '#f + (map (lambda (g1518) + (apply + (lambda (g1522 + g1519 + g1521 + g1520) + (list '$sc-put-cte + (list 'quote + g1521) + (if (eq? g1522 + 'define-syntax-form) + g1520 + (list 'quote + (g231 'module + (g409 g1520 + g1521)))))) + g1518)) + g1498))))) + (g431 g1484 + g1488 + (lambda () + ((lambda (g1508) + ((lambda (g1509) + ((lambda (g1510) + ((lambda () + (if g1508 + (list '$sc-put-cte + (list 'quote + (if (g373 (g264 (g206 g1485)) + (g264 '((top)))) + g1508 + ((lambda (g1511) + (g203 g1508 + (g263 g1511 + (list (g304 (vector + g1508) + (vector + g1511) + (vector + (g101 g1508))))))) + (g264 (g206 g1485))))) + g1510) + ((lambda (g1512) + (g190 '#f + (list (list '$sc-put-cte + (list 'quote + g1512) + g1510) + (g430 g1512 + g1509)))) + (g101 'tmp)))))) + (list 'quote + (g231 'module + (g409 g1487 + g1509))))) + (g101 g1508))) + (if g1485 + ((lambda (g1513) + ((lambda (g1514) + (if (g90 g1514) + (annotation-expression + g1514) + g1514)) + (if (g204 g1513) + (g205 g1513) + g1513))) + g1485) + '#f)))) + (g190 '#f + (map (lambda (g1517) + (list 'define + g1517 + (g446))) + g1499)) + (g191 '#f + g1502 + g1505 + (g190 '#f + (list (if (null? + g1499) + (g446) + (g190 '#f + (map (lambda (g1516 + g1515) + (list 'set! + g1516 + g1515)) + g1499 + g1507))) + (if (null? + g1506) + (g446) + (g190 '#f + g1506))))) + (g446))))) + (map (lambda (g1530) + (g432 (cdr g1530) + (car g1530) + '(()))) + g1497) + (map (lambda (g1528) + (g432 (cdr g1528) + (car g1528) + '(()))) + g1503) + (map (lambda (g1529) + (g432 (cdr g1529) + (car g1529) + '(()))) + g1493)) + ((lambda (g1531) + ((lambda (g1532) + (if (memv g1532 + '(define-form)) + ((lambda (g1533) + (begin (g424 g1482 + (g302 (g414 g1531)) + (g231 'lexical + g1533)) + (g1501 + (cdr g1504) + (cons g1533 + g1502) + (cons (g416 g1531) + g1503)))) + (g451 (g413 g1531))) + (if (memv g1532 + '(define-syntax-form + module-form)) + (g1501 + (cdr g1504) + g1502 + g1503) + (error 'sc-expand-internal + '"unexpected module binding type")))) + (g412 g1531))) + (car g1504)))))) + g1501) + g1496 + '() + '()) + ((lambda (g1535 g1534) + (letrec ((g1536 + (lambda (g1551 + g1548 + g1550 + g1549) + ((letrec ((g1552 + (lambda (g1554 + g1553) + (if (null? + g1554) + (g1549) + (if (g388 (g413 (car g1554)) + g1551) + (g1550 + (car g1554) + (g370 (reverse + g1553) + (cdr g1554))) + (g1552 + (cdr g1554) + (cons (car g1554) + g1553))))))) + g1552) + g1548 + '())))) + (g1536 + g1535 + g1496 + (lambda (g1538 g1537) + ((lambda (g1541 + g1539 + g1540) + ((lambda (g1543 + g1542) + ((lambda (g1544) + (if (memv g1544 + '(define-form)) + (begin (g303 g1539 + g1542) + (g1495 + g1543 + g1537 + (cons g1542 + g1499) + (cons (g416 g1538) + g1497) + g1498)) + (if (memv g1544 + '(define-syntax-form)) + (g1495 + g1543 + g1537 + g1499 + g1497 + (cons (list g1541 + g1539 + g1542 + (g416 g1538)) + g1498)) + (if (memv g1544 + '(module-form)) + ((lambda (g1545) + (g1495 + (append + (g401 g1545) + g1543) + g1537 + g1499 + g1497 + (cons (list g1541 + g1539 + g1542 + g1545) + g1498))) + (g416 g1538)) + (error 'sc-expand-internal + '"unexpected module binding type"))))) + g1541)) + (append + g1540 + g1534) + (g101 ((lambda (g1546) + ((lambda (g1547) + (if (g90 g1547) + (annotation-expression + g1547) + g1547)) + (if (g204 g1546) + (g205 g1546) + g1546))) + g1535)))) + (g412 g1538) + (g414 g1538) + (g415 g1538))) + (lambda () + (g1495 + g1534 + g1496 + g1499 + g1497 + g1498))))) + (car g1500) + (cdr g1500)))))) + g1495) + g1492 + g1494 + '() + '() + '())))) + (g401 g1487)))) + (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076))) + (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480))) + (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078))) + (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478))) + (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080))) + (g416 (lambda (g1477) (vector-ref g1477 '5))) + (g415 (lambda (g1082) (vector-ref g1082 '4))) + (g414 (lambda (g1476) (vector-ref g1476 '3))) + (g413 (lambda (g1083) (vector-ref g1083 '2))) + (g412 (lambda (g1475) (vector-ref g1475 '1))) + (g411 + (lambda (g1084) + (if (vector? g1084) + (if (= (vector-length g1084) '6) + (eq? (vector-ref g1084 '0) 'module-binding) + '#f) + '#f))) + (g410 + (lambda (g1474 g1470 g1473 g1471 g1472) + (vector 'module-binding g1474 g1470 g1473 g1471 g1472))) + (g409 + (lambda (g1086 g1085) + (g402 (list->vector + (map (lambda (g1087) + (g369 (if (pair? g1087) (car g1087) g1087))) + g1086)) + g1085))) + (g408 + (lambda (g1468) + (g402 (list->vector + (map (lambda (g1469) + (if (pair? g1469) (car g1469) g1469)) + g1468)) + '#f))) + (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088))) + (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466))) + (g405 (lambda (g1090) (vector-ref g1090 '2))) + (g404 (lambda (g1465) (vector-ref g1465 '1))) + (g403 + (lambda (g1091) + (if (vector? g1091) + (if (= (vector-length g1091) '3) + (eq? (vector-ref g1091 '0) 'interface) + '#f) + '#f))) + (g402 + (lambda (g1464 g1463) (vector 'interface g1464 g1463))) + (g401 + (lambda (g1092) + ((letrec ((g1093 + (lambda (g1095 g1094) + (if (null? g1095) + g1094 + (g1093 + (cdr g1095) + (if (pair? (car g1095)) + (g1093 (car g1095) g1094) + (cons (car g1095) g1094))))))) + g1093) + g1092 + '()))) + (g400 + (lambda (g1390 g1385 g1389 g1386 g1388 g1387) + (call-with-values + (lambda () (g398 g1390 g1385 g1389 '#f g1387)) + (lambda (g1401 g1397 g1400 g1398 g1399) + ((lambda (g1402) + (if (memv g1402 '(begin-form)) + ((lambda (g1403) + ((lambda (g1404) + (if g1404 + (apply (lambda (g1405) (g446)) g1404) + ((lambda (g1406) + (if g1406 + (apply + (lambda (g1409 g1407 g1408) + (g396 (cons g1407 g1408) + g1385 + g1398 + g1399 + g1386 + g1388 + g1387)) + g1406) + (syntax-error g1403))) + ($syntax-dispatch + g1403 + '(any any . each-any))))) + ($syntax-dispatch g1403 '(any)))) + g1400) + (if (memv g1402 '(local-syntax-form)) + (g445 g1397 + g1400 + g1385 + g1398 + g1399 + (lambda (g1414 g1411 g1413 g1412) + (g396 g1414 + g1411 + g1413 + g1412 + g1386 + g1388 + g1387))) + (if (memv g1402 '(eval-when-form)) + ((lambda (g1415) + ((lambda (g1416) + (if g1416 + (apply + (lambda (g1420 + g1417 + g1419 + g1418) + ((lambda (g1422 g1421) + (if (eq? g1386 'e) + (if (memq 'eval + g1422) + (g396 g1421 + g1385 + g1398 + g1399 + 'e + '(eval) + g1387) + (g446)) + (if (memq 'load + g1422) + (if ((lambda (g1423) + (if g1423 + g1423 + (if (eq? g1386 + 'c&e) + (memq 'eval + g1422) + '#f))) + (memq 'compile + g1422)) + (g396 g1421 + g1385 + g1398 + g1399 + 'c&e + '(compile + load) + g1387) + (if (memq g1386 + '(c c&e)) + (g396 g1421 + g1385 + g1398 + g1399 + 'c + '(load) + g1387) + (g446))) + (if ((lambda (g1424) + (if g1424 + g1424 + (if (eq? g1386 + 'c&e) + (memq 'eval + g1422) + '#f))) + (memq 'compile + g1422)) + (begin (g91 (g396 g1421 + g1385 + g1398 + g1399 + 'e + '(eval) + g1387)) + (g446)) + (g446))))) + (g397 g1400 g1417 g1398) + (cons g1419 g1418))) + g1416) + (syntax-error g1415))) + ($syntax-dispatch + g1415 + '(any each-any any . each-any)))) + g1400) + (if (memv g1402 '(define-syntax-form)) + (g443 g1400 + g1398 + g1399 + (lambda (g1429 g1427 g1428) + ((lambda (g1430) + (begin ((lambda (g1435) + ((lambda (g1436) + ((lambda (g1437) + (if (memv g1437 + '(displaced-lexical)) + (g250 g1430) + (void))) + (g232 g1436))) + (g253 g1435 + g1385))) + (g377 g1430 + '(()))) + (g431 g1386 + g1388 + (lambda () + (list '$sc-put-cte + (list 'quote + ((lambda (g1431) + (if (g373 (g264 (g206 g1430)) + (g264 '((top)))) + g1431 + ((lambda (g1432) + (g203 g1431 + (g263 g1432 + (list (g304 (vector + g1431) + (vector + g1432) + (vector + (g101 g1431))))))) + (g264 (g206 g1430))))) + ((lambda (g1433) + ((lambda (g1434) + (if (g90 g1434) + (annotation-expression + g1434) + g1434)) + (if (g204 g1433) + (g205 g1433) + g1433))) + g1430))) + (g432 g1427 + (g249 g1385) + g1428)))))) + (g393 g1429 g1428)))) + (if (memv g1402 '(define-form)) + (g442 g1400 + g1398 + g1399 + (lambda (g1440 g1438 g1439) + ((lambda (g1441) + (begin ((lambda (g1448) + ((lambda (g1449) + ((lambda (g1450) + (if (memv g1450 + '(displaced-lexical)) + (g250 g1441) + (void))) + (g232 g1449))) + (g253 g1448 + g1385))) + (g377 g1441 + '(()))) + ((lambda (g1442) + ((lambda (g1443) + (g190 '#f + (list (g431 g1386 + g1388 + (lambda () + (list '$sc-put-cte + (list 'quote + (if (eq? g1442 + g1443) + g1442 + ((lambda (g1445) + (g203 g1442 + (g263 g1445 + (list (g304 (vector + g1442) + (vector + g1445) + (vector + g1443)))))) + (g264 (g206 g1441))))) + (list 'quote + (g231 'global + g1443))))) + ((lambda (g1444) + (begin (if (eq? g1386 + 'c&e) + (g91 g1444) + (void)) + g1444)) + (list 'define + g1443 + (g432 g1438 + g1385 + g1439)))))) + (if (g373 (g264 (g206 g1441)) + (g264 '((top)))) + g1442 + (g101 g1442)))) + ((lambda (g1446) + ((lambda (g1447) + (if (g90 g1447) + (annotation-expression + g1447) + g1447)) + (if (g204 g1446) + (g205 g1446) + g1446))) + g1441)))) + (g393 g1440 g1439)))) + (if (memv g1402 '(module-form)) + ((lambda (g1452 g1451) + (g440 g1400 + g1398 + g1399 + (g263 (g264 g1398) + (cons g1451 + (g265 g1398))) + (lambda (g1455 + g1453 + g1454) + (if g1455 + (begin ((lambda (g1456) + ((lambda (g1457) + ((lambda (g1458) + (if (memv g1458 + '(displaced-lexical)) + (g250 (g393 g1455 + g1398)) + (void))) + (g232 g1457))) + (g253 g1456 + g1452))) + (g377 g1455 + '(()))) + (g422 g1400 + g1452 + g1451 + g1398 + g1399 + g1386 + g1388 + g1455 + g1453 + g1454)) + (g422 g1400 + g1452 + g1451 + g1398 + g1399 + g1386 + g1388 + '#f + g1453 + g1454))))) + (cons '("top-level module placeholder" + placeholder) + g1385) + (g304 '() '() '())) + (if (memv g1402 + '(import-form)) + (g441 g1400 + g1398 + g1399 + (lambda (g1459) + (g431 g1386 + g1388 + (lambda () + (begin (if g1397 + (syntax-error + (g394 g1400 + g1398 + g1399) + '"not valid at top-level") + (void)) + ((lambda (g1460) + ((lambda (g1461) + (if (memv g1461 + '(module)) + (g430 g1459 + (g405 (g233 g1460))) + (if (memv g1461 + '(displaced-lexical)) + (g250 g1459) + (syntax-error + g1459 + '"import from unknown module")))) + (g232 g1460))) + (g253 (g377 g1459 + '(())) + '()))))))) + ((lambda (g1462) + (begin (if (eq? g1386 + 'c&e) + (g91 g1462) + (void)) + g1462)) + (g433 g1401 + g1397 + g1400 + g1385 + g1398 + g1399)))))))))) + g1401))))) + (g399 + (lambda (g1099 g1096 g1098 g1097) + (call-with-values + (lambda () (g398 g1099 g1096 g1098 '#f g1097)) + (lambda (g1104 g1100 g1103 g1101 g1102) + (g433 g1104 g1100 g1103 g1096 g1101 g1102))))) + (g398 + (lambda (g1370 g1366 g1369 g1367 g1368) + (if (symbol? g1370) + ((lambda (g1371) + ((lambda (g1372) + ((lambda (g1373) + ((lambda () + ((lambda (g1374) + (if (memv g1374 '(lexical)) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367) + (if (memv g1374 '(global)) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367) + (if (memv g1374 '(macro macro!)) + (g398 (g436 (g233 g1372) + g1370 + g1366 + g1369 + g1367 + g1368) + g1366 + '(()) + '#f + g1368) + (values + g1373 + (g233 g1372) + g1370 + g1369 + g1367))))) + g1373)))) + (g232 g1372))) + (g253 g1371 g1366))) + (g377 g1370 g1369)) + (if (pair? g1370) + ((lambda (g1375) + (if (g256 g1375) + ((lambda (g1376) + ((lambda (g1377) + ((lambda (g1378) + ((lambda () + ((lambda (g1379) + (if (memv g1379 '(lexical)) + (values + 'lexical-call + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(macro macro!)) + (g398 (g436 (g233 g1377) + g1370 + g1366 + g1369 + g1367 + g1368) + g1366 + '(()) + '#f + g1368) + (if (memv g1379 + '(core)) + (values + g1378 + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(local-syntax)) + (values + 'local-syntax-form + (g233 g1377) + g1370 + g1369 + g1367) + (if (memv g1379 + '(begin)) + (values + 'begin-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(eval-when)) + (values + 'eval-when-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(define)) + (values + 'define-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(define-syntax)) + (values + 'define-syntax-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(module-key)) + (values + 'module-form + '#f + g1370 + g1369 + g1367) + (if (memv g1379 + '(import)) + (values + 'import-form + (if (g233 g1377) + (g393 g1375 + g1369) + '#f) + g1370 + g1369 + g1367) + (if (memv g1379 + '(set!)) + (g435 g1370 + g1366 + g1369 + g1367 + g1368) + (values + 'call + '#f + g1370 + g1369 + g1367))))))))))))) + g1378)))) + (g232 g1377))) + (g253 g1376 g1366))) + (g377 g1375 g1369)) + (values 'call '#f g1370 g1369 g1367))) + (car g1370)) + (if (g204 g1370) + (g398 (g205 g1370) + g1366 + (g371 g1369 (g206 g1370)) + '#f + g1368) + (if (g90 g1370) + (g398 (annotation-expression g1370) + g1366 + g1369 + (annotation-source g1370) + g1368) + (if ((lambda (g1380) + ((lambda (g1381) + (if g1381 + g1381 + ((lambda (g1382) + (if g1382 + g1382 + ((lambda (g1383) + (if g1383 + g1383 + ((lambda (g1384) + (if g1384 + g1384 + (null? + g1380))) + (char? + g1380)))) + (string? g1380)))) + (number? g1380)))) + (boolean? g1380))) + g1370) + (values 'constant '#f g1370 g1369 g1367) + (values + 'other + '#f + g1370 + g1369 + g1367)))))))) + (g397 + (lambda (g1107 g1105 g1106) + ((letrec ((g1108 + (lambda (g1110 g1109) + (if (null? g1110) + g1109 + (g1108 + (cdr g1110) + (cons ((lambda (g1111) + (if (g378 g1111 + '#(syntax-object + compile + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e when-list w) + #((top) + (top) + (top)) + #("i" "i" "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'compile + (if (g378 g1111 + '#(syntax-object + load + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'load + (if (g378 g1111 + '#(syntax-object + eval + ((top) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(when-list + situations) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(e + when-list + w) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + (lambda-var-list + gen-var + strip + strip* + strip-annotation + ellipsis? + chi-void + chi-local-syntax + chi-lambda-clause + parse-define-syntax + parse-define + parse-import + parse-module + do-import! + chi-internal + chi-body + chi-macro + chi-set! + chi-application + chi-expr + chi + ct-eval/residualize + do-top-import + vfor-each + vmap + chi-external + check-defined-ids + check-module-exports + extend-store! + id-set-diff + chi-top-module + set-module-binding-val! + set-module-binding-imps! + set-module-binding-label! + set-module-binding-id! + set-module-binding-type! + module-binding-val + module-binding-imps + module-binding-label + module-binding-id + module-binding-type + module-binding? + make-module-binding + make-resolved-interface + make-trimmed-interface + set-interface-token! + set-interface-exports! + interface-token + interface-exports + interface? + make-interface + flatten-exports + chi-top + chi-top-expr + syntax-type + chi-when-list + chi-top-sequence + chi-sequence + source-wrap + wrap + bound-id-member? + invalid-ids-error + distinct-bound-ids? + valid-bound-ids? + bound-id=? + literal-id=? + free-id=? + id-var-name + id-var-name-loc + id-var-name&marks + id-var-name-loc&marks + same-marks? + join-marks + join-wraps + smart-append + make-trimmed-syntax-object + make-binding-wrap + lookup-import-binding-name + extend-ribcage-subst! + extend-ribcage-barrier-help! + extend-ribcage-barrier! + extend-ribcage! + make-empty-ribcage + import-token-key + import-token? + make-import-token + barrier-marker + new-mark + anti-mark + the-anti-mark + only-top-marked? + top-marked? + top-wrap + empty-wrap + set-ribcage-labels! + set-ribcage-marks! + set-ribcage-symnames! + ribcage-labels + ribcage-marks + ribcage-symnames + ribcage? + make-ribcage + set-indirect-label! + get-indirect-label + indirect-label? + gen-indirect-label + gen-labels + label? + gen-label + make-rename + rename-marks + rename-new + rename-old + subst-rename? + wrap-subst + wrap-marks + make-wrap + id-sym-name&marks + id-sym-name + id? + nonsymbol-id? + global-extend + lookup + sanitize-binding + lookup* + displaced-lexical-error + transformer-env + extend-var-env* + extend-env* + extend-env + null-env + binding? + set-binding-value! + set-binding-type! + binding-value + binding-type + make-binding + arg-check + source-annotation + no-source + unannotate + set-syntax-object-wrap! + set-syntax-object-expression! + syntax-object-wrap + syntax-object-expression + syntax-object? + make-syntax-object + self-evaluating? + build-lexical-var + build-letrec + build-sequence + build-data + build-primref + build-lambda + build-cte-install + build-module-definition + build-global-definition + build-global-assignment + build-global-reference + build-lexical-assignment + build-lexical-reference + build-conditional + build-application + generate-id + get-import-binding + get-global-definition-hook + put-global-definition-hook + gensym-hook + error-hook + local-eval-hook + top-level-eval-hook + annotation? + fx< + fx= + fx- + fx+ + noexpand + define-structure + unless + when) + ((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + ("i" "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + 'eval + (syntax-error + (g393 g1111 g1106) + '"invalid eval-when situation"))))) + (car g1110)) + g1109)))))) + g1108) + g1105 + '()))) + (g396 + (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355) + (g190 g1353 + ((letrec ((g1359 + (lambda (g1364 g1360 g1363 g1361 g1362) + (if (null? g1364) + '() + ((lambda (g1365) + (cons g1365 + (g1359 + (cdr g1364) + g1360 + g1363 + g1361 + g1362))) + (g400 (car g1364) + g1360 + g1363 + g1361 + g1362 + g1355)))))) + g1359) + g1358 + g1352 + g1357 + g1356 + g1354)))) + (g395 + (lambda (g1115 g1112 g1114 g1113) + (g190 g1113 + ((letrec ((g1116 + (lambda (g1119 g1117 g1118) + (if (null? g1119) + '() + ((lambda (g1120) + (cons g1120 + (g1116 + (cdr g1119) + g1117 + g1118))) + (g432 (car g1119) g1117 g1118)))))) + g1116) + g1115 + g1112 + g1114)))) + (g394 + (lambda (g1351 g1349 g1350) + (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351) + g1349))) + (g393 + (lambda (g1122 g1121) + (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f) + g1122 + (if (g204 g1122) + (g203 (g205 g1122) (g371 g1121 (g206 g1122))) + (if (null? g1122) g1122 (g203 g1122 g1121)))))) + (g392 + (lambda (g1347 g1346) + (if (not (null? g1346)) + ((lambda (g1348) + (if g1348 g1348 (g392 g1347 (cdr g1346)))) + (g388 g1347 (car g1346))) + '#f))) + (g391 + (lambda (g1125 g1123 g1124) + ((letrec ((g1126 + (lambda (g1128 g1127) + (if (null? g1128) + (syntax-error g1123) + (if (g256 (car g1128)) + (if (g392 (car g1128) g1127) + (syntax-error + (car g1128) + '"duplicate " + g1124) + (g1126 + (cdr g1128) + (cons (car g1128) g1127))) + (syntax-error + (car g1128) + '"invalid " + g1124)))))) + g1126) + g1125 + '()))) + (g390 + (lambda (g1342) + ((letrec ((g1343 + (lambda (g1344) + ((lambda (g1345) + (if g1345 + g1345 + (if (not (g392 (car g1344) (cdr g1344))) + (g1343 (cdr g1344)) + '#f))) + (null? g1344))))) + g1343) + g1342))) + (g389 + (lambda (g1129) + (if ((letrec ((g1130 + (lambda (g1131) + ((lambda (g1132) + (if g1132 + g1132 + (if (g256 (car g1131)) + (g1130 (cdr g1131)) + '#f))) + (null? g1131))))) + g1130) + g1129) + (g390 g1129) + '#f))) + (g388 + (lambda (g1337 g1336) + (if (if (g204 g1337) (g204 g1336) '#f) + (if (eq? ((lambda (g1339) + (if (g90 g1339) + (annotation-expression g1339) + g1339)) + (g205 g1337)) + ((lambda (g1338) + (if (g90 g1338) + (annotation-expression g1338) + g1338)) + (g205 g1336))) + (g373 (g264 (g206 g1337)) (g264 (g206 g1336))) + '#f) + (eq? ((lambda (g1341) + (if (g90 g1341) + (annotation-expression g1341) + g1341)) + g1337) + ((lambda (g1340) + (if (g90 g1340) + (annotation-expression g1340) + g1340)) + g1336))))) + (g378 + (lambda (g1134 g1133) + (if (eq? ((lambda (g1137) + ((lambda (g1138) + (if (g90 g1138) + (annotation-expression g1138) + g1138)) + (if (g204 g1137) (g205 g1137) g1137))) + g1134) + ((lambda (g1135) + ((lambda (g1136) + (if (g90 g1136) + (annotation-expression g1136) + g1136)) + (if (g204 g1135) (g205 g1135) g1135))) + g1133)) + (eq? (g377 g1134 '(())) (g377 g1133 '(()))) + '#f))) + (g377 + (lambda (g1333 g1332) + (call-with-values + (lambda () (g374 g1333 g1332)) + (lambda (g1335 g1334) + (if (g301 g1335) (g302 g1335) g1335))))) + (g376 + (lambda (g1140 g1139) + (call-with-values + (lambda () (g374 g1140 g1139)) + (lambda (g1142 g1141) g1142)))) + (g375 + (lambda (g1329 g1328) + (call-with-values + (lambda () (g374 g1329 g1328)) + (lambda (g1331 g1330) + (values (if (g301 g1331) (g302 g1331) g1331) g1330))))) + (g374 + (lambda (g1144 g1143) + (letrec ((g1147 + (lambda (g1174 g1170 g1173 g1171 g1172) + ((lambda (g1175) + ((letrec ((g1176 + (lambda (g1177) + (if (= g1177 g1175) + (g1145 + g1174 + (cdr g1170) + g1173) + (if (if (eq? (vector-ref + g1171 + g1177) + g1174) + (g373 g1173 + (vector-ref + (g307 g1172) + g1177)) + '#f) + (values + (vector-ref + (g308 g1172) + g1177) + g1173) + (g1176 (+ g1177 '1))))))) + g1176) + '0)) + (vector-length g1171)))) + (g1146 + (lambda (g1159 g1155 g1158 g1156 g1157) + ((letrec ((g1160 + (lambda (g1162 g1161) + (if (null? g1162) + (g1145 g1159 (cdr g1155) g1158) + (if (if (eq? (car g1162) g1159) + (g373 g1158 + (list-ref + (g307 g1157) + g1161)) + '#f) + (values + (list-ref + (g308 g1157) + g1161) + g1158) + (if (g357 (car g1162)) + ((lambda (g1163) + (if g1163 + ((lambda (g1164) + (if (symbol? + g1164) + (values + g1164 + g1158) + (g375 g1164 + '(())))) + g1163) + (g1160 + (cdr g1162) + g1161))) + (g367 g1159 + (g358 (car g1162)) + g1158)) + (if (if (eq? (car g1162) + g354) + (g373 g1158 + (list-ref + (g307 g1157) + g1161)) + '#f) + (values '#f g1158) + (g1160 + (cdr g1162) + (+ g1161 + '1))))))))) + g1160) + g1156 + '0))) + (g1145 + (lambda (g1167 g1165 g1166) + (if (null? g1165) + (values g1167 g1166) + ((lambda (g1168) + (if (eq? g1168 'shift) + (g1145 g1167 (cdr g1165) (cdr g1166)) + ((lambda (g1169) + (if (vector? g1169) + (g1147 + g1167 + g1165 + g1166 + g1169 + g1168) + (g1146 + g1167 + g1165 + g1166 + g1169 + g1168))) + (g306 g1168)))) + (car g1165)))))) + (if (symbol? g1144) + (g1145 g1144 (g265 g1143) (g264 g1143)) + (if (g204 g1144) + ((lambda (g1149 g1148) + ((lambda (g1150) + (call-with-values + (lambda () + (g1145 g1149 (g265 g1143) g1150)) + (lambda (g1152 g1151) + (if (eq? g1152 g1149) + (g1145 g1149 (g265 g1148) g1151) + (values g1152 g1151))))) + (g372 (g264 g1143) (g264 g1148)))) + ((lambda (g1153) + (if (g90 g1153) + (annotation-expression g1153) + g1153)) + (g205 g1144)) + (g206 g1144)) + (if (g90 g1144) + (g1145 + ((lambda (g1154) + (if (g90 g1154) + (annotation-expression g1154) + g1154)) + g1144) + (g265 g1143) + (g264 g1143)) + (g93 'id-var-name '"invalid id" g1144))))))) + (g373 + (lambda (g1326 g1325) + ((lambda (g1327) + (if g1327 + g1327 + (if (not (null? g1326)) + (if (not (null? g1325)) + (if (eq? (car g1326) (car g1325)) + (g373 (cdr g1326) (cdr g1325)) + '#f) + '#f) + '#f))) + (eq? g1326 g1325)))) + (g372 (lambda (g1179 g1178) (g370 g1179 g1178))) + (g371 + (lambda (g1322 g1321) + ((lambda (g1324 g1323) + (if (null? g1324) + (if (null? g1323) + g1321 + (g263 (g264 g1321) (g370 g1323 (g265 g1321)))) + (g263 (g370 g1324 (g264 g1321)) + (g370 g1323 (g265 g1321))))) + (g264 g1322) + (g265 g1322)))) + (g370 + (lambda (g1181 g1180) + (if (null? g1180) g1181 (append g1181 g1180)))) + (g369 + (lambda (g1315) + (call-with-values + (lambda () (g375 g1315 '(()))) + (lambda (g1317 g1316) + (begin (if (not g1317) + (syntax-error + g1315 + '"identifier not visible for export") + (void)) + ((lambda (g1318) + (g203 g1318 + (g263 g1316 + (list (g304 (vector g1318) + (vector g1316) + (vector g1317)))))) + ((lambda (g1319) + ((lambda (g1320) + (if (g90 g1320) + (annotation-expression g1320) + g1320)) + (if (g204 g1319) (g205 g1319) g1319))) + g1315))))))) + (g368 + (lambda (g1184 g1182 g1183) + (if (null? g1184) + g1183 + (g263 (g264 g1183) + (cons ((lambda (g1185) + ((lambda (g1186) + ((lambda (g1188 g1187) + (begin ((letrec ((g1189 + (lambda (g1191 + g1190) + (if (not (null? + g1191)) + (call-with-values + (lambda () + (g262 (car g1191) + g1183)) + (lambda (g1193 + g1192) + (begin (vector-set! + g1188 + g1190 + g1193) + (vector-set! + g1187 + g1190 + g1192) + (g1189 + (cdr g1191) + (+ g1190 + '1))))) + (void))))) + g1189) + g1184 + '0) + (g304 g1188 g1187 g1185))) + (make-vector g1186) + (make-vector g1186))) + (vector-length g1185))) + (list->vector g1182)) + (g265 g1183)))))) + (g367 + (lambda (g1310 g1308 g1309) + ((lambda (g1311) + (if g1311 + ((letrec ((g1312 + (lambda (g1313) + (if (pair? g1313) + ((lambda (g1314) + (if g1314 + g1314 + (g1312 (cdr g1313)))) + (g1312 (car g1313))) + (if (g373 g1309 (g264 (g206 g1313))) + g1313 + '#f))))) + g1312) + g1311) + '#f)) + (g100 g1310 g1308)))) + (g366 + (lambda (g1195 g1194) + (g309 g1195 (cons (g356 g1194) (g306 g1195))))) + (g365 + (lambda (g1307 g1306) + (begin (g309 g1307 (cons g354 (g306 g1307))) + (g310 g1307 (cons (g264 g1306) (g307 g1307)))))) + (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196)))) + (g363 + (lambda (g1304 g1302 g1303) + (begin (g309 g1304 + (cons ((lambda (g1305) + (if (g90 g1305) + (annotation-expression g1305) + g1305)) + (g205 g1302)) + (g306 g1304))) + (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304))) + (g311 g1304 (cons g1303 (g308 g1304)))))) + (g358 cdr) + (g357 + (lambda (g1301) + (if (pair? g1301) (eq? (car g1301) g355) '#f))) + (g356 (lambda (g1198) (cons g355 g1198))) + (g355 'import-token) + (g354 '#f) + (g349 + (lambda (g1300) + (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300))))) + (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199))) + (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298))) + (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201))) + (g308 (lambda (g1297) (vector-ref g1297 '3))) + (g307 (lambda (g1203) (vector-ref g1203 '2))) + (g306 (lambda (g1296) (vector-ref g1296 '1))) + (g305 + (lambda (g1204) + (if (vector? g1204) + (if (= (vector-length g1204) '4) + (eq? (vector-ref g1204 '0) 'ribcage) + '#f) + '#f))) + (g304 + (lambda (g1295 g1293 g1294) + (vector 'ribcage g1295 g1293 g1294))) + (g303 set-car!) + (g302 car) + (g301 pair?) + (g300 (lambda () (list (g297)))) + (g299 + (lambda (g1205) + (if (null? g1205) '() (cons (g297) (g299 (cdr g1205)))))) + (g298 + (lambda (g1290) + ((lambda (g1291) + (if g1291 + g1291 + ((lambda (g1292) (if g1292 g1292 (g301 g1290))) + (symbol? g1290)))) + (string? g1290)))) + (g297 (lambda () (string '#\i))) + (g265 cdr) + (g264 car) + (g263 cons) + (g262 + (lambda (g1207 g1206) + (if (g204 g1207) + (values + ((lambda (g1208) + (if (g90 g1208) + (annotation-expression g1208) + g1208)) + (g205 g1207)) + (g372 (g264 g1206) (g264 (g206 g1207)))) + (values + ((lambda (g1209) + (if (g90 g1209) + (annotation-expression g1209) + g1209)) + g1207) + (g264 g1206))))) + (g256 + (lambda (g1288) + (if (symbol? g1288) + '#t + (if (g204 g1288) + (symbol? + ((lambda (g1289) + (if (g90 g1289) + (annotation-expression g1289) + g1289)) + (g205 g1288))) + (if (g90 g1288) + (symbol? (annotation-expression g1288)) + '#f))))) + (g255 + (lambda (g1210) + (if (g204 g1210) + (symbol? + ((lambda (g1211) + (if (g90 g1211) + (annotation-expression g1211) + g1211)) + (g205 g1210))) + '#f))) + (g254 + (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286)))) + (g253 + (lambda (g1213 g1212) + (letrec ((g1214 + (lambda (g1221 g1220) + (begin (g234 g1221 (g232 g1220)) + (g235 g1221 (g233 g1220)))))) + ((lambda (g1215) + ((lambda (g1216) + (if (memv g1216 '(deferred)) + (begin (g1214 + g1215 + ((lambda (g1217) + ((lambda (g1218) + (if g1218 + g1218 + (syntax-error + g1217 + '"invalid transformer"))) + (g252 g1217))) + (g92 (g233 g1215)))) + ((lambda (g1219) g1215) (g232 g1215))) + g1215)) + (g232 g1215))) + (g251 g1213 g1212))))) + (g252 + (lambda (g1283) + (if (procedure? g1283) + (g231 'macro g1283) + (if (g236 g1283) + ((lambda (g1284) + (if (memv g1284 '(core macro macro!)) + (if (procedure? (g233 g1283)) g1283 '#f) + (if (memv g1284 '(module)) + (if (g403 (g233 g1283)) g1283 '#f) + g1283))) + (g232 g1283)) + '#f)))) + (g251 + (lambda (g1223 g1222) + ((lambda (g1224) + (if g1224 + (cdr g1224) + (if (symbol? g1223) + ((lambda (g1225) + (if g1225 g1225 (g231 'global g1223))) + (g99 g1223)) + (g231 'displaced-lexical '#f)))) + (assq g1223 g1222)))) + (g250 + (lambda (g1282) + (syntax-error + g1282 + (if (g377 g1282 '(())) + '"identifier out of context" + '"identifier not visible")))) + (g249 + (lambda (g1226) + (if (null? g1226) + '() + ((lambda (g1227) + (if (eq? (cadr g1227) 'lexical) + (g249 (cdr g1226)) + (cons g1227 (g249 (cdr g1226))))) + (car g1226))))) + (g248 + (lambda (g1281 g1279 g1280) + (if (null? g1281) + g1280 + (g248 (cdr g1281) + (cdr g1279) + (g246 (car g1281) + (g231 'lexical (car g1279)) + g1280))))) + (g247 + (lambda (g1230 g1228 g1229) + (if (null? g1230) + g1229 + (g247 (cdr g1230) + (cdr g1228) + (g246 (car g1230) (car g1228) g1229))))) + (g246 + (lambda (g1278 g1276 g1277) + (cons (cons g1278 g1276) g1277))) + (g236 + (lambda (g1231) + (if (pair? g1231) (symbol? (car g1231)) '#f))) + (g235 set-cdr!) + (g234 set-car!) + (g233 cdr) + (g232 car) + (g231 (lambda (g1275 g1274) (cons g1275 g1274))) + (g223 + (lambda (g1232) + (if (g90 g1232) + (annotation-source g1232) + (if (g204 g1232) (g223 (g205 g1232)) '#f)))) + (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272))) + (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233))) + (g206 (lambda (g1271) (vector-ref g1271 '2))) + (g205 (lambda (g1235) (vector-ref g1235 '1))) + (g204 + (lambda (g1270) + (if (vector? g1270) + (if (= (vector-length g1270) '3) + (eq? (vector-ref g1270 '0) 'syntax-object) + '#f) + '#f))) + (g203 + (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236))) + (g191 + (lambda (g1269 g1266 g1268 g1267) + (if (null? g1266) + g1267 + (list 'letrec (map list g1266 g1268) g1267)))) + (g190 + (lambda (g1239 g1238) + (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238)))) + (g101 + ((lambda (g1251) + (letrec ((g1254 + (lambda (g1260) + ((letrec ((g1261 + (lambda (g1263 g1262) + (if (< g1263 g1251) + (list->string + (cons (g1253 g1263) g1262)) + ((lambda (g1265 g1264) + (g1261 + g1264 + (cons (g1253 g1265) + g1262))) + (modulo g1263 g1251) + (quotient g1263 g1251)))))) + g1261) + g1260 + '()))) + (g1253 + (lambda (g1259) (integer->char (+ g1259 '33)))) + (g1252 (lambda () '0))) + ((lambda (g1256 g1255) + (lambda (g1257) + (begin (set! g1255 (+ g1255 '1)) + ((lambda (g1258) g1258) + (string->symbol + (string-append + '"#" + g1256 + (g1254 g1255))))))) + (g1254 (g1252)) + '-1))) + (- '127 '32 '2))) + (g100 (lambda (g1241 g1240) (getprop g1241 g1240))) + (g99 (lambda (g1250) (getprop g1250 '*sc-expander*))) + (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242))) + (g93 + (lambda (g1249 g1247 g1248) + (error g1249 '"~a ~s" g1247 g1248))) + (g92 (lambda (g1244) (eval (list g53 g1244)))) + (g91 (lambda (g1246) (eval (list g53 g1246)))) + (g90 (lambda (g1245) '#f)) + (g53 '"noexpand")) + (begin (set! $sc-put-cte + (lambda (g802 g801) + (letrec ((g805 + (lambda (g831 g830) + ((lambda (g832) + (putprop g832 '*sc-expander* g830)) + (if (symbol? g831) g831 (g377 g831 '(())))))) + (g804 + (lambda (g815 g814) + (g429 (lambda (g816) (g803 g816 g814)) g815))) + (g803 + (lambda (g818 g817) + (letrec ((g820 + (lambda (g828 g827) + (if (pair? g827) + (if (g388 (car g827) g828) + (g820 g828 (cdr g827)) + (g819 (car g827) + (g820 g828 + (cdr g827)))) + (if ((lambda (g829) + (if g829 + g829 + (g388 g827 g828))) + (not g827)) + '#f + g827)))) + (g819 + (lambda (g826 g825) + (if (not g825) + g826 + (cons g826 g825))))) + ((lambda (g821) + ((lambda (g822) + (if (if (not g822) (symbol? g818) '#f) + (remprop g821 g817) + (putprop + g821 + g817 + (g819 g818 g822)))) + (g820 g818 (getprop g821 g817)))) + ((lambda (g823) + ((lambda (g824) + (if (g90 g824) + (annotation-expression g824) + g824)) + (if (g204 g823) (g205 g823) g823))) + g818)))))) + ((lambda (g806) + ((lambda (g807) + (if (memv g807 '(module)) + (begin ((lambda (g808) + (g804 (g404 g808) (g405 g808))) + (g233 g806)) + (g805 g802 g806)) + (if (memv g807 '(do-import)) + ((lambda (g809) + ((lambda (g810) + ((lambda (g811) + (if (memv g811 '(module)) + ((lambda (g812) + (begin (if (not (eq? (g405 g812) + g809)) + (syntax-error + g802 + '"import mismatch for module") + (void)) + (g804 (g404 g812) + '*top*))) + (g233 g810)) + (syntax-error + g802 + '"import from unknown module"))) + (g232 g810))) + (g253 (g377 g802 '(())) '()))) + (g233 g801)) + (g805 g802 g806)))) + (g232 g806))) + ((lambda (g813) + (if g813 + g813 + (error 'define-syntax + '"invalid transformer ~s" + g801))) + (g252 g801)))))) + (g254 'local-syntax 'letrec-syntax '#t) + (g254 'local-syntax 'let-syntax '#f) + (g254 'core + 'fluid-let-syntax + (lambda (g456 g453 g455 g454) + ((lambda (g457) + ((lambda (g458) + (if (if g458 + (apply + (lambda (g463 g459 g462 g460 g461) + (g389 g459)) + g458) + '#f) + (apply + (lambda (g469 g465 g468 g466 g467) + ((lambda (g470) + (begin (for-each + (lambda (g477 g476) + ((lambda (g478) + (if (memv g478 + '(displaced-lexical)) + (g250 (g393 g477 + g455)) + (void))) + (g232 (g253 g476 g453)))) + g465 + g470) + (g437 (cons g466 g467) + (g394 g456 g455 g454) + (g247 g470 + ((lambda (g471) + (map (lambda (g473) + (g231 'deferred + (g432 g473 + g471 + g455))) + g468)) + (g249 g453)) + g453) + g455))) + (map (lambda (g480) (g377 g480 g455)) + g465))) + g458) + ((lambda (g481) + (syntax-error (g394 g456 g455 g454))) + g457))) + ($syntax-dispatch + g457 + '(any #(each (any any)) any . each-any)))) + g456))) + (g254 'core + 'quote + (lambda (g795 g792 g794 g793) + ((lambda (g796) + ((lambda (g797) + (if g797 + (apply + (lambda (g799 g798) + (list 'quote (g450 g798 g794))) + g797) + ((lambda (g800) + (syntax-error (g394 g795 g794 g793))) + g796))) + ($syntax-dispatch g796 '(any any)))) + g795))) + (g254 'core + 'syntax + ((lambda () + (letrec ((g489 + (lambda (g584) + ((lambda (g585) + (if (memv g585 '(ref)) + (cadr g584) + (if (memv g585 '(primitive)) + (cadr g584) + (if (memv g585 '(quote)) + (list 'quote (cadr g584)) + (if (memv g585 '(lambda)) + (list 'lambda + (cadr g584) + (g489 (caddr + g584))) + (if (memv g585 '(map)) + ((lambda (g586) + (cons (if (= (length + g586) + '2) + 'map + 'map) + g586)) + (map g489 + (cdr g584))) + (cons (car g584) + (map g489 + (cdr g584))))))))) + (car g584)))) + (g488 + (lambda (g502) + (if (eq? (car g502) 'list) + (cons 'vector (cdr g502)) + (if (eq? (car g502) 'quote) + (list 'quote + (list->vector (cadr g502))) + (list 'list->vector g502))))) + (g487 + (lambda (g583 g582) + (if (equal? g582 ''()) + g583 + (list 'append g583 g582)))) + (g486 + (lambda (g504 g503) + ((lambda (g505) + (if (memv g505 '(quote)) + (if (eq? (car g504) 'quote) + (list 'quote + (cons (cadr g504) + (cadr g503))) + (if (eq? (cadr g503) '()) + (list 'list g504) + (list 'cons g504 g503))) + (if (memv g505 '(list)) + (cons 'list + (cons g504 (cdr g503))) + (list 'cons g504 g503)))) + (car g503)))) + (g485 + (lambda (g575 g574) + ((lambda (g577 g576) + (if (eq? (car g575) 'ref) + (car g576) + (if (andmap + (lambda (g578) + (if (eq? (car g578) 'ref) + (memq (cadr g578) g577) + '#f)) + (cdr g575)) + (cons 'map + (cons (list 'primitive + (car g575)) + (map ((lambda (g579) + (lambda (g580) + (cdr (assq (cadr g580) + g579)))) + (map cons + g577 + g576)) + (cdr g575)))) + (cons 'map + (cons (list 'lambda + g577 + g575) + g576))))) + (map cdr g574) + (map (lambda (g581) + (list 'ref (car g581))) + g574)))) + (g484 + (lambda (g507 g506) + (list 'apply + '(primitive append) + (g485 g507 g506)))) + (g483 + (lambda (g569 g566 g568 g567) + (if (= g568 '0) + (values g566 g567) + (if (null? g567) + (syntax-error + g569 + '"missing ellipsis in syntax form") + (call-with-values + (lambda () + (g483 g569 + g566 + (- g568 '1) + (cdr g567))) + (lambda (g571 g570) + ((lambda (g572) + (if g572 + (values + (cdr g572) + g567) + ((lambda (g573) + (values + g573 + (cons (cons (cons g571 + g573) + (car g567)) + g570))) + (g451 'tmp)))) + (assq g571 (car g567))))))))) + (g482 + (lambda (g512 g508 g511 g509 g510) + (if (g256 g508) + ((lambda (g513) + ((lambda (g514) + (if (eq? (g232 g514) 'syntax) + (call-with-values + (lambda () + ((lambda (g517) + (g483 g512 + (car g517) + (cdr g517) + g509)) + (g233 g514))) + (lambda (g516 g515) + (values + (list 'ref g516) + g515))) + (if (g510 g508) + (syntax-error + g512 + '"misplaced ellipsis in syntax form") + (values + (list 'quote g508) + g509)))) + (g253 g513 g511))) + (g377 g508 '(()))) + ((lambda (g518) + ((lambda (g519) + (if (if g519 + (apply + (lambda (g521 g520) + (g510 g521)) + g519) + '#f) + (apply + (lambda (g523 g522) + (g482 g512 + g522 + g511 + g509 + (lambda (g524) + '#f))) + g519) + ((lambda (g525) + (if (if g525 + (apply + (lambda (g528 + g526 + g527) + (g510 g526)) + g525) + '#f) + (apply + (lambda (g531 + g529 + g530) + ((letrec ((g532 + (lambda (g534 + g533) + ((lambda (g535) + ((lambda (g536) + (if (if g536 + (apply + (lambda (g538 + g537) + (g510 g538)) + g536) + '#f) + (apply + (lambda (g540 + g539) + (g532 g539 + (lambda (g541) + (call-with-values + (lambda () + (g533 (cons '() + g541))) + (lambda (g543 + g542) + (if (null? + (car g542)) + (syntax-error + g512 + '"extra ellipsis in syntax form") + (values + (g484 g543 + (car g542)) + (cdr g542)))))))) + g536) + ((lambda (g544) + (call-with-values + (lambda () + (g482 g512 + g534 + g511 + g509 + g510)) + (lambda (g546 + g545) + (call-with-values + (lambda () + (g533 g545)) + (lambda (g548 + g547) + (values + (g487 g548 + g546) + g547)))))) + g535))) + ($syntax-dispatch + g535 + '(any . + any)))) + g534)))) + g532) + g530 + (lambda (g549) + (call-with-values + (lambda () + (g482 g512 + g531 + g511 + (cons '() + g549) + g510)) + (lambda (g551 + g550) + (if (null? + (car g550)) + (syntax-error + g512 + '"extra ellipsis in syntax form") + (values + (g485 g551 + (car g550)) + (cdr g550)))))))) + g525) + ((lambda (g552) + (if g552 + (apply + (lambda (g554 + g553) + (call-with-values + (lambda () + (g482 g512 + g554 + g511 + g509 + g510)) + (lambda (g556 + g555) + (call-with-values + (lambda () + (g482 g512 + g553 + g511 + g555 + g510)) + (lambda (g558 + g557) + (values + (g486 g556 + g558) + g557)))))) + g552) + ((lambda (g559) + (if g559 + (apply + (lambda (g561 + g560) + (call-with-values + (lambda () + (g482 g512 + (cons g561 + g560) + g511 + g509 + g510)) + (lambda (g563 + g562) + (values + (g488 g563) + g562)))) + g559) + ((lambda (g565) + (values + (list 'quote + g508) + g509)) + g518))) + ($syntax-dispatch + g518 + '#(vector + (any . + each-any)))))) + ($syntax-dispatch + g518 + '(any . any))))) + ($syntax-dispatch + g518 + '(any any . any))))) + ($syntax-dispatch + g518 + '(any any)))) + g508))))) + (lambda (g493 g490 g492 g491) + ((lambda (g494) + ((lambda (g495) + ((lambda (g496) + (if g496 + (apply + (lambda (g498 g497) + (call-with-values + (lambda () + (g482 g494 + g497 + g490 + '() + g447)) + (lambda (g500 g499) + (g489 g500)))) + g496) + ((lambda (g501) (syntax-error g494)) + g495))) + ($syntax-dispatch g495 '(any any)))) + g494)) + (g394 g493 g492 g491))))))) + (g254 'core + 'lambda + (lambda (g785 g782 g784 g783) + ((lambda (g786) + ((lambda (g787) + (if g787 + (apply + (lambda (g789 g788) + (g444 (g394 g785 g784 g783) + g788 + g782 + g784 + (lambda (g791 g790) + (list 'lambda g791 g790)))) + g787) + (syntax-error g786))) + ($syntax-dispatch g786 '(any . any)))) + g785))) + (g254 'core + 'letrec + (lambda (g590 g587 g589 g588) + ((lambda (g591) + ((lambda (g592) + (if g592 + (apply + (lambda (g597 g593 g596 g594 g595) + ((lambda (g598) + (if (not (g389 g598)) + (g391 (map (lambda (g599) + (g393 g599 g589)) + g598) + (g394 g590 g589 g588) + '"bound variable") + ((lambda (g601 g600) + ((lambda (g603 g602) + (g191 g588 + g600 + (map (lambda (g606) + (g432 g606 + g602 + g603)) + g596) + (g437 (cons g594 g595) + (g394 g590 + g603 + g588) + g602 + g603))) + (g368 g598 g601 g589) + (g248 g601 g600 g587))) + (g299 g598) + (map g451 g598)))) + g593)) + g592) + ((lambda (g608) + (syntax-error (g394 g590 g589 g588))) + g591))) + ($syntax-dispatch + g591 + '(any #(each (any any)) any . each-any)))) + g590))) + (g254 'core + 'if + (lambda (g770 g767 g769 g768) + ((lambda (g771) + ((lambda (g772) + (if g772 + (apply + (lambda (g775 g773 g774) + (list 'if + (g432 g773 g767 g769) + (g432 g774 g767 g769) + (g446))) + g772) + ((lambda (g776) + (if g776 + (apply + (lambda (g780 g777 g779 g778) + (list 'if + (g432 g777 g767 g769) + (g432 g779 g767 g769) + (g432 g778 g767 g769))) + g776) + ((lambda (g781) + (syntax-error + (g394 g770 g769 g768))) + g771))) + ($syntax-dispatch + g771 + '(any any any any))))) + ($syntax-dispatch g771 '(any any any)))) + g770))) + (g254 'set! 'set! '()) + (g254 'begin 'begin '()) + (g254 'module-key 'module '()) + (g254 'import 'import '#f) + (g254 'import 'import-only '#t) + (g254 'define 'define '()) + (g254 'define-syntax 'define-syntax '()) + (g254 'eval-when 'eval-when '()) + (g254 'core + 'syntax-case + ((lambda () + (letrec ((g612 + (lambda (g693 g690 g692 g691) + (if (null? g692) + (list 'syntax-error g693) + ((lambda (g694) + ((lambda (g695) + (if g695 + (apply + (lambda (g697 g696) + (if (if (g256 g697) + (if (not (g392 g697 + g690)) + (not (g447 g697)) + '#f) + '#f) + ((lambda (g699 g698) + (list (list 'lambda + (list g698) + (g432 g696 + (g246 g699 + (g231 'syntax + (cons g698 + '0)) + g691) + (g368 (list g697) + (list g699) + '(())))) + g693)) + (g297) + (g451 g697)) + (g611 g693 + g690 + (cdr g692) + g691 + g697 + '#t + g696))) + g695) + ((lambda (g700) + (if g700 + (apply + (lambda (g703 + g701 + g702) + (g611 g693 + g690 + (cdr g692) + g691 + g703 + g701 + g702)) + g700) + ((lambda (g704) + (syntax-error + (car g692) + '"invalid syntax-case clause")) + g694))) + ($syntax-dispatch + g694 + '(any any any))))) + ($syntax-dispatch + g694 + '(any any)))) + (car g692))))) + (g611 + (lambda (g635 g629 g634 g630 g633 g631 g632) + (call-with-values + (lambda () (g609 g633 g629)) + (lambda (g637 g636) + (if (not (g390 (map car g636))) + (g391 (map car g636) + g633 + '"pattern variable") + (if (not (andmap + (lambda (g638) + (not (g447 (car g638)))) + g636)) + (syntax-error + g633 + '"misplaced ellipsis in syntax-case pattern") + ((lambda (g639) + (list (list 'lambda + (list g639) + (list 'if + ((lambda (g649) + ((lambda (g650) + (if g650 + (apply + (lambda () + g639) + g650) + ((lambda (g651) + (list 'if + g639 + (g610 g636 + g631 + g639 + g630) + (list 'quote + '#f))) + g649))) + ($syntax-dispatch + g649 + '#(atom + #t)))) + g631) + (g610 g636 + g632 + g639 + g630) + (g612 g635 + g629 + g634 + g630))) + (if (eq? g637 'any) + (list 'list g635) + (list '$syntax-dispatch + g635 + (list 'quote + g637))))) + (g451 'tmp)))))))) + (g610 + (lambda (g683 g680 g682 g681) + ((lambda (g685 g684) + ((lambda (g687 g686) + (list 'apply + (list 'lambda + g686 + (g432 g680 + (g247 g687 + (map (lambda (g689 + g688) + (g231 'syntax + (cons g689 + g688))) + g686 + (map cdr + g683)) + g681) + (g368 g685 + g687 + '(())))) + g682)) + (g299 g685) + (map g451 g685))) + (map car g683) + (map cdr g683)))) + (g609 + (lambda (g653 g652) + ((letrec ((g654 + (lambda (g657 g655 g656) + (if (g256 g657) + (if (g392 g657 g652) + (values + (vector + 'free-id + g657) + g656) + (values + 'any + (cons (cons g657 + g655) + g656))) + ((lambda (g658) + ((lambda (g659) + (if (if g659 + (apply + (lambda (g661 + g660) + (g447 g660)) + g659) + '#f) + (apply + (lambda (g663 + g662) + (call-with-values + (lambda () + (g654 g663 + (+ g655 + '1) + g656)) + (lambda (g665 + g664) + (values + (if (eq? g665 + 'any) + 'each-any + (vector + 'each + g665)) + g664)))) + g659) + ((lambda (g666) + (if g666 + (apply + (lambda (g668 + g667) + (call-with-values + (lambda () + (g654 g667 + g655 + g656)) + (lambda (g670 + g669) + (call-with-values + (lambda () + (g654 g668 + g655 + g669)) + (lambda (g672 + g671) + (values + (cons g672 + g670) + g671)))))) + g666) + ((lambda (g673) + (if g673 + (apply + (lambda () + (values + '() + g656)) + g673) + ((lambda (g674) + (if g674 + (apply + (lambda (g675) + (call-with-values + (lambda () + (g654 g675 + g655 + g656)) + (lambda (g677 + g676) + (values + (vector + 'vector + g677) + g676)))) + g674) + ((lambda (g679) + (values + (vector + 'atom + (g450 g657 + '(()))) + g656)) + g658))) + ($syntax-dispatch + g658 + '#(vector + each-any))))) + ($syntax-dispatch + g658 + '())))) + ($syntax-dispatch + g658 + '(any . + any))))) + ($syntax-dispatch + g658 + '(any any)))) + g657))))) + g654) + g653 + '0 + '())))) + (lambda (g616 g613 g615 g614) + ((lambda (g617) + ((lambda (g618) + ((lambda (g619) + (if g619 + (apply + (lambda (g623 g620 g622 g621) + (if (andmap + (lambda (g625) + (if (g256 g625) + (not (g447 g625)) + '#f)) + g622) + ((lambda (g626) + (list (list 'lambda + (list g626) + (g612 g626 + g622 + g621 + g613)) + (g432 g620 + g613 + '(())))) + (g451 'tmp)) + (syntax-error + g617 + '"invalid literals list in"))) + g619) + (syntax-error g618))) + ($syntax-dispatch + g618 + '(any any each-any . each-any)))) + g617)) + (g394 g616 g615 g614))))))) + (set! sc-expand + ((lambda (g763 g761 g762) + ((lambda (g764) + (lambda (g765) + (if (if (pair? g765) (equal? (car g765) g53) '#f) + (cadr g765) + (g400 g765 '() g764 g763 g761 g762)))) + (g263 (g264 '((top))) (cons g762 (g265 '((top))))))) + 'e + '(eval) + ((lambda (g766) (begin (g366 g766 '*top*) g766)) + (g304 '() '() '())))) + (set! identifier? (lambda (g705) (g255 g705))) + (set! datum->syntax-object + (lambda (g759 g758) + (begin ((lambda (g760) + (if (not (g255 g760)) + (g93 'datum->syntax-object + '"invalid argument" + g760) + (void))) + g759) + (g203 g758 (g206 g759))))) + (set! syntax-object->datum + (lambda (g706) (g450 g706 '(())))) + (set! generate-temporaries + (lambda (g755) + (begin ((lambda (g757) + (if (not (list? g757)) + (g93 'generate-temporaries + '"invalid argument" + g757) + (void))) + g755) + (map (lambda (g756) (g393 (gensym) '((top)))) + g755)))) + (set! free-identifier=? + (lambda (g708 g707) + (begin ((lambda (g710) + (if (not (g255 g710)) + (g93 'free-identifier=? + '"invalid argument" + g710) + (void))) + g708) + ((lambda (g709) + (if (not (g255 g709)) + (g93 'free-identifier=? + '"invalid argument" + g709) + (void))) + g707) + (g378 g708 g707)))) + (set! bound-identifier=? + (lambda (g752 g751) + (begin ((lambda (g754) + (if (not (g255 g754)) + (g93 'bound-identifier=? + '"invalid argument" + g754) + (void))) + g752) + ((lambda (g753) + (if (not (g255 g753)) + (g93 'bound-identifier=? + '"invalid argument" + g753) + (void))) + g751) + (g388 g752 g751)))) + (set! syntax-error + (lambda (g711 . g712) + (begin (for-each + (lambda (g714) + ((lambda (g715) + (if (not (string? g715)) + (g93 'syntax-error + '"invalid argument" + g715) + (void))) + g714)) + g712) + ((lambda (g713) (g93 '#f g713 (g450 g711 '(())))) + (if (null? g712) + '"invalid syntax" + (apply string-append g712)))))) + ((lambda () + (letrec ((g720 + (lambda (g748 g745 g747 g746) + (if (not g746) + '#f + (if (eq? g745 'any) + (cons (g393 g748 g747) g746) + (if (g204 g748) + (g719 ((lambda (g749) + (if (g90 g749) + (annotation-expression + g749) + g749)) + (g205 g748)) + g745 + (g371 g747 (g206 g748)) + g746) + (g719 ((lambda (g750) + (if (g90 g750) + (annotation-expression + g750) + g750)) + g748) + g745 + g747 + g746)))))) + (g719 + (lambda (g728 g725 g727 g726) + (if (null? g725) + (if (null? g728) g726 '#f) + (if (pair? g725) + (if (pair? g728) + (g720 (car g728) + (car g725) + g727 + (g720 (cdr g728) + (cdr g725) + g727 + g726)) + '#f) + (if (eq? g725 'each-any) + ((lambda (g729) + (if g729 (cons g729 g726) '#f)) + (g717 g728 g727)) + ((lambda (g730) + (if (memv g730 '(each)) + (if (null? g728) + (g718 (vector-ref + g725 + '1) + g726) + ((lambda (g731) + (if g731 + ((letrec ((g732 + (lambda (g733) + (if (null? + (car g733)) + g726 + (cons (map car + g733) + (g732 (map cdr + g733))))))) + g732) + g731) + '#f)) + (g716 g728 + (vector-ref + g725 + '1) + g727))) + (if (memv g730 '(free-id)) + (if (g256 g728) + (if (g378 (g393 g728 + g727) + (vector-ref + g725 + '1)) + g726 + '#f) + '#f) + (if (memv g730 '(atom)) + (if (equal? + (vector-ref + g725 + '1) + (g450 g728 + g727)) + g726 + '#f) + (if (memv g730 + '(vector)) + (if (vector? + g728) + (g720 (vector->list + g728) + (vector-ref + g725 + '1) + g727 + g726) + '#f) + (void)))))) + (vector-ref g725 '0))))))) + (g718 + (lambda (g743 g742) + (if (null? g743) + g742 + (if (eq? g743 'any) + (cons '() g742) + (if (pair? g743) + (g718 (car g743) + (g718 (cdr g743) g742)) + (if (eq? g743 'each-any) + (cons '() g742) + ((lambda (g744) + (if (memv g744 '(each)) + (g718 (vector-ref + g743 + '1) + g742) + (if (memv g744 + '(free-id + atom)) + g742 + (if (memv g744 + '(vector)) + (g718 (vector-ref + g743 + '1) + g742) + (void))))) + (vector-ref g743 '0)))))))) + (g717 + (lambda (g735 g734) + (if (g90 g735) + (g717 (annotation-expression g735) g734) + (if (pair? g735) + ((lambda (g736) + (if g736 + (cons (g393 (car g735) g734) + g736) + '#f)) + (g717 (cdr g735) g734)) + (if (null? g735) + '() + (if (g204 g735) + (g717 (g205 g735) + (g371 g734 (g206 g735))) + '#f)))))) + (g716 + (lambda (g739 g737 g738) + (if (g90 g739) + (g716 (annotation-expression g739) + g737 + g738) + (if (pair? g739) + ((lambda (g740) + (if g740 + ((lambda (g741) + (if g741 + (cons g740 g741) + '#f)) + (g716 (cdr g739) g737 g738)) + '#f)) + (g720 (car g739) g737 g738 '())) + (if (null? g739) + '() + (if (g204 g739) + (g716 (g205 g739) + g737 + (g371 g738 (g206 g739))) + '#f))))))) + (set! $syntax-dispatch + (lambda (g722 g721) + (if (eq? g721 'any) + (list g722) + (if (g204 g722) + (g719 ((lambda (g723) + (if (g90 g723) + (annotation-expression g723) + g723)) + (g205 g722)) + g721 + (g206 g722) + '()) + (g719 ((lambda (g724) + (if (g90 g724) + (annotation-expression g724) + g724)) + g722) + g721 + '(()) + '())))))))))))) +($sc-put-cte + 'with-syntax + (lambda (g1828) + ((lambda (g1829) + ((lambda (g1830) + (if g1830 + (apply + (lambda (g1833 g1831 g1832) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ e1 e2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + (cons g1831 g1832))) + g1830) + ((lambda (g1835) + (if g1835 + (apply + (lambda (g1840 g1836 g1839 g1837 g1838) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g1839 + '() + (list g1836 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1837 g1838))))) + g1835) + ((lambda (g1842) + (if g1842 + (apply + (lambda (g1847 g1843 g1846 g1844 g1845) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g1846) + '() + (list g1843 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(_ out in e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1844 g1845))))) + g1842) + (syntax-error g1829))) + ($syntax-dispatch + g1829 + '(any #(each (any any)) any . each-any))))) + ($syntax-dispatch + g1829 + '(any ((any any)) any . each-any))))) + ($syntax-dispatch g1829 '(any () any . each-any)))) + g1828))) +($sc-put-cte + 'syntax-rules + (lambda (g1851) + ((lambda (g1852) + ((lambda (g1853) + (if g1853 + (apply + (lambda (g1858 g1854 g1857 g1855 g1856) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + (cons '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + x + ((top) + #(ribcage + #(_ k keyword pattern template) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1854 + (map (lambda (g1861 g1860) + (list (cons '#(syntax-object + dummy + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1860) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + k + keyword + pattern + template) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1861))) + g1856 + g1855)))))) + g1853) + (syntax-error g1852))) + ($syntax-dispatch + g1852 + '(any each-any . #(each ((any . any) any)))))) + g1851))) +($sc-put-cte + 'or + (lambda (g1862) + ((lambda (g1863) + ((lambda (g1864) + (if g1864 + (apply + (lambda (g1865) + '#(syntax-object + #f + ((top) + #(ribcage #(_) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + g1864) + ((lambda (g1866) + (if g1866 + (apply (lambda (g1868 g1867) g1867) g1866) + ((lambda (g1869) + (if g1869 + (apply + (lambda (g1873 g1870 g1872 g1871) + (list '#(syntax-object + let + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1870)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '#(syntax-object + or + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1872 g1871))))) + g1869) + (syntax-error g1863))) + ($syntax-dispatch g1863 '(any any any . each-any))))) + ($syntax-dispatch g1863 '(any any))))) + ($syntax-dispatch g1863 '(any)))) + g1862))) +($sc-put-cte + 'and + (lambda (g1875) + ((lambda (g1876) + ((lambda (g1877) + (if g1877 + (apply + (lambda (g1881 g1878 g1880 g1879) + (cons '#(syntax-object + if + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + (cons g1878 + (cons (cons '#(syntax-object + and + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1880 g1879)) + '(#(syntax-object + #f + ((top) + #(ribcage + #(_ e1 e2 e3) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))))))) + g1877) + ((lambda (g1883) + (if g1883 + (apply (lambda (g1885 g1884) g1884) g1883) + ((lambda (g1886) + (if g1886 + (apply + (lambda (g1887) + '#(syntax-object + #t + ((top) + #(ribcage #(_) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + g1886) + (syntax-error g1876))) + ($syntax-dispatch g1876 '(any))))) + ($syntax-dispatch g1876 '(any any))))) + ($syntax-dispatch g1876 '(any any any . each-any)))) + g1875))) +($sc-put-cte + 'let + (lambda (g1888) + ((lambda (g1889) + ((lambda (g1890) + (if (if g1890 + (apply + (lambda (g1895 g1891 g1894 g1892 g1893) + (andmap identifier? g1891)) + g1890) + '#f) + (apply + (lambda (g1901 g1897 g1900 g1898 g1899) + (cons (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ x v e1 e2) + #((top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g1897 (cons g1898 g1899))) + g1900)) + g1890) + ((lambda (g1905) + (if (if g1905 + (apply + (lambda (g1911 g1906 g1910 g1907 g1909 g1908) + (andmap identifier? (cons g1906 g1910))) + g1905) + '#f) + (apply + (lambda (g1918 g1913 g1917 g1914 g1916 g1915) + (cons (list '#(syntax-object + letrec + ((top) + #(ribcage + #(_ f x v e1 e2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list g1913 + (cons '#(syntax-object + lambda + ((top) + #(ribcage + #(_ + f + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1917 + (cons g1916 + g1915))))) + g1913) + g1914)) + g1905) + (syntax-error g1889))) + ($syntax-dispatch + g1889 + '(any any #(each (any any)) any . each-any))))) + ($syntax-dispatch + g1889 + '(any #(each (any any)) any . each-any)))) + g1888))) +($sc-put-cte + 'let* + (lambda (g1922) + ((lambda (g1923) + ((lambda (g1924) + (if (if g1924 + (apply + (lambda (g1929 g1925 g1928 g1926 g1927) + (andmap identifier? g1925)) + g1924) + '#f) + (apply + (lambda (g1935 g1931 g1934 g1932 g1933) + ((letrec ((g1936 + (lambda (g1937) + (if (null? g1937) + (cons '#(syntax-object + let + ((top) + #(ribcage () () ()) + #(ribcage + #(bindings) + #((top)) + #("i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(let* x v e1 e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons '() (cons g1932 g1933))) + ((lambda (g1939) + ((lambda (g1940) + (if g1940 + (apply + (lambda (g1942 g1941) + (list '#(syntax-object + let + ((top) + #(ribcage + #(body + binding) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(bindings) + #((top)) + #("i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(let* + x + v + e1 + e2) + #((top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list g1941) + g1942)) + g1940) + (syntax-error g1939))) + ($syntax-dispatch + g1939 + '(any any)))) + (list (g1936 (cdr g1937)) + (car g1937))))))) + g1936) + (map list g1931 g1934))) + g1924) + (syntax-error g1923))) + ($syntax-dispatch + g1923 + '(any #(each (any any)) any . each-any)))) + g1922))) +($sc-put-cte + 'cond + (lambda (g1945) + ((lambda (g1946) + ((lambda (g1947) + (if g1947 + (apply + (lambda (g1950 g1948 g1949) + ((letrec ((g1951 + (lambda (g1953 g1952) + (if (null? g1952) + ((lambda (g1954) + ((lambda (g1955) + (if g1955 + (apply + (lambda (g1957 g1956) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ m1 m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1957 g1956))) + g1955) + ((lambda (g1959) + (if g1959 + (apply + (lambda (g1960) + (cons '#(syntax-object + let + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1960)) + '((#(syntax-object + if + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))) + g1959) + ((lambda (g1961) + (if g1961 + (apply + (lambda (g1963 + g1962) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1963)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1962 + '(#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))) + g1961) + ((lambda (g1964) + (if g1964 + (apply + (lambda (g1967 + g1965 + g1966) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1967 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1965 + g1966)))) + g1964) + ((lambda (g1969) + (syntax-error + g1945)) + g1954))) + ($syntax-dispatch + g1954 + '(any any + . + each-any))))) + ($syntax-dispatch + g1954 + '(any #(free-id + #(syntax-object + => + ((top) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g1954 + '(any))))) + ($syntax-dispatch + g1954 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(clause clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ m1 m2) + #((top) (top) (top)) + #("i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any + . + each-any)))) + g1953) + ((lambda (g1970) + ((lambda (g1971) + ((lambda (g1972) + ((lambda (g1973) + (if g1973 + (apply + (lambda (g1974) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1974)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0) + #((top)) + #("i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1971))) + g1973) + ((lambda (g1975) + (if g1975 + (apply + (lambda (g1977 + g1976) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1977)) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1976 + '(#(syntax-object + t + ((top) + #(ribcage + #(e0 + e1) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))) + g1971))) + g1975) + ((lambda (g1978) + (if g1978 + (apply + (lambda (g1981 + g1979 + g1980) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1981 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e0 + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g1979 + g1980)) + g1971)) + g1978) + ((lambda (g1983) + (syntax-error + g1945)) + g1972))) + ($syntax-dispatch + g1972 + '(any any + . + each-any))))) + ($syntax-dispatch + g1972 + '(any #(free-id + #(syntax-object + => + ((top) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + m1 + m2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g1972 + '(any)))) + g1953)) + g1970)) + (g1951 (car g1952) (cdr g1952))))))) + g1951) + g1948 + g1949)) + g1947) + (syntax-error g1946))) + ($syntax-dispatch g1946 '(any any . each-any)))) + g1945))) +($sc-put-cte + 'do + (lambda (g1985) + ((lambda (g1986) + ((lambda (g1987) + (if g1987 + (apply + (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991) + ((lambda (g1995) + ((lambda (g2005) + (if g2005 + (apply + (lambda (g2006) + ((lambda (g2007) + ((lambda (g2009) + (if g2009 + (apply + (lambda () + (list '#(syntax-object + let + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (map list g1988 g1993) + (list '#(syntax-object + if + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + not + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1992) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (append + g1991 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2006))))))) + g2009) + ((lambda (g2014) + (if g2014 + (apply + (lambda (g2016 g2015) + (list '#(syntax-object + let + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (map list + g1988 + g1993) + (list '#(syntax-object + if + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g1992 + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2016 + g2015)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (append + g1991 + (list (cons '#(syntax-object + doloop + ((top) + #(ribcage + #(e1 + e2) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(step) + #((top)) + #("i")) + #(ribcage + #(_ + var + init + step + e0 + e1 + c) + #((top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(orig-x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2006))))))) + g2014) + (syntax-error g2007))) + ($syntax-dispatch + g2007 + '(any . each-any))))) + ($syntax-dispatch g2007 '()))) + g1990)) + g2005) + (syntax-error g1995))) + ($syntax-dispatch g1995 'each-any))) + (map (lambda (g1999 g1998) + ((lambda (g2000) + ((lambda (g2001) + (if g2001 + (apply (lambda () g1999) g2001) + ((lambda (g2002) + (if g2002 + (apply + (lambda (g2003) g2003) + g2002) + ((lambda (g2004) + (syntax-error g1985)) + g2000))) + ($syntax-dispatch g2000 '(any))))) + ($syntax-dispatch g2000 '()))) + g1998)) + g1988 + g1989))) + g1987) + (syntax-error g1986))) + ($syntax-dispatch + g1986 + '(any #(each (any any . any)) + (any . each-any) + . + each-any)))) + g1985))) +($sc-put-cte + 'quasiquote + (letrec ((g2030 + (lambda (g2142) + (if (identifier? g2142) + (free-identifier=? + g2142 + '#(syntax-object + quote + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2022 + (lambda (g2036) + (if (identifier? g2036) + (free-identifier=? + g2036 + '#(syntax-object + list + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2029 + (lambda (g2141) + (if (identifier? g2141) + (free-identifier=? + g2141 + '#(syntax-object + cons + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + '#f))) + (g2023 + (lambda (g2037) + ((lambda (g2038) + ((lambda (g2039) + (if g2039 + (apply (lambda (g2040) (g2030 g2040)) g2039) + ((lambda (g2041) '#f) g2038))) + ($syntax-dispatch g2038 '(any ())))) + g2037))) + (g2028 + (lambda (g2138 g2137) + ((letrec ((g2139 + (lambda (g2140) + (if (null? g2140) + g2137 + (g2024 (car g2140) (g2139 (cdr g2140))))))) + g2139) + g2138))) + (g2024 + (lambda (g2043 g2042) + ((lambda (g2044) + ((lambda (g2045) + (if g2045 + (apply + (lambda (g2047 g2046) + ((lambda (g2048) + ((lambda (g2049) + (if (if g2049 + (apply + (lambda (g2051 g2050) + (g2030 g2051)) + g2049) + '#f) + (apply + (lambda (g2053 g2052) + ((lambda (g2054) + ((lambda (g2055) + (if (if g2055 + (apply + (lambda (g2057 + g2056) + (g2030 g2057)) + g2055) + '#f) + (apply + (lambda (g2059 g2058) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? + dx) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2058 + g2052))) + g2055) + ((lambda (g2060) + (if (null? g2052) + (list '#(syntax-object + list + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(quote? + dy) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x + y) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047 + g2046))) + g2054))) + ($syntax-dispatch + g2054 + '(any any)))) + g2047)) + g2049) + ((lambda (g2061) + (if (if g2061 + (apply + (lambda (g2063 g2062) + (g2022 g2063)) + g2061) + '#f) + (apply + (lambda (g2065 g2064) + (cons '#(syntax-object + list + ((top) + #(ribcage + #(listp stuff) + #((top) (top)) + #("i" "i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2047 g2064))) + g2061) + ((lambda (g2066) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2047 + g2046)) + g2048))) + ($syntax-dispatch + g2048 + '(any . any))))) + ($syntax-dispatch g2048 '(any any)))) + g2046)) + g2045) + (syntax-error g2044))) + ($syntax-dispatch g2044 '(any any)))) + (list g2043 g2042)))) + (g2027 + (lambda (g2129 g2128) + ((lambda (g2130) + (if (null? g2130) + '(#(syntax-object + quote + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(ls) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x y) #((top) (top)) #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ()))) + ()) + (if (null? (cdr g2130)) + (car g2130) + ((lambda (g2131) + ((lambda (g2132) + (if g2132 + (apply + (lambda (g2133) + (cons '#(syntax-object + append + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(ls) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x y) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2133)) + g2132) + (syntax-error g2131))) + ($syntax-dispatch g2131 'each-any))) + g2130)))) + ((letrec ((g2135 + (lambda (g2136) + (if (null? g2136) + (if (g2023 g2128) '() (list g2128)) + (if (g2023 (car g2136)) + (g2135 (cdr g2136)) + (cons (car g2136) + (g2135 (cdr g2136)))))))) + g2135) + g2129)))) + (g2025 + (lambda (g2067) + ((lambda (g2068) + ((lambda (g2069) + ((lambda (g2070) + ((lambda (g2071) + (if (if g2071 + (apply + (lambda (g2073 g2072) (g2030 g2073)) + g2071) + '#f) + (apply + (lambda (g2075 g2074) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? x) + #((top) (top)) + #("i" "i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list->vector g2074))) + g2071) + ((lambda (g2077) + ((letrec ((g2078 + (lambda (g2080 g2079) + ((lambda (g2081) + ((lambda (g2082) + (if (if g2082 + (apply + (lambda (g2084 + g2083) + (g2030 + g2084)) + g2082) + '#f) + (apply + (lambda (g2086 + g2085) + (g2079 + (map (lambda (g2087) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(quote? + x) + #((top) + (top)) + #("i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x + k) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2087)) + g2085))) + g2082) + ((lambda (g2088) + (if (if g2088 + (apply + (lambda (g2090 + g2089) + (g2022 + g2090)) + g2088) + '#f) + (apply + (lambda (g2092 + g2091) + (g2079 + g2091)) + g2088) + ((lambda (g2094) + (if (if g2094 + (apply + (lambda (g2097 + g2095 + g2096) + (g2029 + g2097)) + g2094) + '#f) + (apply + (lambda (g2100 + g2098 + g2099) + (g2078 + g2099 + (lambda (g2101) + (g2079 + (cons g2098 + g2101))))) + g2094) + ((lambda (g2102) + (list '#(syntax-object + list->vector + ((top) + #(ribcage + #(else) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(x + k) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2069)) + g2081))) + ($syntax-dispatch + g2081 + '(any any + any))))) + ($syntax-dispatch + g2081 + '(any . + each-any))))) + ($syntax-dispatch + g2081 + '(any each-any)))) + g2080)))) + g2078) + g2067 + (lambda (g2103) + (cons '#(syntax-object + vector + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(ls) + #((top)) + #("i")) + #(ribcage + #(_) + #((top)) + #("i")) + #(ribcage + #(pat-x) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2103)))) + g2070))) + ($syntax-dispatch g2070 '(any each-any)))) + g2069)) + g2068)) + g2067))) + (g2026 + (lambda (g2105 g2104) + ((lambda (g2106) + ((lambda (g2107) + (if g2107 + (apply + (lambda (g2108) + (if (= g2104 '0) + g2108 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + unquote + ((top) + #(ribcage #(p) #((top)) #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (g2026 (list g2108) (- g2104 '1))))) + g2107) + ((lambda (g2109) + (if g2109 + (apply + (lambda (g2111 g2110) + (if (= g2104 '0) + (g2028 g2111 (g2026 g2110 g2104)) + (g2024 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + unquote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (g2026 g2111 (- g2104 '1))) + (g2026 g2110 g2104)))) + g2109) + ((lambda (g2114) + (if g2114 + (apply + (lambda (g2116 g2115) + (if (= g2104 '0) + (g2027 + g2116 + (g2026 g2115 g2104)) + (g2024 + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + unquote-splicing + ((top) + #(ribcage + #(p q) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + (g2026 + g2116 + (- g2104 '1))) + (g2026 g2115 g2104)))) + g2114) + ((lambda (g2119) + (if g2119 + (apply + (lambda (g2120) + (g2024 + '(#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + quasiquote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))) + (g2026 + (list g2120) + (+ g2104 '1)))) + g2119) + ((lambda (g2121) + (if g2121 + (apply + (lambda (g2123 g2122) + (g2024 + (g2026 + g2123 + g2104) + (g2026 + g2122 + g2104))) + g2121) + ((lambda (g2124) + (if g2124 + (apply + (lambda (g2125) + (g2025 + (g2026 + g2125 + g2104))) + g2124) + ((lambda (g2127) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(p) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(p + lev) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2127)) + g2106))) + ($syntax-dispatch + g2106 + '#(vector + each-any))))) + ($syntax-dispatch + g2106 + '(any . any))))) + ($syntax-dispatch + g2106 + '(#(free-id + #(syntax-object + quasiquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any))))) + ($syntax-dispatch + g2106 + '((#(free-id + #(syntax-object + unquote-splicing + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + . + each-any) + . + any))))) + ($syntax-dispatch + g2106 + '((#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage + #(p lev) + #((top) (top)) + #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + . + each-any) + . + any))))) + ($syntax-dispatch + g2106 + '(#(free-id + #(syntax-object + unquote + ((top) + #(ribcage () () ()) + #(ribcage #(p lev) #((top) (top)) #("i" "i")) + #(ribcage + #(isquote? + islist? + iscons? + quote-nil? + quasilist* + quasicons + quasiappend + quasivector + quasi) + #((top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i" "i" "i" "i")) + #(ribcage ((import-token . *top*)) () ())))) + any)))) + g2105)))) + (lambda (g2031) + ((lambda (g2032) + ((lambda (g2033) + (if g2033 + (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033) + (syntax-error g2032))) + ($syntax-dispatch g2032 '(any any)))) + g2031)))) +($sc-put-cte + 'include + (lambda (g2143) + (letrec ((g2144 + (lambda (g2155 g2154) + ((lambda (g2156) + ((letrec ((g2157 + (lambda () + ((lambda (g2158) + (if (eof-object? g2158) + (begin (close-input-port g2156) '()) + (cons (datum->syntax-object + g2154 + g2158) + (g2157)))) + (read g2156))))) + g2157))) + (open-input-file g2155))))) + ((lambda (g2145) + ((lambda (g2146) + (if g2146 + (apply + (lambda (g2148 g2147) + ((lambda (g2149) + ((lambda (g2150) + ((lambda (g2151) + (if g2151 + (apply + (lambda (g2152) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(exp) + #((top)) + #("i")) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(fn) + #((top)) + #("i")) + #(ribcage + #(k filename) + #((top) (top)) + #("i" "i")) + #(ribcage + (read-file) + ((top)) + ("i")) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2152)) + g2151) + (syntax-error g2150))) + ($syntax-dispatch g2150 'each-any))) + (g2144 g2149 g2148))) + (syntax-object->datum g2147))) + g2146) + (syntax-error g2145))) + ($syntax-dispatch g2145 '(any any)))) + g2143)))) +($sc-put-cte + 'unquote + (lambda (g2159) + ((lambda (g2160) + ((lambda (g2161) + (if g2161 + (apply + (lambda (g2163 g2162) + (syntax-error + g2159 + '"expression not valid outside of quasiquote")) + g2161) + (syntax-error g2160))) + ($syntax-dispatch g2160 '(any . each-any)))) + g2159))) +($sc-put-cte + 'unquote-splicing + (lambda (g2164) + ((lambda (g2165) + ((lambda (g2166) + (if g2166 + (apply + (lambda (g2168 g2167) + (syntax-error + g2164 + '"expression not valid outside of quasiquote")) + g2166) + (syntax-error g2165))) + ($syntax-dispatch g2165 '(any . each-any)))) + g2164))) +($sc-put-cte + 'case + (lambda (g2169) + ((lambda (g2170) + ((lambda (g2171) + (if g2171 + (apply + (lambda (g2175 g2172 g2174 g2173) + ((lambda (g2176) + ((lambda (g2203) + (list '#(syntax-object + let + ((top) + #(ribcage #(body) #((top)) #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (list (list '#(syntax-object + t + ((top) + #(ribcage + #(body) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) (top) (top) (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2172)) + g2203)) + g2176)) + ((letrec ((g2177 + (lambda (g2179 g2178) + (if (null? g2178) + ((lambda (g2180) + ((lambda (g2181) + (if g2181 + (apply + (lambda (g2183 g2182) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(e1 e2) + #((top) + (top)) + #("i" "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2183 + g2182))) + g2181) + ((lambda (g2185) + (if g2185 + (apply + (lambda (g2188 + g2186 + g2187) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2188)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2186 + g2187)))) + g2185) + ((lambda (g2191) + (syntax-error + g2169)) + g2180))) + ($syntax-dispatch + g2180 + '(each-any + any + . + each-any))))) + ($syntax-dispatch + g2180 + '(#(free-id + #(syntax-object + else + ((top) + #(ribcage () () ()) + #(ribcage + #(clause clauses) + #((top) (top)) + #("i" "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ e m1 m2) + #((top) + (top) + (top) + (top)) + #("i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + any + . + each-any)))) + g2179) + ((lambda (g2192) + ((lambda (g2193) + ((lambda (g2194) + ((lambda (g2195) + (if g2195 + (apply + (lambda (g2198 + g2196 + g2197) + (list '#(syntax-object + if + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + memv + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + '#(syntax-object + t + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + quote + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2198)) + (cons '#(syntax-object + begin + ((top) + #(ribcage + #(k + e1 + e2) + #((top) + (top) + (top)) + #("i" + "i" + "i")) + #(ribcage + #(rest) + #((top)) + #("i")) + #(ribcage + () + () + ()) + #(ribcage + #(clause + clauses) + #((top) + (top)) + #("i" + "i")) + #(ribcage + #(f) + #((top)) + #("i")) + #(ribcage + #(_ + e + m1 + m2) + #((top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2196 + g2197)) + g2193)) + g2195) + ((lambda (g2201) + (syntax-error + g2169)) + g2194))) + ($syntax-dispatch + g2194 + '(each-any + any + . + each-any)))) + g2179)) + g2192)) + (g2177 (car g2178) (cdr g2178))))))) + g2177) + g2174 + g2173))) + g2171) + (syntax-error g2170))) + ($syntax-dispatch g2170 '(any any any . each-any)))) + g2169))) +($sc-put-cte + 'identifier-syntax + (lambda (g2204) + ((lambda (g2205) + ((lambda (g2206) + (if g2206 + (apply + (lambda (g2208 g2207) + (list '#(syntax-object + lambda + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ()))) + '(#(syntax-object + x + ((top) + #(ribcage #(_ e) #((top) (top)) #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '() + (list '#(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + identifier? + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + id + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + g2207)) + (list (cons g2208 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + (cons g2207 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ e) + #((top) (top)) + #("i" "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ())))))))))) + g2206) + ((lambda (g2209) + (if (if g2209 + (apply + (lambda (g2215 g2210 g2214 g2211 g2213 g2212) + (if (identifier? g2210) + (identifier? g2211) + '#f)) + g2209) + '#f) + (apply + (lambda (g2221 g2216 g2220 g2217 g2219 g2218) + (list '#(syntax-object + cons + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) (top) (top) (top) (top) (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + quote + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + #(syntax-object + macro! + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list '#(syntax-object + lambda + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + x + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" "i" "i" "i" "i" "i")) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list '#(syntax-object + syntax-case + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '#(syntax-object + x + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ()))) + '(#(syntax-object + set! + ((top) + #(ribcage + #(_ id exp1 var val exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage () () ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token . *top*)) + () + ())))) + (list (list '#(syntax-object + set! + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2217 + g2219) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2218)) + (list (cons g2216 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (cons g2220 + '(#(syntax-object + x + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + #(syntax-object + ... + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))))))) + (list g2216 + (list '#(syntax-object + identifier? + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2216)) + (list '#(syntax-object + syntax + ((top) + #(ribcage + #(_ + id + exp1 + var + val + exp2) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i" + "i" + "i" + "i" + "i" + "i")) + #(ribcage + () + () + ()) + #(ribcage + #(x) + #((top)) + #("i")) + #(ribcage + ((import-token + . + *top*)) + () + ()))) + g2220)))))) + g2209) + (syntax-error g2205))) + ($syntax-dispatch + g2205 + '(any (any any) + ((#(free-id + #(syntax-object + set! + ((top) + #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i")) + #(ribcage ((import-token . *top*)) () ())))) + any + any) + any)))))) + ($syntax-dispatch g2205 '(any any)))) + g2204))) diff --git a/module/language/r5rs/psyntax.ss b/module/language/r5rs/psyntax.ss new file mode 100644 index 000000000..c8ac3e503 --- /dev/null +++ b/module/language/r5rs/psyntax.ss @@ -0,0 +1,3202 @@ +;;; Portable implementation of syntax-case +;;; Extracted from Chez Scheme Version 6.3 +;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman + +;;; Copyright (c) 1992-2000 Cadence Research Systems +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. This software +;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, +;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY +;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE +;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY +;;; NATURE WHATSOEVER. + +;;; Before attempting to port this code to a new implementation of +;;; Scheme, please read the notes below carefully. + +;;; This file defines the syntax-case expander, sc-expand, and a set +;;; of associated syntactic forms and procedures. Of these, the +;;; following are documented in The Scheme Programming Language, +;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be +;;; found online at http://www.scheme.com. Most are also documented +;;; in the R4RS and draft R5RS. +;;; +;;; bound-identifier=? +;;; datum->syntax-object +;;; define-syntax +;;; fluid-let-syntax +;;; free-identifier=? +;;; generate-temporaries +;;; identifier? +;;; identifier-syntax +;;; let-syntax +;;; letrec-syntax +;;; syntax +;;; syntax-case +;;; syntax-object->datum +;;; syntax-rules +;;; with-syntax +;;; +;;; All standard Scheme syntactic forms are supported by the expander +;;; or syntactic abstractions defined in this file. Only the R4RS +;;; delay is omitted, since its expansion is implementation-dependent. + +;;; Also defined are three forms that support modules: module, import, +;;; and import-only. These are documented in the Chez Scheme User's +;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can +;;; also be found online at http://www.scheme.com. They are described +;;; briefly here as well. +;;; +;;; Both are definitions and may appear where and only where other +;;; definitions may appear. modules may be named: +;;; +;;; (module id (ex ...) defn ... init ...) +;;; +;;; or anonymous: +;;; +;;; (module (ex ...) defn ... init ...) +;;; +;;; The latter form is semantically equivalent to: +;;; +;;; (module T (ex ...) defn ... init ...) +;;; (import T) +;;; +;;; where T is a fresh identifier. +;;; +;;; In either form, each of the exports in (ex ...) is either an +;;; identifier or of the form (id ex ...). In the former case, the +;;; single identifier ex is exported. In the latter, the identifier +;;; id is exported and the exports ex ... are "implicitly" exported. +;;; This listing of implicit exports is useful only when id is a +;;; keyword bound to a transformer that expands into references to +;;; the listed implicit exports. In the present implementation, +;;; listing of implicit exports is necessary only for top-level +;;; modules and allows the implementation to avoid placing all +;;; identifiers into the top-level environment where subsequent passes +;;; of the compiler will be unable to deal effectively with them. +;;; +;;; Named modules may be referenced in import statements, which +;;; always take one of the forms: +;;; +;;; (import id) +;;; (import-only id) +;;; +;;; id must name a module. Each exported identifier becomes visible +;;; within the scope of the import form. In the case of import-only, +;;; all other identifiers become invisible in the scope of the +;;; import-only form, except for those established by definitions +;;; that appear textually after the import-only form. + +;;; The remaining exports are listed below. sc-expand, eval-when, and +;;; syntax-error are described in the Chez Scheme User's Guide. +;;; +;;; (sc-expand datum) +;;; if datum represents a valid expression, sc-expand returns an +;;; expanded version of datum in a core language that includes no +;;; syntactic abstractions. The core language includes begin, +;;; define, if, lambda, letrec, quote, and set!. +;;; (eval-when situations expr ...) +;;; conditionally evaluates expr ... at compile-time or run-time +;;; depending upon situations +;;; (syntax-error object message) +;;; used to report errors found during expansion +;;; ($syntax-dispatch e p) +;;; used by expanded code to handle syntax-case matching +;;; ($sc-put-cte symbol val) +;;; used to establish top-level compile-time (expand-time) bindings. + +;;; The following nonstandard procedures must be provided by the +;;; implementation for this code to run. +;;; +;;; (void) +;;; returns the implementation's cannonical "unspecified value". The +;;; following usually works: +;;; +;;; (define void (lambda () (if #f #f))). +;;; +;;; (andmap proc list1 list2 ...) +;;; returns true if proc returns true when applied to each element of list1 +;;; along with the corresponding elements of list2 .... The following +;;; definition works but does no error checking: +;;; +;;; (define andmap +;;; (lambda (f first . rest) +;;; (or (null? first) +;;; (if (null? rest) +;;; (let andmap ((first first)) +;;; (let ((x (car first)) (first (cdr first))) +;;; (if (null? first) +;;; (f x) +;;; (and (f x) (andmap first))))) +;;; (let andmap ((first first) (rest rest)) +;;; (let ((x (car first)) +;;; (xr (map car rest)) +;;; (first (cdr first)) +;;; (rest (map cdr rest))) +;;; (if (null? first) +;;; (apply f (cons x xr)) +;;; (and (apply f (cons x xr)) (andmap first rest))))))))) +;;; +;;; (ormap proc list1) +;;; returns the first non-false return result of proc applied to +;;; the elements of list1 or false if none. The following definition +;;; works but does no error checking: +;;; +;;; (define ormap +;;; (lambda (proc list1) +;;; (and (not (null? list1)) +;;; (or (proc (car list1)) (ormap proc (cdr list1)))))) +;;; +;;; The following nonstandard procedures must also be provided by the +;;; implementation for this code to run using the standard portable +;;; hooks and output constructors. They are not used by expanded code, +;;; and so need be present only at expansion time. +;;; +;;; (eval x) +;;; where x is always in the form ("noexpand" expr). +;;; returns the value of expr. the "noexpand" flag is used to tell the +;;; evaluator/expander that no expansion is necessary, since expr has +;;; already been fully expanded to core forms. +;;; +;;; eval will not be invoked during the loading of psyntax.pp. After +;;; psyntax.pp has been loaded, the expansion of any macro definition, +;;; whether local or global, results in a call to eval. If, however, +;;; sc-expand has already been registered as the expander to be used +;;; by eval, and eval accepts one argument, nothing special must be done +;;; to support the "noexpand" flag, since it is handled by sc-expand. +;;; +;;; (error who format-string why what) +;;; where who is either a symbol or #f, format-string is always "~a ~s", +;;; why is always a string, and what may be any object. error should +;;; signal an error with a message something like +;;; +;;; "error in <who>: <why> <what>" +;;; +;;; (gensym) +;;; returns a unique symbol each time it's called. In Chez Scheme, gensym +;;; returns a symbol with a "globally" unique name so that gensyms that +;;; end up in the object code of separately compiled files cannot conflict. +;;; This is necessary only if you intend to support compiled files. +;;; +;;; (putprop symbol key value) +;;; (getprop symbol key) +;;; (remprop symbol key) +;;; key is always a symbol; value may be any object. putprop should +;;; associate the given value with the given symbol and key in some way +;;; that it can be retrieved later with getprop. getprop should return +;;; #f if no value is associated with the given symbol and key. remprop +;;; should remove the association between the given symbol and key. + +;;; When porting to a new Scheme implementation, you should define the +;;; procedures listed above, load the expanded version of psyntax.ss +;;; (psyntax.pp, which should be available whereever you found +;;; psyntax.ss), and register sc-expand as the current expander (how +;;; you do this depends upon your implementation of Scheme). You may +;;; change the hooks and constructors defined toward the beginning of +;;; the code below, but to avoid bootstrapping problems, do so only +;;; after you have a working version of the expander. + +;;; Chez Scheme allows the syntactic form (syntax <template>) to be +;;; abbreviated to #'<template>, just as (quote <datum>) may be +;;; abbreviated to '<datum>. The #' syntax makes programs written +;;; using syntax-case shorter and more readable and draws out the +;;; intuitive connection between syntax and quote. If you have access +;;; to the source code of your Scheme system's reader, you might want +;;; to implement this extension. + +;;; If you find that this code loads or runs slowly, consider +;;; switching to faster hardware or a faster implementation of +;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding, +;;; compiling (with full optimization), and loading this file takes +;;; between one and two seconds. + +;;; In the expander implementation, we sometimes use syntactic abstractions +;;; when procedural abstractions would suffice. For example, we define +;;; top-wrap and top-marked? as +;;; (define-syntax top-wrap (identifier-syntax '((top)))) +;;; (define-syntax top-marked? +;;; (syntax-rules () +;;; ((_ w) (memq 'top (wrap-marks w))))) +;;; rather than +;;; (define top-wrap '((top))) +;;; (define top-marked? +;;; (lambda (w) (memq 'top (wrap-marks w)))) +;;; On ther other hand, we don't do this consistently; we define make-wrap, +;;; wrap-marks, and wrap-subst simply as +;;; (define make-wrap cons) +;;; (define wrap-marks car) +;;; (define wrap-subst cdr) +;;; In Chez Scheme, the syntactic and procedural forms of these +;;; abstractions are equivalent, since the optimizer consistently +;;; integrates constants and small procedures. Some Scheme +;;; implementations, however, may benefit from more consistent use +;;; of one form or the other. + + +;;; Implementation notes: + +;;; "begin" is treated as a splicing construct at top level and at +;;; the beginning of bodies. Any sequence of expressions that would +;;; be allowed where the "begin" occurs is allowed. + +;;; "let-syntax" and "letrec-syntax" are also treated as splicing +;;; constructs, in violation of the R5RS. A consequence is that let-syntax +;;; and letrec-syntax do not create local contours, as do let and letrec. +;;; Although the functionality is greater as it is presently implemented, +;;; we will probably change it to conform to the R5RS. modules provide +;;; similar functionality to nonsplicing letrec-syntax when the latter is +;;; used as a definition. + +;;; Objects with no standard print syntax, including objects containing +;;; cycles and syntax objects, are allowed in quoted data as long as they +;;; are contained within a syntax form or produced by datum->syntax-object. +;;; Such objects are never copied. + +;;; When the expander encounters a reference to an identifier that has +;;; no global or lexical binding, it treats it as a global-variable +;;; reference. This allows one to write mutually recursive top-level +;;; definitions, e.g.: +;;; +;;; (define f (lambda (x) (g x))) +;;; (define g (lambda (x) (f x))) +;;; +;;; but may not always yield the intended when the variable in question +;;; is later defined as a keyword. + +;;; Top-level variable definitions of syntax keywords are permitted. +;;; In order to make this work, top-level define not only produces a +;;; top-level definition in the core language, but also modifies the +;;; compile-time environment (using $sc-put-cte) to record the fact +;;; that the identifier is a variable. + +;;; Top-level definitions of macro-introduced identifiers are visible +;;; only in code produced by the macro. That is, a binding for a +;;; hidden (generated) identifier is created instead, and subsequent +;;; references within the macro output are renamed accordingly. For +;;; example: +;;; +;;; (define-syntax a +;;; (syntax-rules () +;;; ((_ var exp) +;;; (begin +;;; (define secret exp) +;;; (define var +;;; (lambda () +;;; (set! secret (+ secret 17)) +;;; secret)))))) +;;; (a x 0) +;;; (x) => 17 +;;; (x) => 34 +;;; secret => Error: variable secret is not bound +;;; +;;; The definition above would fail if the definition for secret +;;; were placed after the definition for var, since the expander would +;;; encounter the references to secret before the definition that +;;; establishes the compile-time map from the identifier secret to +;;; the generated identifier. + +;;; Identifiers and syntax objects are implemented as vectors for +;;; portability. As a result, it is possible to "forge" syntax +;;; objects. + +;;; The input to sc-expand may contain "annotations" describing, e.g., the +;;; source file and character position from where each object was read if +;;; it was read from a file. These annotations are handled properly by +;;; sc-expand only if the annotation? hook (see hooks below) is implemented +;;; properly and the operators make-annotation, annotation-expression, +;;; annotation-source, annotation-stripped, and set-annotation-stripped! +;;; are supplied. If annotations are supplied, the proper annotation +;;; source is passed to the various output constructors, allowing +;;; implementations to accurately correlate source and expanded code. +;;; Contact one of the authors for details if you wish to make use of +;;; this feature. + +;;; Implementation of modules: +;;; +;;; The implementation of modules requires that implicit top-level exports +;;; be listed with the exported macro at some level where both are visible, +;;; e.g., +;;; +;;; (module M (alpha (beta b)) +;;; (module ((alpha a) b) +;;; (define-syntax alpha (identifier-syntax a)) +;;; (define a 'a) +;;; (define b 'b)) +;;; (define-syntax beta (identifier-syntax b))) +;;; +;;; Listing of implicit imports is not needed for macros that do not make +;;; it out to top level, including all macros that are local to a "body". +;;; (They may be listed in this case, however.) We need this information +;;; for top-level modules since a top-level module expands into a letrec +;;; for non-top-level variables and top-level definitions (assignments) for +;;; top-level variables. Because of the general nature of macro +;;; transformers, we cannot determine the set of implicit exports from the +;;; transformer code, so without the user's help, we'd have to put all +;;; variables at top level. +;;; +;;; Each such top-level identifier is given a generated name (gensym). +;;; When a top-level module is imported at top level, a compile-time +;;; alias is established from the top-level name to the generated name. +;;; The expander follows these aliases transparently. When any module is +;;; imported anywhere other than at top level, the id-var-name of the +;;; import identifier is set to the id-var-name of the export identifier. +;;; Since we can't determine the actual labels for identifiers defined in +;;; top-level modules until we determine which are placed in the letrec +;;; and which make it to top level, we give each an "indirect" label---a +;;; pair whose car will eventually contain the actual label. Import does +;;; not follow the indirect, but id-var-name does. +;;; +;;; All identifiers defined within a local module are folded into the +;;; letrec created for the enclosing body. Visibility is controlled in +;;; this case and for nested top-level modules by introducing a new wrap +;;; for each module. + + +;;; Bootstrapping: + +;;; When changing syntax-object representations, it is necessary to support +;;; both old and new syntax-object representations in id-var-name. It +;;; should be sufficient to recognize old representations and treat +;;; them as not lexically bound. + + +(let () + +(define-syntax when + (syntax-rules () + ((_ test e1 e2 ...) (if test (begin e1 e2 ...))))) +(define-syntax unless + (syntax-rules () + ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...))))) +(define-syntax define-structure + (lambda (x) + (define construct-name + (lambda (template-identifier . args) + (datum->syntax-object + template-identifier + (string->symbol + (apply string-append + (map (lambda (x) + (if (string? x) + x + (symbol->string (syntax-object->datum x)))) + args)))))) + (syntax-case x () + ((_ (name id1 ...)) + (andmap identifier? (syntax (name id1 ...))) + (with-syntax + ((constructor (construct-name (syntax name) "make-" (syntax name))) + (predicate (construct-name (syntax name) (syntax name) "?")) + ((access ...) + (map (lambda (x) (construct-name x (syntax name) "-" x)) + (syntax (id1 ...)))) + ((assign ...) + (map (lambda (x) + (construct-name x "set-" (syntax name) "-" x "!")) + (syntax (id1 ...)))) + (structure-length + (+ (length (syntax (id1 ...))) 1)) + ((index ...) + (let f ((i 1) (ids (syntax (id1 ...)))) + (if (null? ids) + '() + (cons i (f (+ i 1) (cdr ids))))))) + (syntax (begin + (define constructor + (lambda (id1 ...) + (vector 'name id1 ... ))) + (define predicate + (lambda (x) + (and (vector? x) + (= (vector-length x) structure-length) + (eq? (vector-ref x 0) 'name)))) + (define access + (lambda (x) + (vector-ref x index))) + ... + (define assign + (lambda (x update) + (vector-set! x index update))) + ...))))))) + +(define noexpand "noexpand") + +;;; hooks to nonportable run-time helpers +(begin +(define-syntax fx+ (identifier-syntax +)) +(define-syntax fx- (identifier-syntax -)) +(define-syntax fx= (identifier-syntax =)) +(define-syntax fx< (identifier-syntax <)) + +(define annotation? (lambda (x) #f)) + +(define top-level-eval-hook + (lambda (x) + (eval `(,noexpand ,x)))) + +(define local-eval-hook + (lambda (x) + (eval `(,noexpand ,x)))) + +(define error-hook + (lambda (who why what) + (error who "~a ~s" why what))) + +(define-syntax gensym-hook + (syntax-rules () + ((_) (gensym)))) + +(define put-global-definition-hook + (lambda (symbol val) + ($sc-put-cte symbol val))) + +(define get-global-definition-hook + (lambda (symbol) + (getprop symbol '*sc-expander*))) + +(define get-import-binding + (lambda (symbol token) + (getprop symbol token))) + +(define generate-id + (let ((b (- 127 32 2))) + ; session-key should generate a unique integer for each system run + ; to support separate compilation + (define session-key (lambda () 0)) + (define make-digit (lambda (x) (integer->char (fx+ x 33)))) + (define fmt + (lambda (n) + (let fmt ((n n) (a '())) + (if (< n b) + (list->string (cons (make-digit n) a)) + (let ((r (modulo n b)) (rest (quotient n b))) + (fmt rest (cons (make-digit r) a))))))) + (let ((prefix (fmt (session-key))) (n -1)) + (lambda (name) + (set! n (+ n 1)) + (let ((newsym (string->symbol (string-append "#" prefix (fmt n))))) + newsym))))) +) + + +;;; output constructors +(begin +(define-syntax build-application + (syntax-rules () + ((_ source fun-exp arg-exps) + `(,fun-exp . ,arg-exps)))) + +(define-syntax build-conditional + (syntax-rules () + ((_ source test-exp then-exp else-exp) + `(if ,test-exp ,then-exp ,else-exp)))) + +(define-syntax build-lexical-reference + (syntax-rules () + ((_ type source var) + var))) + +(define-syntax build-lexical-assignment + (syntax-rules () + ((_ source var exp) + `(set! ,var ,exp)))) + +(define-syntax build-global-reference + (syntax-rules () + ((_ source var) + var))) + +(define-syntax build-global-assignment + (syntax-rules () + ((_ source var exp) + `(set! ,var ,exp)))) + +(define-syntax build-global-definition + (syntax-rules () + ((_ source var exp) + `(define ,var ,exp)))) + +(define-syntax build-module-definition + ; should have the effect of a global definition but may not appear at top level + (identifier-syntax build-global-assignment)) + +(define-syntax build-cte-install + ; should build a call that has the same effect as calling the + ; global definition hook + (syntax-rules () + ((_ sym exp) `($sc-put-cte ',sym ,exp)))) + +(define-syntax build-lambda + (syntax-rules () + ((_ src vars exp) + `(lambda ,vars ,exp)))) + +(define-syntax build-primref + (syntax-rules () + ((_ src name) name) + ((_ src level name) name))) + +(define-syntax build-data + (syntax-rules () + ((_ src exp) `',exp))) + +(define build-sequence + (lambda (src exps) + (if (null? (cdr exps)) + (car exps) + `(begin ,@exps)))) + +(define build-letrec + (lambda (src vars val-exps body-exp) + (if (null? vars) + body-exp + `(letrec ,(map list vars val-exps) ,body-exp)))) + +(define-syntax build-lexical-var + (syntax-rules () + ((_ src id) (gensym)))) + +(define-syntax self-evaluating? + (syntax-rules () + ((_ e) + (let ((x e)) + (or (boolean? x) (number? x) (string? x) (char? x) (null? x)))))) +) + +(define-structure (syntax-object expression wrap)) + +(define-syntax unannotate + (syntax-rules () + ((_ x) + (let ((e x)) + (if (annotation? e) + (annotation-expression e) + e))))) + +(define-syntax no-source (identifier-syntax #f)) + +(define source-annotation + (lambda (x) + (cond + ((annotation? x) (annotation-source x)) + ((syntax-object? x) (source-annotation (syntax-object-expression x))) + (else no-source)))) + +(define-syntax arg-check + (syntax-rules () + ((_ pred? e who) + (let ((x e)) + (if (not (pred? x)) (error-hook who "invalid argument" x)))))) + +;;; compile-time environments + +;;; wrap and environment comprise two level mapping. +;;; wrap : id --> label +;;; env : label --> <element> + +;;; environments are represented in two parts: a lexical part and a global +;;; part. The lexical part is a simple list of associations from labels +;;; to bindings. The global part is implemented by +;;; {put,get}-global-definition-hook and associates symbols with +;;; bindings. + +;;; global (assumed global variable) and displaced-lexical (see below) +;;; do not show up in any environment; instead, they are fabricated by +;;; lookup when it finds no other bindings. + +;;; <environment> ::= ((<label> . <binding>)*) + +;;; identifier bindings include a type and a value + +;;; <binding> ::= (macro . <procedure>) macros +;;; (deferred . <expanded code>) lazy-evaluation of transformers +;;; (core . <procedure>) core forms +;;; (begin) begin +;;; (define) define +;;; (define-syntax) define-syntax +;;; (local-syntax . rec?) let-syntax/letrec-syntax +;;; (eval-when) eval-when +;;; (syntax . (<var> . <level>)) pattern variables +;;; (global . <symbol>) assumed global variable +;;; (lexical . <var>) lexical variables +;;; (displaced-lexical . #f) id-var-name not found in store +;;; <level> ::= <nonnegative integer> +;;; <var> ::= variable returned by build-lexical-var + +;;; a macro is a user-defined syntactic-form. a core is a system-defined +;;; syntactic form. begin, define, define-syntax, and eval-when are +;;; treated specially since they are sensitive to whether the form is +;;; at top-level and (except for eval-when) can denote valid internal +;;; definitions. + +;;; a pattern variable is a variable introduced by syntax-case and can +;;; be referenced only within a syntax form. + +;;; any identifier for which no top-level syntax definition or local +;;; binding of any kind has been seen is assumed to be a global +;;; variable. + +;;; a lexical variable is a lambda- or letrec-bound variable. + +;;; a displaced-lexical identifier is a lexical identifier removed from +;;; it's scope by the return of a syntax object containing the identifier. +;;; a displaced lexical can also appear when a letrec-syntax-bound +;;; keyword is referenced on the rhs of one of the letrec-syntax clauses. +;;; a displaced lexical should never occur with properly written macros. + +(define make-binding (lambda (x y) (cons x y))) +(define binding-type car) +(define binding-value cdr) +(define set-binding-type! set-car!) +(define set-binding-value! set-cdr!) +(define binding? (lambda (x) (and (pair? x) (symbol? (car x))))) + +(define-syntax null-env (identifier-syntax '())) + +(define extend-env + (lambda (label binding r) + (cons (cons label binding) r))) + +(define extend-env* + (lambda (labels bindings r) + (if (null? labels) + r + (extend-env* (cdr labels) (cdr bindings) + (extend-env (car labels) (car bindings) r))))) + +(define extend-var-env* + ; variant of extend-env* that forms "lexical" binding + (lambda (labels vars r) + (if (null? labels) + r + (extend-var-env* (cdr labels) (cdr vars) + (extend-env (car labels) (make-binding 'lexical (car vars)) r))))) + +;;; we use a "macros only" environment in expansion of local macro +;;; definitions so that their definitions can use local macros without +;;; attempting to use other lexical identifiers. +;;; +;;; - can make this null-env if we don't want to allow macros to use other +;;; macros in defining their transformers +;;; - can add a cache here if it pays off +(define transformer-env + (lambda (r) + (if (null? r) + '() + (let ((a (car r))) + (if (eq? (cadr a) 'lexical) ; only strip out lexical so that (transformer x) works + (transformer-env (cdr r)) + (cons a (transformer-env (cdr r)))))))) + +(define displaced-lexical-error + (lambda (id) + (syntax-error id + (if (id-var-name id empty-wrap) + "identifier out of context" + "identifier not visible")))) + +(define lookup* + ; x may be a label or a symbol + ; although symbols are usually global, we check the environment first + ; anyway because a temporary binding may have been established by + ; fluid-let-syntax + (lambda (x r) + (cond + ((assq x r) => cdr) + ((symbol? x) + (or (get-global-definition-hook x) (make-binding 'global x))) + (else (make-binding 'displaced-lexical #f))))) + +(define sanitize-binding + (lambda (b) + (cond + ((procedure? b) (make-binding 'macro b)) + ((binding? b) + (case (binding-type b) + ((core macro macro!) (and (procedure? (binding-value b)) b)) + ((module) (and (interface? (binding-value b)) b)) + (else b))) + (else #f)))) + +(define lookup + (lambda (x r) + (define whack-binding! + (lambda (b *b) + (set-binding-type! b (binding-type *b)) + (set-binding-value! b (binding-value *b)))) + (let ((b (lookup* x r))) + (case (binding-type b) +; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r)) + ((deferred) + (whack-binding! b + (let ((*b (local-eval-hook (binding-value b)))) + (or (sanitize-binding *b) + (syntax-error *b "invalid transformer")))) + (case (binding-type b) +; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r)) + (else b))) + (else b))))) + +(define global-extend + (lambda (type sym val) + (put-global-definition-hook sym (make-binding type val)))) + + +;;; Conceptually, identifiers are always syntax objects. Internally, +;;; however, the wrap is sometimes maintained separately (a source of +;;; efficiency and confusion), so that symbols are also considered +;;; identifiers by id?. Externally, they are always wrapped. + +(define nonsymbol-id? + (lambda (x) + (and (syntax-object? x) + (symbol? (unannotate (syntax-object-expression x)))))) + +(define id? + (lambda (x) + (cond + ((symbol? x) #t) + ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x)))) + ((annotation? x) (symbol? (annotation-expression x))) + (else #f)))) + +(define-syntax id-sym-name + (syntax-rules () + ((_ e) + (let ((x e)) + (unannotate (if (syntax-object? x) (syntax-object-expression x) x)))))) + +(define id-sym-name&marks + (lambda (x w) + (if (syntax-object? x) + (values + (unannotate (syntax-object-expression x)) + (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) + (values (unannotate x) (wrap-marks w))))) + +;;; syntax object wraps + +;;; <wrap> ::= ((<mark> ...) . (<subst> ...)) +;;; <subst> ::= <ribcage> | <shift> +;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external +;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible +;;; <ex-symname> ::= <symname> | <import token> | <barrier> +;;; <shift> ::= shift +;;; <barrier> ::= #f ; inserted by import-only +;;; <import token> ::= #<"import-token" <token>> +;;; <token> ::= <generated id> + +(define make-wrap cons) +(define wrap-marks car) +(define wrap-subst cdr) + +(define-syntax subst-rename? (identifier-syntax vector?)) +(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0)))) +(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1)))) +(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2)))) +(define-syntax make-rename + (syntax-rules () + ((_ old new marks) (vector old new marks)))) + +;;; labels + +;;; simple labels must be comparable with "eq?" and distinct from symbols +;;; and pairs. + +;;; indirect labels, which are implemented as pairs, are used to support +;;; import aliasing for identifiers exported (explictly or implicitly) from +;;; top-level modules. chi-external creates an indirect label for each +;;; defined identifier, import causes the pair to be shared aliases it +;;; establishes, and chi-top-module whacks the pair to hold the top-level +;;; identifier name (symbol) if the id is to be placed at top level, before +;;; expanding the right-hand sides of the definitions in the module. + +(define gen-label + (lambda () (string #\i))) +(define label? + (lambda (x) + (or (string? x) ; normal lexical labels + (symbol? x) ; global labels (symbolic names) + (indirect-label? x)))) + +(define gen-labels + (lambda (ls) + (if (null? ls) + '() + (cons (gen-label) (gen-labels (cdr ls)))))) + +(define gen-indirect-label + (lambda () (list (gen-label)))) + +(define indirect-label? pair?) +(define get-indirect-label car) +(define set-indirect-label! set-car!) + +(define-structure (ribcage symnames marks labels)) +(define-syntax empty-wrap (identifier-syntax '(()))) + +(define-syntax top-wrap (identifier-syntax '((top)))) + +(define-syntax top-marked? + (syntax-rules () + ((_ w) (memq 'top (wrap-marks w))))) + +(define-syntax only-top-marked? + (syntax-rules () + ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap))))) + +;;; Marks must be comparable with "eq?" and distinct from pairs and +;;; the symbol top. We do not use integers so that marks will remain +;;; unique even across file compiles. + +(define-syntax the-anti-mark (identifier-syntax #f)) + +(define anti-mark + (lambda (w) + (make-wrap (cons the-anti-mark (wrap-marks w)) + (cons 'shift (wrap-subst w))))) + +(define-syntax new-mark + (syntax-rules () + ((_) (string #\m)))) + +(define barrier-marker #f) +(module (make-import-token import-token? import-token-key) + (define tag 'import-token) + (define make-import-token (lambda (x) (cons tag x))) + (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag)))) + (define import-token-key cdr)) + +;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for +;;; internal definitions, in which the ribcages are built incrementally +(define-syntax make-empty-ribcage + (syntax-rules () + ((_) (make-ribcage '() '() '())))) + +(define extend-ribcage! + ; must receive ids with complete wraps + ; ribcage guaranteed to be list-based + (lambda (ribcage id label) + (set-ribcage-symnames! ribcage + (cons (unannotate (syntax-object-expression id)) + (ribcage-symnames ribcage))) + (set-ribcage-marks! ribcage + (cons (wrap-marks (syntax-object-wrap id)) + (ribcage-marks ribcage))) + (set-ribcage-labels! ribcage + (cons label (ribcage-labels ribcage))))) + +(define extend-ribcage-barrier! + ; must receive ids with complete wraps + ; ribcage guaranteed to be list-based + (lambda (ribcage killer-id) + (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id)))) + +(define extend-ribcage-barrier-help! + (lambda (ribcage wrap) + (set-ribcage-symnames! ribcage + (cons barrier-marker (ribcage-symnames ribcage))) + (set-ribcage-marks! ribcage + (cons (wrap-marks wrap) (ribcage-marks ribcage))))) + +(define extend-ribcage-subst! + ; ribcage guaranteed to be list-based + (lambda (ribcage token) + (set-ribcage-symnames! ribcage + (cons (make-import-token token) (ribcage-symnames ribcage))))) + +(define lookup-import-binding-name + (lambda (sym key marks) + (let ((new (get-import-binding sym key))) + (and new + (let f ((new new)) + (cond + ((pair? new) (or (f (car new)) (f (cdr new)))) + ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new) + (else #f))))))) + +;;; make-binding-wrap creates vector-based ribcages +(define make-binding-wrap + (lambda (ids labels w) + (if (null? ids) + w + (make-wrap + (wrap-marks w) + (cons + (let ((labelvec (list->vector labels))) + (let ((n (vector-length labelvec))) + (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) + (let f ((ids ids) (i 0)) + (if (not (null? ids)) + (call-with-values + (lambda () (id-sym-name&marks (car ids) w)) + (lambda (symname marks) + (vector-set! symnamevec i symname) + (vector-set! marksvec i marks) + (f (cdr ids) (fx+ i 1)))))) + (make-ribcage symnamevec marksvec labelvec)))) + (wrap-subst w)))))) + +;;; make-trimmed-syntax-object is used by make-resolved-interface to support +;;; creation of module export lists whose constituent ids do not contain +;;; unnecessary substitutions or marks. +(define make-trimmed-syntax-object + (lambda (id) + (call-with-values + (lambda () (id-var-name&marks id empty-wrap)) + (lambda (tosym marks) + (unless tosym + (syntax-error id "identifier not visible for export")) + (let ((fromsym (id-sym-name id))) + (make-syntax-object fromsym + (make-wrap marks + (list (make-ribcage (vector fromsym) (vector marks) (vector tosym)))))))))) + +;;; Scheme's append should not copy the first argument if the second is +;;; nil, but it does, so we define a smart version here. +(define smart-append + (lambda (m1 m2) + (if (null? m2) + m1 + (append m1 m2)))) + +(define join-wraps + (lambda (w1 w2) + (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1))) + (if (null? m1) + (if (null? s1) + w2 + (make-wrap + (wrap-marks w2) + (smart-append s1 (wrap-subst w2)))) + (make-wrap + (smart-append m1 (wrap-marks w2)) + (smart-append s1 (wrap-subst w2))))))) + +(define join-marks + (lambda (m1 m2) + (smart-append m1 m2))) + +(define same-marks? + (lambda (x y) + (or (eq? x y) + (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y)) + (same-marks? (cdr x) (cdr y)))))) + +(define id-var-name-loc&marks + (lambda (id w) + (define search + (lambda (sym subst marks) + (if (null? subst) + (values sym marks) + (let ((fst (car subst))) + (if (eq? fst 'shift) + (search sym (cdr subst) (cdr marks)) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (search-vector-rib sym subst marks symnames fst) + (search-list-rib sym subst marks symnames fst)))))))) + (define search-list-rib + (lambda (sym subst marks symnames ribcage) + (let f ((symnames symnames) (i 0)) + (cond + ((null? symnames) (search sym (cdr subst) marks)) + ((and (eq? (car symnames) sym) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (values (list-ref (ribcage-labels ribcage) i) marks)) + ((import-token? (car symnames)) + (cond + ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) => + (lambda (id) + (if (symbol? id) + (values id marks) + (id-var-name&marks id empty-wrap)))) ; could be more efficient: new is a resolved id + (else (f (cdr symnames) i)))) + ((and (eq? (car symnames) barrier-marker) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (values #f marks)) + (else (f (cdr symnames) (fx+ i 1))))))) + (define search-vector-rib + (lambda (sym subst marks symnames ribcage) + (let ((n (vector-length symnames))) + (let f ((i 0)) + (cond + ((fx= i n) (search sym (cdr subst) marks)) + ((and (eq? (vector-ref symnames i) sym) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (values (vector-ref (ribcage-labels ribcage) i) marks)) + (else (f (fx+ i 1)))))))) + (cond + ((symbol? id) (search id (wrap-subst w) (wrap-marks w))) + ((syntax-object? id) + (let ((sym (unannotate (syntax-object-expression id))) + (w1 (syntax-object-wrap id))) + (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) + (call-with-values (lambda () (search sym (wrap-subst w) marks)) + (lambda (new-id marks) + (if (eq? new-id sym) + (search sym (wrap-subst w1) marks) + (values new-id marks))))))) + ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w))) + (else (error-hook 'id-var-name "invalid id" id))))) + +(define id-var-name&marks + ; this version follows indirect labels + (lambda (id w) + (call-with-values + (lambda () (id-var-name-loc&marks id w)) + (lambda (label marks) + (values (if (indirect-label? label) (get-indirect-label label) label) marks))))) + +(define id-var-name-loc + ; this version doesn't follow indirect labels + (lambda (id w) + (call-with-values + (lambda () (id-var-name-loc&marks id w)) + (lambda (label marks) label)))) + +(define id-var-name + ; this version follows indirect labels + (lambda (id w) + (call-with-values + (lambda () (id-var-name-loc&marks id w)) + (lambda (label marks) + (if (indirect-label? label) (get-indirect-label label) label))))) + +;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) +;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. + +(define free-id=? + (lambda (i j) + (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator + (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap))))) + +(define-syntax literal-id=? (identifier-syntax free-id=?)) + +;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as +;;; long as the missing portion of the wrap is common to both of the ids +;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w)) + +(define bound-id=? + (lambda (i j) + (if (and (syntax-object? i) (syntax-object? j)) + (and (eq? (unannotate (syntax-object-expression i)) + (unannotate (syntax-object-expression j))) + (same-marks? (wrap-marks (syntax-object-wrap i)) + (wrap-marks (syntax-object-wrap j)))) + (eq? (unannotate i) (unannotate j))))) + +;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. +;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids +;;; as long as the missing portion of the wrap is common to all of the +;;; ids. + +(define valid-bound-ids? + (lambda (ids) + (and (let all-ids? ((ids ids)) + (or (null? ids) + (and (id? (car ids)) + (all-ids? (cdr ids))))) + (distinct-bound-ids? ids)))) + +;;; distinct-bound-ids? expects a list of ids and returns #t if there are +;;; no duplicates. It is quadratic on the length of the id list; long +;;; lists could be sorted to make it more efficient. distinct-bound-ids? +;;; may be passed unwrapped (or partially wrapped) ids as long as the +;;; missing portion of the wrap is common to all of the ids. + +(define distinct-bound-ids? + (lambda (ids) + (let distinct? ((ids ids)) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (distinct? (cdr ids))))))) + +(define invalid-ids-error + ; find first bad one and complain about it + (lambda (ids exp class) + (let find ((ids ids) (gooduns '())) + (if (null? ids) + (syntax-error exp) ; shouldn't happen + (if (id? (car ids)) + (if (bound-id-member? (car ids) gooduns) + (syntax-error (car ids) "duplicate " class) + (find (cdr ids) (cons (car ids) gooduns))) + (syntax-error (car ids) "invalid " class)))))) + +(define bound-id-member? + (lambda (x list) + (and (not (null? list)) + (or (bound-id=? x (car list)) + (bound-id-member? x (cdr list)))))) + +;;; wrapping expressions and identifiers + +(define wrap + (lambda (x w) + (cond + ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) + ((syntax-object? x) + (make-syntax-object + (syntax-object-expression x) + (join-wraps w (syntax-object-wrap x)))) + ((null? x) x) + (else (make-syntax-object x w))))) + +(define source-wrap + (lambda (x w s) + (wrap (if s (make-annotation x s #f) x) w))) + +;;; expanding + +(define chi-sequence + (lambda (body r w s) + (build-sequence s + (let dobody ((body body) (r r) (w w)) + (if (null? body) + '() + (let ((first (chi (car body) r w))) + (cons first (dobody (cdr body) r w)))))))) + +(define chi-top-sequence + (lambda (body r w s m esew ribcage) + (build-sequence s + (let dobody ((body body) (r r) (w w) (m m) (esew esew)) + (if (null? body) + '() + (let ((first (chi-top (car body) r w m esew ribcage))) + (cons first (dobody (cdr body) r w m esew)))))))) + +(define chi-when-list + (lambda (e when-list w) + ; when-list is syntax'd version of list of situations + (let f ((when-list when-list) (situations '())) + (if (null? when-list) + situations + (f (cdr when-list) + (cons (let ((x (car when-list))) + (cond + ((literal-id=? x (syntax compile)) 'compile) + ((literal-id=? x (syntax load)) 'load) + ((literal-id=? x (syntax eval)) 'eval) + (else (syntax-error (wrap x w) + "invalid eval-when situation")))) + situations)))))) + +;;; syntax-type returns five values: type, value, e, w, and s. The first +;;; two are described in the table below. +;;; +;;; type value explanation +;;; ------------------------------------------------------------------- +;;; begin none begin keyword +;;; begin-form none begin expression +;;; call none any other call +;;; constant none self-evaluating datum +;;; core procedure core form (including singleton) +;;; define none define keyword +;;; define-form none variable definition +;;; define-syntax none define-syntax keyword +;;; define-syntax-form none syntax definition +;;; displaced-lexical none displaced lexical identifier +;;; eval-when none eval-when keyword +;;; eval-when-form none eval-when form +;;; global name global variable reference +;;; import none import keyword +;;; import-form none import form +;;; lexical name lexical variable reference +;;; lexical-call name call to lexical variable +;;; local-syntax rec? letrec-syntax/let-syntax keyword +;;; local-syntax-form rec? syntax definition +;;; module none module keyword +;;; module-form none module definition +;;; other none anything else +;;; syntax level pattern variable +;;; +;;; For all forms, e is the form, w is the wrap for e. and s is the source. +;;; +;;; syntax-type expands macros and unwraps as necessary to get to +;;; one of the forms above. + +(define syntax-type + (lambda (e r w s rib) + (cond + ((symbol? e) + (let* ((n (id-var-name e w)) + (b (lookup n r)) + (type (binding-type b))) + (case type + ((lexical) (values type (binding-value b) e w s)) + ((global) (values type (binding-value b) e w s)) + ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib)) + (else (values type (binding-value b) e w s))))) + ((pair? e) + (let ((first (car e))) + (if (id? first) + (let* ((n (id-var-name first w)) + (b (lookup n r)) + (type (binding-type b))) + (case type + ((lexical) (values 'lexical-call (binding-value b) e w s)) + ((macro macro!) + (syntax-type (chi-macro (binding-value b) e r w s rib) + r empty-wrap #f rib)) + ((core) (values type (binding-value b) e w s)) + ((local-syntax) + (values 'local-syntax-form (binding-value b) e w s)) + ((begin) (values 'begin-form #f e w s)) + ((eval-when) (values 'eval-when-form #f e w s)) + ((define) (values 'define-form #f e w s)) + ((define-syntax) (values 'define-syntax-form #f e w s)) + ((module-key) (values 'module-form #f e w s)) + ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s)) + ((set!) (chi-set! e r w s rib)) + (else (values 'call #f e w s)))) + (values 'call #f e w s)))) + ((syntax-object? e) + ;; s can't be valid source if we've unwrapped + (syntax-type (syntax-object-expression e) + r + (join-wraps w (syntax-object-wrap e)) + no-source rib)) + ((annotation? e) + (syntax-type (annotation-expression e) r w (annotation-source e) rib)) + ((self-evaluating? e) (values 'constant #f e w s)) + (else (values 'other #f e w s))))) + +(define chi-top-expr + (lambda (e r w top-ribcage) + (call-with-values + (lambda () (syntax-type e r w no-source top-ribcage)) + (lambda (type value e w s) + (chi-expr type value e r w s))))) + +(define chi-top + (lambda (e r w m esew top-ribcage) + (define-syntax eval-if-c&e + (syntax-rules () + ((_ m e) + (let ((x e)) + (if (eq? m 'c&e) (top-level-eval-hook x)) + x)))) + (call-with-values + (lambda () (syntax-type e r w no-source top-ribcage)) + (lambda (type value e w s) + (case type + ((begin-form) + (syntax-case e () + ((_) (chi-void)) + ((_ e1 e2 ...) + (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage)))) + ((local-syntax-form) + (chi-local-syntax value e r w s + (lambda (body r w s) + (chi-top-sequence body r w s m esew top-ribcage)))) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (chi-when-list e (syntax (x ...)) w)) + (body (syntax (e1 e2 ...)))) + (cond + ((eq? m 'e) + (if (memq 'eval when-list) + (chi-top-sequence body r w s 'e '(eval) top-ribcage) + (chi-void))) + ((memq 'load when-list) + (if (or (memq 'compile when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage) + (if (memq m '(c c&e)) + (chi-top-sequence body r w s 'c '(load) top-ribcage) + (chi-void)))) + ((or (memq 'compile when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook + (chi-top-sequence body r w s 'e '(eval) top-ribcage)) + (chi-void)) + (else (chi-void))))))) + ((define-syntax-form) + (parse-define-syntax e w s + (lambda (id rhs w) + (let ((id (wrap id w))) + (let ((n (id-var-name id empty-wrap))) + (let ((b (lookup n r))) + (case (binding-type b) + ((displaced-lexical) (displaced-lexical-error id))))) + (ct-eval/residualize m esew + (lambda () + (build-cte-install + (let ((sym (id-sym-name id))) + (if (only-top-marked? id) + sym + (let ((marks (wrap-marks (syntax-object-wrap id)))) + (make-syntax-object sym + (make-wrap marks + (list (make-ribcage (vector sym) + (vector marks) (vector (generate-id sym))))))))) + (chi rhs (transformer-env r) w)))))))) + ((define-form) + (parse-define e w s + (lambda (id rhs w) + (let ((id (wrap id w))) + (let ((n (id-var-name id empty-wrap))) + (let ((b (lookup n r))) + (case (binding-type b) + ((displaced-lexical) (displaced-lexical-error id))))) + (let ((sym (id-sym-name id))) + (let ((valsym (if (only-top-marked? id) sym (generate-id sym)))) + (build-sequence no-source + (list + (ct-eval/residualize m esew + (lambda () + (build-cte-install + (if (eq? sym valsym) + sym + (let ((marks (wrap-marks (syntax-object-wrap id)))) + (make-syntax-object sym + (make-wrap marks + (list (make-ribcage (vector sym) + (vector marks) (vector valsym))))))) + (build-data no-source (make-binding 'global valsym))))) + (eval-if-c&e m (build-global-definition s valsym (chi rhs r w)))))) + ))))) + ((module-form) + (let ((r (cons '("top-level module placeholder" . (placeholder)) r)) + (ribcage (make-empty-ribcage))) + (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))) + (lambda (id exports forms) + (if id + (begin + (let ((n (id-var-name id empty-wrap))) + (let ((b (lookup n r))) + (case (binding-type b) + ((displaced-lexical) (displaced-lexical-error (wrap id w)))))) + (chi-top-module e r ribcage w s m esew id exports forms)) + (chi-top-module e r ribcage w s m esew #f exports forms)))))) + ((import-form) + (parse-import e w s + (lambda (mid) + (ct-eval/residualize m esew + (lambda () + (when value (syntax-error (source-wrap e w s) "not valid at top-level")) + (let ((binding (lookup (id-var-name mid empty-wrap) null-env))) + (case (binding-type binding) + ((module) (do-top-import mid (interface-token (binding-value binding)))) + ((displaced-lexical) (displaced-lexical-error mid)) + (else (syntax-error mid "import from unknown module"))))))))) + (else (eval-if-c&e m (chi-expr type value e r w s)))))))) + +(define flatten-exports + (lambda (exports) + (let loop ((exports exports) (ls '())) + (if (null? exports) + ls + (loop (cdr exports) + (if (pair? (car exports)) + (loop (car exports) ls) + (cons (car exports) ls))))))) + + +(define-structure (interface exports token)) + +(define make-trimmed-interface + ; trim out implicit exports + (lambda (exports) + (make-interface + (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports)) + #f))) + +(define make-resolved-interface + ; trim out implicit exports & resolve others to actual top-level symbol + (lambda (exports import-token) + (make-interface + (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports)) + import-token))) + +(define-structure (module-binding type id label imps val)) + +(define chi-top-module + (lambda (e r ribcage w s m esew id exports forms) + (let ((fexports (flatten-exports exports))) + (chi-external ribcage (source-wrap e w s) + (map (lambda (d) (cons r d)) forms) r exports fexports m esew + (lambda (bindings inits) + ; dvs & des: "defined" (letrec-bound) vars & rhs expressions + ; svs & ses: "set!" (top-level) vars & rhs expressions + (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '())) + (if (null? fexports) + ; remaining bindings are either local vars or local macros/modules + (let partition ((bs bs) (dvs '()) (des '())) + (if (null? bs) + (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses)) + (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des)) + (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits))) + ; we wait to do this here so that expansion of des & ses use + ; local versions, which in particular, allows us to use macros + ; locally even if esew tells us not to eval them + (for-each (lambda (x) + (apply (lambda (t label sym val) + (when label (set-indirect-label! label sym))) + x)) + ctdefs) + (build-sequence no-source + (list (ct-eval/residualize m esew + (lambda () + (if (null? ctdefs) + (chi-void) + (build-sequence no-source + (map (lambda (x) + (apply (lambda (t label sym val) + (build-cte-install sym + (if (eq? t 'define-syntax-form) + val + (build-data no-source + (make-binding 'module + (make-resolved-interface val sym)))))) + x)) + ctdefs))))) + (ct-eval/residualize m esew + (lambda () + (let ((n (if id (id-sym-name id) #f))) + (let* ((token (generate-id n)) + (b (build-data no-source + (make-binding 'module + (make-resolved-interface exports token))))) + (if n + (build-cte-install + (if (only-top-marked? id) + n + (let ((marks (wrap-marks (syntax-object-wrap id)))) + (make-syntax-object n + (make-wrap marks + (list (make-ribcage (vector n) + (vector marks) (vector (generate-id n)))))))) + b) + (let ((n (generate-id 'tmp))) + (build-sequence no-source + (list (build-cte-install n b) + (do-top-import n token))))))))) + ; Some systems complain when undefined variables are assigned. + (build-sequence no-source + (map (lambda (v) (build-global-definition no-source v (chi-void))) svs)) + (build-letrec no-source + dvs + des + (build-sequence no-source + (list + (if (null? svs) + (chi-void) + (build-sequence no-source + (map (lambda (v e) + (build-module-definition no-source v e)) + svs + ses))) + (if (null? inits) + (chi-void) + (build-sequence no-source inits))))) + (chi-void)))) + (let ((b (car bs))) + (case (module-binding-type b) + ((define-form) + (let ((var (gen-var (module-binding-id b)))) + (extend-store! r + (get-indirect-label (module-binding-label b)) + (make-binding 'lexical var)) + (partition (cdr bs) (cons var dvs) + (cons (module-binding-val b) des)))) + ((define-syntax-form module-form) (partition (cdr bs) dvs des)) + (else (error 'sc-expand-internal "unexpected module binding type")))))) + (let ((id (car fexports)) (fexports (cdr fexports))) + (define pluck-binding + (lambda (id bs succ fail) + (let loop ((bs bs) (new-bs '())) + (if (null? bs) + (fail) + (if (bound-id=? (module-binding-id (car bs)) id) + (succ (car bs) (smart-append (reverse new-bs) (cdr bs))) + (loop (cdr bs) (cons (car bs) new-bs))))))) + (pluck-binding id bs + (lambda (b bs) + (let ((t (module-binding-type b)) + (label (module-binding-label b)) + (imps (module-binding-imps b))) + (let ((fexports (append imps fexports)) + (sym (generate-id (id-sym-name id)))) + (case t + ((define-form) + (set-indirect-label! label sym) + (partition fexports bs (cons sym svs) + (cons (module-binding-val b) ses) + ctdefs)) + ((define-syntax-form) + (partition fexports bs svs ses + (cons (list t label sym (module-binding-val b)) ctdefs))) + ((module-form) + (let ((exports (module-binding-val b))) + (partition (append (flatten-exports exports) fexports) bs + svs ses + (cons (list t label sym exports) ctdefs)))) + (else (error 'sc-expand-internal "unexpected module binding type")))))) + (lambda () (partition fexports bs svs ses ctdefs))))))))))) + +(define id-set-diff + (lambda (exports defs) + (cond + ((null? exports) '()) + ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs)) + (else (cons (car exports) (id-set-diff (cdr exports) defs)))))) + +(define extend-store! + (lambda (r label binding) + (set-cdr! r (extend-env label binding (cdr r))))) + +(define check-module-exports + ; After processing the definitions of a module this is called to verify that the + ; module has defined or imported each exported identifier. Because ids in fexports are + ; wrapped with the given ribcage, they will contain substitutions for anything defined + ; or imported here. These subsitutions can be used by do-import! and do-import-top! to + ; provide access to reexported bindings, for example. + (lambda (source-exp fexports ids) + (define defined? + (lambda (e ids) + (ormap (lambda (x) + (if (interface? x) + (let ((token (interface-token x))) + (if token + (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e))) + (let ((v (interface-exports x))) + (let lp ((i (fx- (vector-length v) 1))) + (and (fx>= i 0) + (or (bound-id=? e (vector-ref v i)) + (lp (fx- i 1)))))))) + (bound-id=? e x))) + ids))) + (let loop ((fexports fexports) (missing '())) + (if (null? fexports) + (unless (null? missing) (syntax-error missing "missing definition for export(s)")) + (let ((e (car fexports)) (fexports (cdr fexports))) + (if (defined? e ids) + (loop fexports missing) + (loop fexports (cons e missing)))))))) + +(define check-defined-ids + (lambda (source-exp ls) + (define b-i=? + ; cope with fat-fingered top-level + (lambda (x y) + (if (symbol? x) + (if (symbol? y) + (eq? x y) + (and (eq? x (id-sym-name y)) + (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap)))) + (if (symbol? y) + (and (eq? y (id-sym-name x)) + (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap))) + (bound-id=? x y))))) + (define vfold + (lambda (v p cls) + (let ((len (vector-length v))) + (let lp ((i 0) (cls cls)) + (if (fx= i len) + cls + (lp (fx+ i 1) (p (vector-ref v i) cls))))))) + (define conflicts + (lambda (x y cls) + (if (interface? x) + (if (interface? y) + (call-with-values + (lambda () + (let ((xe (interface-exports x)) (ye (interface-exports y))) + (if (fx> (vector-length xe) (vector-length ye)) + (values x ye) + (values y xe)))) + (lambda (iface exports) + (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls))) + (id-iface-conflicts y x cls)) + (if (interface? y) + (id-iface-conflicts x y cls) + (if (b-i=? x y) (cons x cls) cls))))) + (define id-iface-conflicts + (lambda (id iface cls) + (let ((token (interface-token iface))) + (if token + (if (lookup-import-binding-name (id-sym-name id) token + (if (symbol? id) + (wrap-marks top-wrap) + (wrap-marks (syntax-object-wrap id)))) + (cons id cls) + cls) + (vfold (interface-exports iface) + (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls)) + cls))))) + (unless (null? ls) + (let lp ((x (car ls)) (ls (cdr ls)) (cls '())) + (if (null? ls) + (unless (null? cls) + (let ((cls (syntax-object->datum cls))) + (syntax-error source-exp "duplicate definition for " + (symbol->string (car cls)) + " in"))) + (let lp2 ((ls2 ls) (cls cls)) + (if (null? ls2) + (lp (car ls) (cdr ls) cls) + (lp2 (cdr ls2) (conflicts x (car ls2) cls))))))))) + +(define chi-external + (lambda (ribcage source-exp body r exports fexports m esew k) + (define return + (lambda (bindings ids inits) + (check-defined-ids source-exp ids) + (check-module-exports source-exp fexports ids) + (k bindings inits))) + (define get-implicit-exports + (lambda (id) + (let f ((exports exports)) + (if (null? exports) + '() + (if (and (pair? (car exports)) (bound-id=? id (caar exports))) + (flatten-exports (cdar exports)) + (f (cdr exports))))))) + (define update-imp-exports + (lambda (bindings exports) + (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports))) + (map (lambda (b) + (let ((id (module-binding-id b))) + (if (not (bound-id-member? id exports)) + b + (make-module-binding + (module-binding-type b) + id + (module-binding-label b) + (append (get-implicit-exports id) (module-binding-imps b)) + (module-binding-val b))))) + bindings)))) + (let parse ((body body) (ids '()) (bindings '()) (inits '())) + (if (null? body) + (return bindings ids inits) + (let ((e (cdar body)) (er (caar body))) + (call-with-values + (lambda () (syntax-type e er empty-wrap no-source ribcage)) + (lambda (type value e w s) + (case type + ((define-form) + (parse-define e w s + (lambda (id rhs w) + (let* ((id (wrap id w)) + (label (gen-indirect-label)) + (imps (get-implicit-exports id))) + (extend-ribcage! ribcage id label) + (parse + (cdr body) + (cons id ids) + (cons (make-module-binding type id label + imps (cons er (wrap rhs w))) + bindings) + inits))))) + ((define-syntax-form) + (parse-define-syntax e w s + (lambda (id rhs w) + (let* ((id (wrap id w)) + (label (gen-indirect-label)) + (imps (get-implicit-exports id)) + (exp (chi rhs (transformer-env er) w))) + ; arrange to evaluate the transformer lazily + (extend-store! r (get-indirect-label label) (cons 'deferred exp)) + (extend-ribcage! ribcage id label) + (parse + (cdr body) + (cons id ids) + (cons (make-module-binding type id label imps exp) + bindings) + inits))))) + ((module-form) + (let* ((*ribcage (make-empty-ribcage)) + (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w))))) + (parse-module e w s *w + (lambda (id *exports forms) + (chi-external *ribcage (source-wrap e w s) + (map (lambda (d) (cons er d)) forms) + r *exports (flatten-exports *exports) m esew + (lambda (*bindings *inits) + (let* ((iface (make-trimmed-interface *exports)) + (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings)) + (inits (append inits *inits))) + (if id + (let ((label (gen-indirect-label)) + (imps (get-implicit-exports id))) + (extend-store! r (get-indirect-label label) + (make-binding 'module iface)) + (extend-ribcage! ribcage id label) + (parse + (cdr body) + (cons id ids) + (cons (make-module-binding type id label imps *exports) bindings) + inits)) + (let () + (do-import! iface ribcage) + (parse (cdr body) (cons iface ids) bindings inits)))))))))) + ((import-form) + (parse-import e w s + (lambda (mid) + (let ((mlabel (id-var-name mid empty-wrap))) + (let ((binding (lookup mlabel r))) + (case (binding-type binding) + ((module) + (let ((iface (binding-value binding))) + (when value (extend-ribcage-barrier! ribcage value)) + (do-import! iface ribcage) + (parse + (cdr body) + (cons iface ids) + (update-imp-exports bindings (vector->list (interface-exports iface))) + inits))) + ((displaced-lexical) (displaced-lexical-error mid)) + (else (syntax-error mid "import from unknown module")))))))) + ((begin-form) + (syntax-case e () + ((_ e1 ...) + (parse (let f ((forms (syntax (e1 ...)))) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w)) + (f (cdr forms))))) + ids bindings inits)))) + ((local-syntax-form) + (chi-local-syntax value e er w s + (lambda (forms er w s) + (parse (let f ((forms forms)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w)) + (f (cdr forms))))) + ids bindings inits)))) + (else ; found an init expression + (return bindings ids + (append inits (cons (cons er (source-wrap e w s)) (cdr body))))))))))))) + +(define vmap + (lambda (fn v) + (do ((i (fx- (vector-length v) 1) (fx- i 1)) + (ls '() (cons (fn (vector-ref v i)) ls))) + ((fx< i 0) ls)))) + +(define vfor-each + (lambda (fn v) + (let ((len (vector-length v))) + (do ((i 0 (fx+ i 1))) + ((fx= i len)) + (fn (vector-ref v i)))))) + +(define do-top-import + (lambda (mid token) + (build-cte-install mid + (build-data no-source + (make-binding 'do-import token))))) + +(define ct-eval/residualize + (lambda (m esew thunk) + (case m + ((c) (if (memq 'compile esew) + (let ((e (thunk))) + (top-level-eval-hook e) + (if (memq 'load esew) e (chi-void))) + (if (memq 'load esew) (thunk) (chi-void)))) + ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e)) + (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void))))) + +(define chi + (lambda (e r w) + (call-with-values + (lambda () (syntax-type e r w no-source #f)) + (lambda (type value e w s) + (chi-expr type value e r w s))))) + +(define chi-expr + (lambda (type value e r w s) + (case type + ((lexical) + (build-lexical-reference 'value s value)) + ((core) (value e r w s)) + ((lexical-call) + (chi-application + (build-lexical-reference 'fun (source-annotation (car e)) value) + e r w s)) + ((constant) (build-data s (strip (source-wrap e w s) empty-wrap))) + ((global) (build-global-reference s value)) + ((call) (chi-application (chi (car e) r w) e r w s)) + ((begin-form) + (syntax-case e () + ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s)))) + ((local-syntax-form) + (chi-local-syntax value e r w s chi-sequence)) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (chi-when-list e (syntax (x ...)) w))) + (if (memq 'eval when-list) + (chi-sequence (syntax (e1 e2 ...)) r w s) + (chi-void)))))) + ((define-form define-syntax-form module-form import-form) + (syntax-error (source-wrap e w s) "invalid context for definition")) + ((syntax) + (syntax-error (source-wrap e w s) + "reference to pattern variable outside syntax form")) + ((displaced-lexical) (displaced-lexical-error (source-wrap e w s))) + (else (syntax-error (source-wrap e w s)))))) + +(define chi-application + (lambda (x e r w s) + (syntax-case e () + ((e0 e1 ...) + (build-application s x + (map (lambda (e) (chi e r w)) (syntax (e1 ...))))) + (_ (syntax-error (source-wrap e w s)))))) + +(define chi-set! + (lambda (e r w s rib) + (syntax-case e () + ((_ id val) + (id? (syntax id)) + (let ((n (id-var-name (syntax id) w))) + (let ((b (lookup n r))) + (case (binding-type b) + ((macro!) + (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w))) + (syntax-type (chi-macro (binding-value b) + `(,(syntax set!) ,id ,val) + r empty-wrap s rib) r empty-wrap s rib))) + (else + (values 'core + (lambda (e r w s) + ; repeat lookup in case we were first expression (init) in + ; module or lambda body. we repeat id-var-name as well, + ; although this is only necessary if we allow inits to + ; preced definitions + (let ((val (chi (syntax val) r w)) + (n (id-var-name (syntax id) w))) + (let ((b (lookup n r))) + (case (binding-type b) + ((lexical) (build-lexical-assignment s (binding-value b) val)) + ((global) (build-global-assignment s (binding-value b) val)) + ((displaced-lexical) + (syntax-error (wrap (syntax id) w) "identifier out of context")) + (else (syntax-error (source-wrap e w s))))))) + e w s)))))) + (_ (syntax-error (source-wrap e w s)))))) + +(define chi-macro + (lambda (p e r w s rib) + (define rebuild-macro-output + (lambda (x m) + (cond ((pair? x) + (cons (rebuild-macro-output (car x) m) + (rebuild-macro-output (cdr x) m))) + ((syntax-object? x) + (let ((w (syntax-object-wrap x))) + (let ((ms (wrap-marks w)) (s (wrap-subst w))) + (make-syntax-object (syntax-object-expression x) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + (make-wrap (cdr ms) + (if rib (cons rib (cdr s)) (cdr s))) + (make-wrap (cons m ms) + (if rib + (cons rib (cons 'shift s)) + (cons 'shift s)))))))) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (do ((i 0 (fx+ i 1))) + ((fx= i n) v) + (vector-set! v i + (rebuild-macro-output (vector-ref x i) m))))) + ((symbol? x) + (syntax-error (source-wrap e w s) + "encountered raw symbol " + (format "~s" x) + " in output of macro")) + (else x)))) + (rebuild-macro-output + (let ((out (p (source-wrap e (anti-mark w) s)))) + (if (procedure? out) + (out (lambda (id) + (unless (identifier? id) + (syntax-error id + "environment argument is not an identifier")) + (lookup (id-var-name id empty-wrap) r))) + out)) + (new-mark)))) + +(define chi-body + ;; Here we create the empty wrap and new environment with placeholder + ;; as required by chi-internal. On return we extend the environment + ;; to recognize the var-labels as lexical variables and build a letrec + ;; binding them to the var-vals which we expand here. + (lambda (body outer-form r w) + (let* ((r (cons '("placeholder" . (placeholder)) r)) + (ribcage (make-empty-ribcage)) + (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))) + (body (map (lambda (x) (cons r (wrap x w))) body))) + (chi-internal ribcage outer-form body r + (lambda (exprs ids vars vals inits) + (when (null? exprs) (syntax-error outer-form "no expressions in body")) + (build-letrec no-source + vars + (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals) + (build-sequence no-source + (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs))))))))) + +(define chi-internal + ;; In processing the forms of the body, we create a new, empty wrap. + ;; This wrap is augmented (destructively) each time we discover that + ;; the next form is a definition. This is done: + ;; + ;; (1) to allow the first nondefinition form to be a call to + ;; one of the defined ids even if the id previously denoted a + ;; definition keyword or keyword for a macro expanding into a + ;; definition; + ;; (2) to prevent subsequent definition forms (but unfortunately + ;; not earlier ones) and the first nondefinition form from + ;; confusing one of the bound identifiers for an auxiliary + ;; keyword; and + ;; (3) so that we do not need to restart the expansion of the + ;; first nondefinition form, which is problematic anyway + ;; since it might be the first element of a begin that we + ;; have just spliced into the body (meaning if we restarted, + ;; we'd really need to restart with the begin or the macro + ;; call that expanded into the begin, and we'd have to give + ;; up allowing (begin <defn>+ <expr>+), which is itself + ;; problematic since we don't know if a begin contains only + ;; definitions until we've expanded it). + ;; + ;; Before processing the body, we also create a new environment + ;; containing a placeholder for the bindings we will add later and + ;; associate this environment with each form. In processing a + ;; let-syntax or letrec-syntax, the associated environment may be + ;; augmented with local keyword bindings, so the environment may + ;; be different for different forms in the body. Once we have + ;; gathered up all of the definitions, we evaluate the transformer + ;; expressions and splice into r at the placeholder the new variable + ;; and keyword bindings. This allows let-syntax or letrec-syntax + ;; forms local to a portion or all of the body to shadow the + ;; definition bindings. + ;; + ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced + ;; into the body. + ;; + ;; outer-form is fully wrapped w/source + (lambda (ribcage source-exp body r k) + (define return + (lambda (exprs ids vars vals inits) + (check-defined-ids source-exp ids) + (k exprs ids vars vals inits))) + (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '())) + (if (null? body) + (return body ids vars vals inits) + (let ((e (cdar body)) (er (caar body))) + (call-with-values + (lambda () (syntax-type e er empty-wrap no-source ribcage)) + (lambda (type value e w s) + (case type + ((define-form) + (parse-define e w s + (lambda (id rhs w) + (let ((id (wrap id w)) (label (gen-label))) + (let ((var (gen-var id))) + (extend-ribcage! ribcage id label) + (extend-store! r label (make-binding 'lexical var)) + (parse + (cdr body) + (cons id ids) + (cons var vars) + (cons (cons er (wrap rhs w)) vals) + inits)))))) + ((define-syntax-form) + (parse-define-syntax e w s + (lambda (id rhs w) + (let ((id (wrap id w)) + (label (gen-label)) + (exp (chi rhs (transformer-env er) w))) + (extend-ribcage! ribcage id label) + (extend-store! r label (make-binding 'deferred exp)) + (parse (cdr body) (cons id ids) vars vals inits))))) + ((module-form) + (let* ((*ribcage (make-empty-ribcage)) + (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w))))) + (parse-module e w s *w + (lambda (id exports forms) + (chi-internal *ribcage (source-wrap e w s) + (map (lambda (d) (cons er d)) forms) r + (lambda (*body *ids *vars *vals *inits) + ; valid bound ids checked already by chi-internal + (check-module-exports source-exp (flatten-exports exports) *ids) + (let ((iface (make-trimmed-interface exports)) + (vars (append *vars vars)) + (vals (append *vals vals)) + (inits (append inits *inits *body))) + (if id + (let ((label (gen-label))) + (extend-ribcage! ribcage id label) + (extend-store! r label (make-binding 'module iface)) + (parse (cdr body) (cons id ids) vars vals inits)) + (let () + (do-import! iface ribcage) + (parse (cdr body) (cons iface ids) vars vals inits)))))))))) + ((import-form) + (parse-import e w s + (lambda (mid) + (let ((mlabel (id-var-name mid empty-wrap))) + (let ((binding (lookup mlabel r))) + (case (car binding) + ((module) + (let ((iface (cdr binding))) + (when value (extend-ribcage-barrier! ribcage value)) + (do-import! iface ribcage) + (parse (cdr body) (cons iface ids) vars vals inits))) + ((displaced-lexical) (displaced-lexical-error mid)) + (else (syntax-error mid "import from unknown module")))))))) + ((begin-form) + (syntax-case e () + ((_ e1 ...) + (parse (let f ((forms (syntax (e1 ...)))) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w)) + (f (cdr forms))))) + ids vars vals inits)))) + ((local-syntax-form) + (chi-local-syntax value e er w s + (lambda (forms er w s) + (parse (let f ((forms forms)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w)) + (f (cdr forms))))) + ids vars vals inits)))) + (else ; found a non-definition + (return (cons (cons er (source-wrap e w s)) (cdr body)) + ids vars vals inits)))))))))) + +(define do-import! + (lambda (interface ribcage) + (let ((token (interface-token interface))) + (if token + (extend-ribcage-subst! ribcage token) + (vfor-each + (lambda (id) + (let ((label1 (id-var-name-loc id empty-wrap))) + (unless label1 + (syntax-error id "exported identifier not visible")) + (extend-ribcage! ribcage id label1))) + (interface-exports interface)))))) + +(define parse-module + (lambda (e w s *w k) + (define listify + (lambda (exports) + (if (null? exports) + '() + (cons (syntax-case (car exports) () + ((ex ...) (listify (syntax (ex ...)))) + (x (if (id? (syntax x)) + (wrap (syntax x) *w) + (syntax-error (source-wrap e w s) + "invalid exports list in")))) + (listify (cdr exports)))))) + (define return + (lambda (id exports forms) + (k id (listify exports) (map (lambda (x) (wrap x *w)) forms)))) + (syntax-case e () + ((_ (ex ...) form ...) + (return #f (syntax (ex ...)) (syntax (form ...)))) + ((_ mid (ex ...) form ...) + (id? (syntax mid)) + ; id receives old wrap so it won't be confused with id of same name + ; defined within the module + (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...)))) + (_ (syntax-error (source-wrap e w s)))))) + +(define parse-import + (lambda (e w s k) + (syntax-case e () + ((_ mid) + (id? (syntax mid)) + (k (wrap (syntax mid) w))) + (_ (syntax-error (source-wrap e w s)))))) + +(define parse-define + (lambda (e w s k) + (syntax-case e () + ((_ name val) + (id? (syntax name)) + (k (syntax name) (syntax val) w)) + ((_ (name . args) e1 e2 ...) + (and (id? (syntax name)) + (valid-bound-ids? (lambda-var-list (syntax args)))) + (k (wrap (syntax name) w) + (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w)) + empty-wrap)) + ((_ name) + (id? (syntax name)) + (k (wrap (syntax name) w) (syntax (void)) empty-wrap)) + (_ (syntax-error (source-wrap e w s)))))) + +(define parse-define-syntax + (lambda (e w s k) + (syntax-case e () + ((_ name val) + (id? (syntax name)) + (k (syntax name) (syntax val) w)) + (_ (syntax-error (source-wrap e w s)))))) + +(define chi-lambda-clause + (lambda (e c r w k) + (syntax-case c () + (((id ...) e1 e2 ...) + (let ((ids (syntax (id ...)))) + (if (not (valid-bound-ids? ids)) + (syntax-error e "invalid parameter list in") + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (k new-vars + (chi-body (syntax (e1 e2 ...)) + e + (extend-var-env* labels new-vars r) + (make-binding-wrap ids labels w))))))) + ((ids e1 e2 ...) + (let ((old-ids (lambda-var-list (syntax ids)))) + (if (not (valid-bound-ids? old-ids)) + (syntax-error e "invalid parameter list in") + (let ((labels (gen-labels old-ids)) + (new-vars (map gen-var old-ids))) + (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) + (if (null? ls1) + ls2 + (f (cdr ls1) (cons (car ls1) ls2)))) + (chi-body (syntax (e1 e2 ...)) + e + (extend-var-env* labels new-vars r) + (make-binding-wrap old-ids labels w))))))) + (_ (syntax-error e))))) + +(define chi-local-syntax + (lambda (rec? e r w s k) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (let ((ids (syntax (id ...)))) + (if (not (valid-bound-ids? ids)) + (invalid-ids-error (map (lambda (x) (wrap x w)) ids) + (source-wrap e w s) + "keyword") + (let ((labels (gen-labels ids))) + (let ((new-w (make-binding-wrap ids labels w))) + (k (syntax (e1 e2 ...)) + (extend-env* + labels + (let ((w (if rec? new-w w)) + (trans-r (transformer-env r))) + (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...)))) + r) + new-w + s)))))) + (_ (syntax-error (source-wrap e w s)))))) + +(define chi-void + (lambda () + (build-application no-source (build-primref no-source 'void) '()))) + +(define ellipsis? + (lambda (x) + (and (nonsymbol-id? x) + (literal-id=? x (syntax (... ...)))))) + +;;; data + +;;; strips all annotations from potentially circular reader output + +(define strip-annotation + (lambda (x parent) + (cond + ((pair? x) + (let ((new (cons #f #f))) + (when parent (set-annotation-stripped! parent new)) + (set-car! new (strip-annotation (car x) #f)) + (set-cdr! new (strip-annotation (cdr x) #f)) + new)) + ((annotation? x) + (or (annotation-stripped x) + (strip-annotation (annotation-expression x) x))) + ((vector? x) + (let ((new (make-vector (vector-length x)))) + (when parent (set-annotation-stripped! parent new)) + (let loop ((i (- (vector-length x) 1))) + (unless (fx< i 0) + (vector-set! new i (strip-annotation (vector-ref x i) #f)) + (loop (fx- i 1)))) + new)) + (else x)))) + +;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly +;;; on an annotation, strips the annotation as well. +;;; since only the head of a list is annotated by the reader, not each pair +;;; in the spine, we also check for pairs whose cars are annotated in case +;;; we've been passed the cdr of an annotated list + +(define strip* + (lambda (x w fn) + (if (top-marked? w) + (fn x) + (let f ((x x)) + (cond + ((syntax-object? x) + (strip* (syntax-object-expression x) (syntax-object-wrap x) fn)) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) + x + (cons a d)))) + ((vector? x) + (let ((old (vector->list x))) + (let ((new (map f old))) + (if (andmap eq? old new) x (list->vector new))))) + (else x)))))) + +(define strip + (lambda (x w) + (strip* x w + (lambda (x) + (if (or (annotation? x) (and (pair? x) (annotation? (car x)))) + (strip-annotation x #f) + x))))) + +;;; lexical variables + +(define gen-var + (lambda (id) + (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) + (if (annotation? id) + (build-lexical-var (annotation-source id) (annotation-expression id)) + (build-lexical-var no-source id))))) + +(define lambda-var-list + (lambda (vars) + (let lvl ((vars vars) (ls '()) (w empty-wrap)) + (cond + ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w)) + ((id? vars) (cons (wrap vars w) ls)) + ((null? vars) ls) + ((syntax-object? vars) + (lvl (syntax-object-expression vars) + ls + (join-wraps w (syntax-object-wrap vars)))) + ((annotation? vars) + (lvl (annotation-expression vars) ls w)) + ; include anything else to be caught by subsequent error + ; checking + (else (cons vars ls)))))) + + +; must precede global-extends + +(set! $sc-put-cte + (lambda (id b) + (define put-token + (lambda (id token) + (define cons-id + (lambda (id x) + (if (not x) id (cons id x)))) + (define weed + (lambda (id x) + (if (pair? x) + (if (bound-id=? (car x) id) ; could just check same-marks + (weed id (cdr x)) + (cons-id (car x) (weed id (cdr x)))) + (if (or (not x) (bound-id=? x id)) + #f + x)))) + (let ((sym (id-sym-name id))) + (let ((x (weed id (getprop sym token)))) + (if (and (not x) (symbol? id)) + ; don't pollute property list when all we have is a plain + ; top-level binding, since that's what's assumed anyway + (remprop sym token) + (putprop sym token (cons-id id x))))))) + (define sc-put-module + (lambda (exports token) + (vfor-each + (lambda (id) (put-token id token)) + exports))) + (define (put-cte id binding) + ;; making assumption here that all macros should be visible to the user and that system + ;; globals don't come through here (primvars.ss sets up their properties) + (let ((sym (if (symbol? id) id (id-var-name id empty-wrap)))) + (putprop sym '*sc-expander* binding))) + (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b)))) + (case (binding-type binding) + ((module) + (let ((iface (binding-value binding))) + (sc-put-module (interface-exports iface) (interface-token iface))) + (put-cte id binding)) + ((do-import) ; fake binding: id is module id, binding-value is import token + (let ((token (binding-value b))) + (let ((b (lookup (id-var-name id empty-wrap) null-env))) + (case (binding-type b) + ((module) + (let ((iface (binding-value b))) + (unless (eq? (interface-token iface) token) + (syntax-error id "import mismatch for module")) + (sc-put-module (interface-exports iface) '*top*))) + (else (syntax-error id "import from unknown module")))))) + (else (put-cte id binding)))))) + + +;;; core transformers + +(global-extend 'local-syntax 'letrec-syntax #t) +(global-extend 'local-syntax 'let-syntax #f) + + +(global-extend 'core 'fluid-let-syntax + (lambda (e r w s) + (syntax-case e () + ((_ ((var val) ...) e1 e2 ...) + (valid-bound-ids? (syntax (var ...))) + (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...))))) + (for-each + (lambda (id n) + (case (binding-type (lookup n r)) + ((displaced-lexical) (displaced-lexical-error (wrap id w))))) + (syntax (var ...)) + names) + (chi-body + (syntax (e1 e2 ...)) + (source-wrap e w s) + (extend-env* + names + (let ((trans-r (transformer-env r))) + (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...)))) + r) + w))) + (_ (syntax-error (source-wrap e w s)))))) + +(global-extend 'core 'quote + (lambda (e r w s) + (syntax-case e () + ((_ e) (build-data s (strip (syntax e) w))) + (_ (syntax-error (source-wrap e w s)))))) + +(global-extend 'core 'syntax + (let () + (define gen-syntax + (lambda (src e r maps ellipsis?) + (if (id? e) + (let ((label (id-var-name e empty-wrap))) + (let ((b (lookup label r))) + (if (eq? (binding-type b) 'syntax) + (call-with-values + (lambda () + (let ((var.lev (binding-value b))) + (gen-ref src (car var.lev) (cdr var.lev) maps))) + (lambda (var maps) (values `(ref ,var) maps))) + (if (ellipsis? e) + (syntax-error src "misplaced ellipsis in syntax form") + (values `(quote ,e) maps))))) + (syntax-case e () + ((dots e) + (ellipsis? (syntax dots)) + (gen-syntax src (syntax e) r maps (lambda (x) #f))) + ((x dots . y) + ; this could be about a dozen lines of code, except that we + ; choose to handle (syntax (x ... ...)) forms + (ellipsis? (syntax dots)) + (let f ((y (syntax y)) + (k (lambda (maps) + (call-with-values + (lambda () + (gen-syntax src (syntax x) r + (cons '() maps) ellipsis?)) + (lambda (x maps) + (if (null? (car maps)) + (syntax-error src + "extra ellipsis in syntax form") + (values (gen-map x (car maps)) + (cdr maps)))))))) + (syntax-case y () + ((dots . y) + (ellipsis? (syntax dots)) + (f (syntax y) + (lambda (maps) + (call-with-values + (lambda () (k (cons '() maps))) + (lambda (x maps) + (if (null? (car maps)) + (syntax-error src + "extra ellipsis in syntax form") + (values (gen-mappend x (car maps)) + (cdr maps)))))))) + (_ (call-with-values + (lambda () (gen-syntax src y r maps ellipsis?)) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) + (values (gen-append x y) maps))))))))) + ((x . y) + (call-with-values + (lambda () (gen-syntax src (syntax x) r maps ellipsis?)) + (lambda (x maps) + (call-with-values + (lambda () (gen-syntax src (syntax y) r maps ellipsis?)) + (lambda (y maps) (values (gen-cons x y) maps)))))) + (#(e1 e2 ...) + (call-with-values + (lambda () + (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?)) + (lambda (e maps) (values (gen-vector e) maps)))) + (_ (values `(quote ,e) maps)))))) + + (define gen-ref + (lambda (src var level maps) + (if (fx= level 0) + (values var maps) + (if (null? maps) + (syntax-error src "missing ellipsis in syntax form") + (call-with-values + (lambda () (gen-ref src var (fx- level 1) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values inner-var + (cons (cons (cons outer-var inner-var) + (car maps)) + outer-maps))))))))))) + + (define gen-mappend + (lambda (e map-env) + `(apply (primitive append) ,(gen-map e map-env)))) + + (define gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) `(ref ,(car x))) map-env))) + (cond + ((eq? (car e) 'ref) + ; identity map equivalence: + ; (map (lambda (x) x) y) == y + (car actuals)) + ((andmap + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + ; eta map equivalence: + ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) + `(map (primitive ,(car e)) + ,@(map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e)))) + (else `(map (lambda ,formals ,e) ,@actuals)))))) + + (define gen-cons + (lambda (x y) + (case (car y) + ((quote) + (if (eq? (car x) 'quote) + `(quote (,(cadr x) . ,(cadr y))) + (if (eq? (cadr y) '()) + `(list ,x) + `(cons ,x ,y)))) + ((list) `(list ,x ,@(cdr y))) + (else `(cons ,x ,y))))) + + (define gen-append + (lambda (x y) + (if (equal? y '(quote ())) + x + `(append ,x ,y)))) + + (define gen-vector + (lambda (x) + (cond + ((eq? (car x) 'list) `(vector ,@(cdr x))) + ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) + (else `(list->vector ,x))))) + + + (define regen + (lambda (x) + (case (car x) + ((ref) (build-lexical-reference 'value no-source (cadr x))) + ((primitive) (build-primref no-source (cadr x))) + ((quote) (build-data no-source (cadr x))) + ((lambda) (build-lambda no-source (cadr x) (regen (caddr x)))) + ((map) (let ((ls (map regen (cdr x)))) + (build-application no-source + (if (fx= (length ls) 2) + (build-primref no-source 'map) + ; really need to do our own checking here + (build-primref no-source 2 'map)) ; require error check + ls))) + (else (build-application no-source + (build-primref no-source (car x)) + (map regen (cdr x))))))) + + (lambda (e r w s) + (let ((e (source-wrap e w s))) + (syntax-case e () + ((_ x) + (call-with-values + (lambda () (gen-syntax e (syntax x) r '() ellipsis?)) + (lambda (e maps) (regen e)))) + (_ (syntax-error e))))))) + + +(global-extend 'core 'lambda + (lambda (e r w s) + (syntax-case e () + ((_ . c) + (chi-lambda-clause (source-wrap e w s) (syntax c) r w + (lambda (vars body) (build-lambda s vars body))))))) + + +(global-extend 'core 'letrec + (lambda (e r w s) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (let ((ids (syntax (id ...)))) + (if (not (valid-bound-ids? ids)) + (invalid-ids-error (map (lambda (x) (wrap x w)) ids) + (source-wrap e w s) "bound variable") + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env* labels new-vars r))) + (build-letrec s + new-vars + (map (lambda (x) (chi x r w)) (syntax (val ...))) + (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w))))))) + (_ (syntax-error (source-wrap e w s)))))) + +(global-extend 'core 'if + (lambda (e r w s) + (syntax-case e () + ((_ test then) + (build-conditional s + (chi (syntax test) r w) + (chi (syntax then) r w) + (chi-void))) + ((_ test then else) + (build-conditional s + (chi (syntax test) r w) + (chi (syntax then) r w) + (chi (syntax else) r w))) + (_ (syntax-error (source-wrap e w s)))))) + + + +(global-extend 'set! 'set! '()) + +(global-extend 'begin 'begin '()) + +(global-extend 'module-key 'module '()) +(global-extend 'import 'import #f) +(global-extend 'import 'import-only #t) + +(global-extend 'define 'define '()) + +(global-extend 'define-syntax 'define-syntax '()) + +(global-extend 'eval-when 'eval-when '()) + +(global-extend 'core 'syntax-case + (let () + (define convert-pattern + ; accepts pattern & keys + ; returns syntax-dispatch pattern & ids + (lambda (pattern keys) + (let cvt ((p pattern) (n 0) (ids '())) + (if (id? p) + (if (bound-id-member? p keys) + (values (vector 'free-id p) ids) + (values 'any (cons (cons p n) ids))) + (syntax-case p () + ((x dots) + (ellipsis? (syntax dots)) + (call-with-values + (lambda () (cvt (syntax x) (fx+ n 1) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) + ids)))) + ((x . y) + (call-with-values + (lambda () (cvt (syntax y) n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt (syntax x) n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) + (() (values '() ids)) + (#(x ...) + (call-with-values + (lambda () (cvt (syntax (x ...)) n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + (x (values (vector 'atom (strip p empty-wrap)) ids))))))) + + (define build-dispatch-call + (lambda (pvars exp y r) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-application no-source + (build-primref no-source 'apply) + (list (build-lambda no-source new-vars + (chi exp + (extend-env* + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap))) + y)))))) + + (define gen-clause + (lambda (x keys clauses r pat fender exp) + (call-with-values + (lambda () (convert-pattern pat keys)) + (lambda (p pvars) + (cond + ((not (distinct-bound-ids? (map car pvars))) + (invalid-ids-error (map car pvars) pat "pattern variable")) + ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) + (syntax-error pat + "misplaced ellipsis in syntax-case pattern")) + (else + (let ((y (gen-var 'tmp))) + ; fat finger binding and references to temp variable y + (build-application no-source + (build-lambda no-source (list y) + (let-syntax ((y (identifier-syntax + (build-lexical-reference 'value no-source y)))) + (build-conditional no-source + (syntax-case fender () + (#t y) + (_ (build-conditional no-source + y + (build-dispatch-call pvars fender y r) + (build-data no-source #f)))) + (build-dispatch-call pvars exp y r) + (gen-syntax-case x keys clauses r)))) + (list (if (eq? p 'any) + (build-application no-source + (build-primref no-source 'list) + (list (build-lexical-reference no-source 'value x))) + (build-application no-source + (build-primref no-source '$syntax-dispatch) + (list (build-lexical-reference no-source 'value x) + (build-data no-source p))))))))))))) + + (define gen-syntax-case + (lambda (x keys clauses r) + (if (null? clauses) + (build-application no-source + (build-primref no-source 'syntax-error) + (list (build-lexical-reference 'value no-source x))) + (syntax-case (car clauses) () + ((pat exp) + (if (and (id? (syntax pat)) + (not (bound-id-member? (syntax pat) keys)) + (not (ellipsis? (syntax pat)))) + (let ((label (gen-label)) + (var (gen-var (syntax pat)))) + (build-application no-source + (build-lambda no-source (list var) + (chi (syntax exp) + (extend-env label (make-binding 'syntax `(,var . 0)) r) + (make-binding-wrap (syntax (pat)) + (list label) empty-wrap))) + (list (build-lexical-reference 'value no-source x)))) + (gen-clause x keys (cdr clauses) r + (syntax pat) #t (syntax exp)))) + ((pat fender exp) + (gen-clause x keys (cdr clauses) r + (syntax pat) (syntax fender) (syntax exp))) + (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) + + (lambda (e r w s) + (let ((e (source-wrap e w s))) + (syntax-case e () + ((_ val (key ...) m ...) + (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) + (syntax (key ...))) + (let ((x (gen-var 'tmp))) + ; fat finger binding and references to temp variable x + (build-application s + (build-lambda no-source (list x) + (gen-syntax-case x + (syntax (key ...)) (syntax (m ...)) + r)) + (list (chi (syntax val) r empty-wrap)))) + (syntax-error e "invalid literals list in")))))))) + +;;; The portable sc-expand seeds chi-top's mode m with 'e (for +;;; evaluating) and esew (which stands for "eval syntax expanders +;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e +;;; if we are compiling a file, and esew is set to +;;; (eval-syntactic-expanders-when), which defaults to the list +;;; '(compile load eval). This means that, by default, top-level +;;; syntactic definitions are evaluated immediately after they are +;;; expanded, and the expanded definitions are also residualized into +;;; the object file if we are compiling a file. +(set! sc-expand + (let ((m 'e) (esew '(eval)) + (user-ribcage + (let ((ribcage (make-empty-ribcage))) + (extend-ribcage-subst! ribcage '*top*) + ribcage))) + (let ((user-top-wrap + (make-wrap (wrap-marks top-wrap) + (cons user-ribcage (wrap-subst top-wrap))))) + (lambda (x) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (chi-top x null-env user-top-wrap m esew user-ribcage)))))) + +(set! identifier? + (lambda (x) + (nonsymbol-id? x))) + +(set! datum->syntax-object + (lambda (id datum) + (arg-check nonsymbol-id? id 'datum->syntax-object) + (make-syntax-object datum (syntax-object-wrap id)))) + +(set! syntax-object->datum + ; accepts any object, since syntax objects may consist partially + ; or entirely of unwrapped, nonsymbolic data + (lambda (x) + (strip x empty-wrap))) + +(set! generate-temporaries + (lambda (ls) + (arg-check list? ls 'generate-temporaries) + (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls))) + +(set! free-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'free-identifier=?) + (arg-check nonsymbol-id? y 'free-identifier=?) + (free-id=? x y))) + +(set! bound-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'bound-identifier=?) + (arg-check nonsymbol-id? y 'bound-identifier=?) + (bound-id=? x y))) + + +(set! syntax-error + (lambda (object . messages) + (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages) + (let ((message (if (null? messages) + "invalid syntax" + (apply string-append messages)))) + (error-hook #f message (strip object empty-wrap))))) + +;;; syntax-dispatch expects an expression and a pattern. If the expression +;;; matches the pattern a list of the matching expressions for each +;;; "any" is returned. Otherwise, #f is returned. (This use of #f will +;;; not work on r4rs implementations that violate the ieee requirement +;;; that #f and () be distinct.) + +;;; The expression is matched with the pattern as follows: + +;;; pattern: matches: +;;; () empty list +;;; any anything +;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2) +;;; each-any (any*) +;;; #(free-id <key>) <key> with free-identifier=? +;;; #(each <pattern>) (<pattern>*) +;;; #(vector <pattern>) (list->vector <pattern>) +;;; #(atom <object>) <object> with "equal?" + +;;; Vector cops out to pair under assumption that vectors are rare. If +;;; not, should convert to: +;;; #(vector <pattern>*) #(<pattern>*) + +(let () + +(define match-each + (lambda (e p w) + (cond + ((annotation? e) + (match-each (annotation-expression e) p w)) + ((pair? e) + (let ((first (match (car e) p w '()))) + (and first + (let ((rest (match-each (cdr e) p w))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax-object? e) + (match-each (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)))) + (else #f)))) + +(define match-each-any + (lambda (e w) + (cond + ((annotation? e) + (match-each-any (annotation-expression e) w)) + ((pair? e) + (let ((l (match-each-any (cdr e) w))) + (and l (cons (wrap (car e) w) l)))) + ((null? e) '()) + ((syntax-object? e) + (match-each-any (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)))) + (else #f)))) + +(define match-empty + (lambda (p r) + (cond + ((null? p) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else + (case (vector-ref p 0) + ((each) (match-empty (vector-ref p 1) r)) + ((free-id atom) r) + ((vector) (match-empty (vector-ref p 1) r))))))) + +(define match* + (lambda (e p w r) + (cond + ((null? p) (and (null? e) r)) + ((pair? p) + (and (pair? e) (match (car e) (car p) w + (match (cdr e) (cdr p) w r)))) + ((eq? p 'each-any) + (let ((l (match-each-any e w))) (and l (cons l r)))) + (else + (case (vector-ref p 0) + ((each) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((l (match-each e (vector-ref p 1) w))) + (and l + (let collect ((l l)) + (if (null? (car l)) + r + (cons (map car l) (collect (map cdr l))))))))) + ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r)) + ((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) + ((vector) + (and (vector? e) + (match (vector->list e) (vector-ref p 1) w r)))))))) + +(define match + (lambda (e p w r) + (cond + ((not r) #f) + ((eq? p 'any) (cons (wrap e w) r)) + ((syntax-object? e) + (match* + (unannotate (syntax-object-expression e)) + p + (join-wraps w (syntax-object-wrap e)) + r)) + (else (match* (unannotate e) p w r))))) + +(set! $syntax-dispatch + (lambda (e p) + (cond + ((eq? p 'any) (list e)) + ((syntax-object? e) + (match* (unannotate (syntax-object-expression e)) + p (syntax-object-wrap e) '())) + (else (match* (unannotate e) p empty-wrap '()))))) +)) + + +(define-syntax with-syntax + (lambda (x) + (syntax-case x () + ((_ () e1 e2 ...) + (syntax (begin e1 e2 ...))) + ((_ ((out in)) e1 e2 ...) + (syntax (syntax-case in () (out (begin e1 e2 ...))))) + ((_ ((out in) ...) e1 e2 ...) + (syntax (syntax-case (list in ...) () + ((out ...) (begin e1 e2 ...)))))))) + +(define-syntax syntax-rules + (lambda (x) + (syntax-case x () + ((_ (k ...) ((keyword . pattern) template) ...) + (syntax (lambda (x) + (syntax-case x (k ...) + ((dummy . pattern) (syntax template)) + ...))))))) + +(define-syntax or + (lambda (x) + (syntax-case x () + ((_) (syntax #f)) + ((_ e) (syntax e)) + ((_ e1 e2 e3 ...) + (syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) + +(define-syntax and + (lambda (x) + (syntax-case x () + ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) + ((_ e) (syntax e)) + ((_) (syntax #t))))) + +(define-syntax let + (lambda (x) + (syntax-case x () + ((_ ((x v) ...) e1 e2 ...) + (andmap identifier? (syntax (x ...))) + (syntax ((lambda (x ...) e1 e2 ...) v ...))) + ((_ f ((x v) ...) e1 e2 ...) + (andmap identifier? (syntax (f x ...))) + (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f) + v ...)))))) + +(define-syntax let* + (lambda (x) + (syntax-case x () + ((let* ((x v) ...) e1 e2 ...) + (andmap identifier? (syntax (x ...))) + (let f ((bindings (syntax ((x v) ...)))) + (if (null? bindings) + (syntax (let () e1 e2 ...)) + (with-syntax ((body (f (cdr bindings))) + (binding (car bindings))) + (syntax (let (binding) body))))))))) + +(define-syntax cond + (lambda (x) + (syntax-case x () + ((_ m1 m2 ...) + (let f ((clause (syntax m1)) (clauses (syntax (m2 ...)))) + (if (null? clauses) + (syntax-case clause (else =>) + ((else e1 e2 ...) (syntax (begin e1 e2 ...))) + ((e0) (syntax (let ((t e0)) (if t t)))) + ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t))))) + ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...)))) + (_ (syntax-error x))) + (with-syntax ((rest (f (car clauses) (cdr clauses)))) + (syntax-case clause (else =>) + ((e0) (syntax (let ((t e0)) (if t t rest)))) + ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest)))) + ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest))) + (_ (syntax-error x)))))))))) + +(define-syntax do + (lambda (orig-x) + (syntax-case orig-x () + ((_ ((var init . step) ...) (e0 e1 ...) c ...) + (with-syntax (((step ...) + (map (lambda (v s) + (syntax-case s () + (() v) + ((e) (syntax e)) + (_ (syntax-error orig-x)))) + (syntax (var ...)) + (syntax (step ...))))) + (syntax-case (syntax (e1 ...)) () + (() (syntax (let doloop ((var init) ...) + (if (not e0) + (begin c ... (doloop step ...)))))) + ((e1 e2 ...) + (syntax (let doloop ((var init) ...) + (if e0 + (begin e1 e2 ...) + (begin c ... (doloop step ...)))))))))))) + +(define-syntax quasiquote + (letrec + ; these are here because syntax-case uses literal-identifier=?, + ; and we want the more precise free-identifier=? + ((isquote? (lambda (x) + (and (identifier? x) + (free-identifier=? x (syntax quote))))) + (islist? (lambda (x) + (and (identifier? x) + (free-identifier=? x (syntax list))))) + (iscons? (lambda (x) + (and (identifier? x) + (free-identifier=? x (syntax cons))))) + (quote-nil? (lambda (x) + (syntax-case x () + ((quote? ()) (isquote? (syntax quote?))) + (_ #f)))) + (quasilist* + (lambda (x y) + (let f ((x x)) + (if (null? x) + y + (quasicons (car x) (f (cdr x))))))) + (quasicons + (lambda (x y) + (with-syntax ((x x) (y y)) + (syntax-case (syntax y) () + ((quote? dy) + (isquote? (syntax quote?)) + (syntax-case (syntax x) () + ((quote? dx) + (isquote? (syntax quote?)) + (syntax (quote (dx . dy)))) + (_ (if (null? (syntax dy)) + (syntax (list x)) + (syntax (cons x y)))))) + ((listp . stuff) + (islist? (syntax listp)) + (syntax (list x . stuff))) + (else (syntax (cons x y))))))) + (quasiappend + (lambda (x y) + (let ((ls (let f ((x x)) + (if (null? x) + (if (quote-nil? y) + '() + (list y)) + (if (quote-nil? (car x)) + (f (cdr x)) + (cons (car x) (f (cdr x)))))))) + (cond + ((null? ls) (syntax (quote ()))) + ((null? (cdr ls)) (car ls)) + (else (with-syntax (((p ...) ls)) + (syntax (append p ...)))))))) + (quasivector + (lambda (x) + (with-syntax ((pat-x x)) + (syntax-case (syntax pat-x) () + ((quote? (x ...)) + (isquote? (syntax quote?)) + (syntax (quote #(x ...)))) + (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls)))) + (syntax-case x () + ((quote? (x ...)) + (isquote? (syntax quote?)) + (k (syntax ((quote x) ...)))) + ((listp x ...) + (islist? (syntax listp)) + (k (syntax (x ...)))) + ((cons? x y) + (iscons? (syntax cons?)) + (f (syntax y) (lambda (ls) (k (cons (syntax x) ls))))) + (else + (syntax (list->vector pat-x)))))))))) + (quasi + (lambda (p lev) + (syntax-case p (unquote unquote-splicing quasiquote) + ((unquote p) + (if (= lev 0) + (syntax p) + (quasicons (syntax (quote unquote)) + (quasi (syntax (p)) (- lev 1))))) + (((unquote p ...) . q) + (if (= lev 0) + (quasilist* (syntax (p ...)) (quasi (syntax q) lev)) + (quasicons (quasicons (syntax (quote unquote)) + (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) + (((unquote-splicing p ...) . q) + (if (= lev 0) + (quasiappend (syntax (p ...)) (quasi (syntax q) lev)) + (quasicons (quasicons (syntax (quote unquote-splicing)) + (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) + ((quasiquote p) + (quasicons (syntax (quote quasiquote)) + (quasi (syntax (p)) (+ lev 1)))) + ((p . q) + (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev))) + (#(x ...) (quasivector (quasi (syntax (x ...)) lev))) + (p (syntax (quote p))))))) + (lambda (x) + (syntax-case x () + ((_ e) (quasi (syntax e) 0)))))) + +(define-syntax include + (lambda (x) + (define read-file + (lambda (fn k) + (let ((p (open-input-file fn))) + (let f () + (let ((x (read p))) + (if (eof-object? x) + (begin (close-input-port p) '()) + (cons (datum->syntax-object k x) (f)))))))) + (syntax-case x () + ((k filename) + (let ((fn (syntax-object->datum (syntax filename)))) + (with-syntax (((exp ...) (read-file fn (syntax k)))) + (syntax (begin exp ...)))))))) + +(define-syntax unquote + (lambda (x) + (syntax-case x () + ((_ e ...) + (syntax-error x + "expression not valid outside of quasiquote"))))) + +(define-syntax unquote-splicing + (lambda (x) + (syntax-case x () + ((_ e ...) + (syntax-error x + "expression not valid outside of quasiquote"))))) + +(define-syntax case + (lambda (x) + (syntax-case x () + ((_ e m1 m2 ...) + (with-syntax + ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...)))) + (if (null? clauses) + (syntax-case clause (else) + ((else e1 e2 ...) (syntax (begin e1 e2 ...))) + (((k ...) e1 e2 ...) + (syntax (if (memv t '(k ...)) (begin e1 e2 ...)))) + (_ (syntax-error x))) + (with-syntax ((rest (f (car clauses) (cdr clauses)))) + (syntax-case clause (else) + (((k ...) e1 e2 ...) + (syntax (if (memv t '(k ...)) + (begin e1 e2 ...) + rest))) + (_ (syntax-error x)))))))) + (syntax (let ((t e)) body))))))) + +(define-syntax identifier-syntax + (lambda (x) + (syntax-case x (set!) + ((_ e) + (syntax + (lambda (x) + (syntax-case x () + (id + (identifier? (syntax id)) + (syntax e)) + ((_ x (... ...)) + (syntax (e x (... ...)))))))) + ((_ (id exp1) ((set! var val) exp2)) + (and (identifier? (syntax id)) (identifier? (syntax var))) + (syntax + (cons 'macro! + (lambda (x) + (syntax-case x (set!) + ((set! var val) (syntax exp2)) + ((id x (... ...)) (syntax (exp1 x (... ...)))) + (id (identifier? (syntax id)) (syntax exp1)))))))))) + diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm new file mode 100644 index 000000000..67f8d74cf --- /dev/null +++ b/module/language/r5rs/spec.scm @@ -0,0 +1,63 @@ +;;; Guile R5RS + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language r5rs spec) + #:use-module (system base language) + #:use-module (language r5rs expand) + #:use-module (language r5rs translate) + #:export (r5rs)) + + +;;; +;;; Translator +;;; + +(define (translate x) (if (pair? x) (translate-pair x) x)) + +(define (translate-pair x) + (let ((head (car x)) (rest (cdr x))) + (case head + ((quote) (cons '@quote rest)) + ((define set! if and or begin) + (cons (symbol-append '@ head) (map translate rest))) + ((let let* letrec) + (cons* (symbol-append '@ head) + (map (lambda (b) (cons (car b) (map translate (cdr b)))) + (car rest)) + (map translate (cdr rest)))) + ((lambda) + (cons* '@lambda (car rest) (map translate (cdr rest)))) + (else + (cons (translate head) (map translate rest)))))) + + +;;; +;;; Language definition +;;; + +(define-language r5rs + #:title "Standard Scheme (R5RS + syntax-case)" + #:version "0.3" + #:reader read + #:expander expand + #:translator translate + #:printer write +;; #:environment (global-ref 'Language::R5RS::core) + ) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm new file mode 100644 index 000000000..dc03af6cf --- /dev/null +++ b/module/language/scheme/compile-ghil.scm @@ -0,0 +1,494 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language scheme compile-ghil) + #:use-module (system base pmatch) + #:use-module (system base language) + #:use-module (language ghil) + #:use-module (language scheme inline) + #:use-module (system vm objcode) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (language tree-il) + #:use-module ((system base compile) #:select (syntax-error)) + #:export (compile-ghil translate-1 + *translate-table* define-scheme-translator)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-ghil-env env) + (cond ((not env) (make-ghil-toplevel-env)) + ((module? env) (make-ghil-toplevel-env)) + ((pair? env) + (if (struct? (cadr env)) + (cadr env) + (ghil-env-dereify (cadr env)))) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + + + +(define (compile-ghil x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (call-with-ghil-environment (cenv-ghil-env e) '() + (lambda (env vars) + (let ((x (tree-il->scheme + (sc-expand x 'c '(compile load eval))))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv)))))))) + + +;;; +;;; Translator +;;; + +(define *forbidden-primitives* + ;; Guile's `procedure->macro' family is evil because it crosses the + ;; compilation boundary. One solution might be to evaluate calls to + ;; `procedure->memoizing-macro' at compilation time, but it may be more + ;; compicated than that. + '(procedure->syntax procedure->macro)) + +;; Looks up transformers relative to the current module at +;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. +;; +;; FIXME shadowing lexicals? +(define (lookup-transformer head retrans) + (define (module-ref/safe mod sym) + (and mod + (and=> (module-variable mod sym) + (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))))) + (let* ((mod (current-module)) + (val (cond + ((symbol? head) (module-ref/safe mod head)) + ((pmatch head + ((@ ,modname ,sym) + (module-ref/safe (resolve-interface modname) sym)) + ((@@ ,modname ,sym) + (module-ref/safe (resolve-module modname) sym)) + (else #f))) + (else #f)))) + (cond + ((hashq-ref *translate-table* val)) + + ((macro? val) + (syntax-error #f "unknown kind of macro" head)) + + (else #f)))) + +(define (translate-1 e l x) + (let ((l (or l (location x)))) + (define (retrans x) (translate-1 e #f x)) + (define (retrans/loc x) (translate-1 e (or (location x) l) x)) + (cond ((pair? x) + (let ((head (car x)) (tail (cdr x))) + (cond + ((lookup-transformer head retrans/loc) + => (lambda (t) (t e l x))) + + ;; FIXME: lexical/module overrides of forbidden primitives + ((memq head *forbidden-primitives*) + (syntax-error l (format #f "`~a' is forbidden" head) + (cons head tail))) + + (else + (let ((tail (map retrans tail))) + (or (and (symbol? head) + (try-inline-with-env e l (cons head tail))) + (make-ghil-call e l (retrans head) tail))))))) + + ((symbol? x) + (make-ghil-ref e l (ghil-var-for-ref! e x))) + + ;; fixme: non-self-quoting objects like #<foo> + (else + (make-ghil-quote e l x))))) + +(define (valid-bindings? bindings . it-is-for-do) + (define (valid-binding? b) + (pmatch b + ((,sym ,var) (guard (symbol? sym)) #t) + ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) + (else #f))) + (and (list? bindings) (and-map valid-binding? bindings))) + +(define *translate-table* (make-hash-table)) + +(define-macro (-> form) + `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form))) + +(define-macro (define-scheme-translator sym . clauses) + `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) + (module-ref (current-module) ',sym) + (lambda (e l exp) + (define (retrans x) + ((@ (language scheme compile-ghil) translate-1) + e + (or ((@@ (language scheme compile-ghil) location) x) l) + x)) + (define syntax-error (@ (system base compile) syntax-error)) + (pmatch (cdr exp) + ,@clauses + ,@(if (assq 'else clauses) '() + `((else + (syntax-error l (format #f "bad ~A" ',sym) exp)))))))) + +(define-scheme-translator quote + ;; (quote OBJ) + ((,obj) + (-> (quote obj)))) + +(define-scheme-translator quasiquote + ;; (quasiquote OBJ) + ((,obj) + (-> (quasiquote (trans-quasiquote e l obj 0))))) + +(define-scheme-translator define + ;; (define NAME VAL) + ((,name ,val) (guard (symbol? name) + (ghil-toplevel-env? (ghil-env-parent e))) + (-> (define (ghil-var-define! (ghil-env-parent e) name) + (maybe-name-value! (retrans val) name)))) + ;; (define (NAME FORMALS...) BODY...) + (((,name . ,formals) . ,body) (guard (symbol? name)) + ;; -> (define NAME (lambda FORMALS BODY...)) + (retrans `(define ,name (lambda ,formals ,@body))))) + +(define-scheme-translator set! + ;; (set! NAME VAL) + ((,name ,val) (guard (symbol? name)) + (-> (set (ghil-var-for-set! e name) (retrans val)))) + + ;; FIXME: Would be nice to verify the values of @ and @@ relative + ;; to imported modules... + (((@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@))) + (-> (set (ghil-var-at-module! e modname name #t) (retrans val)))) + + (((@@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@@))) + (-> (set (ghil-var-at-module! e modname name #f) (retrans val)))) + + ;; (set! (NAME ARGS...) VAL) + (((,name . ,args) ,val) (guard (symbol? name)) + ;; -> ((setter NAME) ARGS... VAL) + (retrans `((setter ,name) . (,@args ,val))))) + +(define-scheme-translator if + ;; (if TEST THEN [ELSE]) + ((,test ,then) + (-> (if (retrans test) (retrans then) (retrans '(begin))))) + ((,test ,then ,else) + (-> (if (retrans test) (retrans then) (retrans else))))) + +(define-scheme-translator and + ;; (and EXPS...) + (,tail + (-> (and (map retrans tail))))) + +(define-scheme-translator or + ;; (or EXPS...) + (,tail + (-> (or (map retrans tail))))) + +(define-scheme-translator begin + ;; (begin EXPS...) + (,tail + (-> (begin (map retrans tail))))) + +(define-scheme-translator let + ;; (let NAME ((SYM VAL) ...) BODY...) + ((,name ,bindings . ,body) (guard (symbol? name) + (valid-bindings? bindings)) + ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) + (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) + (,name ,@(map cadr bindings))))) + + ;; (let () BODY...) + ((() . ,body) + ;; Note: this differs from `begin' + (-> (begin (list (trans-body e l body))))) + + ;; (let ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (let ((vals (map (lambda (b) + (maybe-name-value! (retrans (cadr b)) (car b))) + bindings))) + (call-with-ghil-bindings e (map car bindings) + (lambda (vars) + (-> (bind vars vals (trans-body e l body)))))))) + +(define-scheme-translator let* + ;; (let* ((SYM VAL) ...) BODY...) + ((() . ,body) + (retrans `(let () ,@body))) + ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) + (retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) + +(define-scheme-translator letrec + ;; (letrec ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? bindings)) + (call-with-ghil-bindings e (map car bindings) + (lambda (vars) + (let ((vals (map (lambda (b) + (maybe-name-value! + (retrans (cadr b)) (car b))) + bindings))) + (-> (bind vars vals (trans-body e l body)))))))) + +(define-scheme-translator cond + ;; (cond (CLAUSE BODY...) ...) + (() (retrans '(begin))) + (((else . ,body)) (retrans `(begin ,@body))) + (((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) + (((,test => ,proc) . ,rest) + ;; FIXME hygiene! + (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))) + (((,test . ,body) . ,rest) + (retrans `(if ,test (begin ,@body) (cond ,@rest))))) + +(define-scheme-translator case + ;; (case EXP ((KEY...) BODY...) ...) + ((,exp . ,clauses) + (retrans + ;; FIXME hygiene! + `(let ((_t ,exp)) + ,(let loop ((ls clauses)) + (cond ((null? ls) '(begin)) + ((eq? (caar ls) 'else) `(begin ,@(cdar ls))) + (else `(if (memv _t ',(caar ls)) + (begin ,@(cdar ls)) + ,(loop (cdr ls)))))))))) + +(define-scheme-translator do + ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) + ((,bindings (,test . ,result) . ,body) + (let ((sym (map car bindings)) + (val (map cadr bindings)) + (update (map cddr bindings))) + (define (next s x) (if (pair? x) (car x) s)) + (retrans + ;; FIXME hygiene! + `(letrec ((_l (lambda ,sym + (if ,test + (begin ,@result) + (begin ,@body + (_l ,@(map next sym update))))))) + (_l ,@val)))))) + +(define-scheme-translator lambda + ;; (lambda FORMALS BODY...) + ((,formals . ,body) + (receive (syms rest) (parse-formals formals) + (call-with-ghil-environment e syms + (lambda (e vars) + (receive (meta body) (parse-lambda-meta body) + (-> (lambda vars rest meta (trans-body e l body))))))))) + +(define-scheme-translator delay + ;; FIXME not hygienic + ((,expr) + (retrans `(make-promise (lambda () ,expr))))) + +(define-scheme-translator @ + ((,modname ,sym) + (-> (ref (ghil-var-at-module! e modname sym #t))))) + +(define-scheme-translator @@ + ((,modname ,sym) + (-> (ref (ghil-var-at-module! e modname sym #f))))) + +(define *the-compile-toplevel-symbol* 'compile-toplevel) +(define-scheme-translator eval-when + ((,when . ,body) (guard (list? when) (and-map symbol? when)) + (if (memq 'compile when) + (primitive-eval `(begin . ,body))) + (if (memq 'load when) + (retrans `(begin . ,body)) + (retrans `(begin))))) + +(define-scheme-translator apply + ;; FIXME: not hygienic, relies on @apply not being shadowed + (,args (retrans `(@apply ,@args)))) + +;; FIXME: we could add inliners for `list' and `vector' + +(define-scheme-translator @apply + ((,proc ,arg1 . ,args) + (let ((args (cons (retrans arg1) (map retrans args)))) + (cond ((and (symbol? proc) + (not (ghil-var-is-bound? e proc)) + (and=> (module-variable (current-module) proc) + (lambda (var) + (and (variable-bound? var) + (lookup-apply-transformer (variable-ref var)))))) + ;; that is, a variable, not part of this compilation + ;; unit, but defined in the toplevel environment, and has + ;; an apply transformer registered + => (lambda (t) (t e l args))) + (else + (-> (inline 'apply (cons (retrans proc) args)))))))) + +(define-scheme-translator call-with-values + ;; FIXME: not hygienic, relies on @call-with-values not being shadowed + ((,producer ,consumer) + (retrans `(@call-with-values ,producer ,consumer))) + (else #f)) + +(define-scheme-translator @call-with-values + ((,producer ,consumer) + (-> (mv-call (retrans producer) (retrans consumer))))) + +(define-scheme-translator call-with-current-continuation + ;; FIXME: not hygienic, relies on @call-with-current-continuation + ;; not being shadowed + ((,proc) + (retrans `(@call-with-current-continuation ,proc))) + (else #f)) + +(define-scheme-translator @call-with-current-continuation + ((,proc) + (-> (inline 'call/cc (list (retrans proc)))))) + +(define-scheme-translator receive + ((,formals ,producer-exp . ,body) + ;; Lovely, self-referential usage. Not strictly necessary, the + ;; macro would do the trick; but it's good to test the mv-bind + ;; code. + (receive (syms rest) (parse-formals formals) + (let ((producer (retrans `(lambda () ,producer-exp)))) + (call-with-ghil-bindings e syms + (lambda (vars) + (-> (mv-bind producer vars rest + (trans-body e l body))))))))) + +(define-scheme-translator values + ((,x) (retrans x)) + (,args + (-> (values (map retrans args))))) + +(define (lookup-apply-transformer proc) + (cond ((eq? proc values) + (lambda (e l args) + (-> (values* args)))) + (else #f))) + +(define (trans-quasiquote e l x level) + (cond ((not (pair? x)) x) + ((memq (car x) '(unquote unquote-splicing)) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) + (cond + ((zero? level) + (if (eq? (car x) 'unquote) + (-> (unquote (translate-1 e l obj))) + (-> (unquote-splicing (translate-1 e l obj))))) + (else + (list (car x) (trans-quasiquote e l obj (1- level)))))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + ((eq? (car x) 'quasiquote) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (trans-quasiquote e l (car x) level) + (trans-quasiquote e l (cdr x) level))))) + +(define (trans-body e l body) + (define (define->binding df) + (pmatch (cdr df) + ((,name ,val) (guard (symbol? name)) (list name val)) + (((,name . ,formals) . ,body) (guard (symbol? name)) + (list name `(lambda ,formals ,@body))) + (else (syntax-error (location df) "bad define" df)))) + ;; main + (let loop ((ls body) (ds '())) + (pmatch ls + (() (syntax-error l "bad body" body)) + (((define . _) . _) + (loop (cdr ls) (cons (car ls) ds))) + (else + (if (null? ds) + (translate-1 e l `(begin ,@ls)) + (translate-1 e l `(letrec ,(map define->binding ds) ,@ls))))))) + +(define (parse-formals formals) + (cond + ;; (lambda x ...) + ((symbol? formals) (values (list formals) #t)) + ;; (lambda (x y z) ...) + ((list? formals) (values formals #f)) + ;; (lambda (x y . z) ...) + ((pair? formals) + (let loop ((l formals) (v '())) + (if (pair? l) + (loop (cdr l) (cons (car l) v)) + (values (reverse! (cons l v)) #t)))) + (else (syntax-error (location formals) "bad formals" formals)))) + +(define (parse-lambda-meta body) + (cond ((or (null? body) (null? (cdr body))) (values '() body)) + ((string? (car body)) + (values `((documentation . ,(car body))) (cdr body))) + (else (values '() body)))) + +(define (maybe-name-value! val name) + (cond + ((ghil-lambda? val) + (if (not (assq-ref (ghil-lambda-meta val) 'name)) + (set! (ghil-lambda-meta val) + (acons 'name name (ghil-lambda-meta val)))))) + val) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm new file mode 100644 index 000000000..4ac33d77e --- /dev/null +++ b/module/language/scheme/compile-tree-il.scm @@ -0,0 +1,63 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language scheme compile-tree-il) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-lexicals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cadr env)) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +(define (compile-tree-il x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) + (values x cenv cenv))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm new file mode 100644 index 000000000..9243f4e6a --- /dev/null +++ b/module/language/scheme/decompile-tree-il.scm @@ -0,0 +1,26 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001,2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language scheme decompile-tree-il) + #:use-module (language tree-il) + #:export (decompile-tree-il)) + +(define (decompile-tree-il x env opts) + (values (tree-il->scheme x) env)) diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm new file mode 100644 index 000000000..b178b2adc --- /dev/null +++ b/module/language/scheme/inline.scm @@ -0,0 +1,205 @@ +;;; GHIL macros + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language scheme inline) + #:use-module (system base syntax) + #:use-module (language ghil) + #:use-module (srfi srfi-16) + #:export (*inline-table* define-inline try-inline try-inline-with-env)) + +(define *inline-table* '()) + +(define-macro (define-inline sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in))) + (error "what" ',(car in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp)))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-ghil-quote #f #f ,exp)) + (else (error "bad consequent yall" exp)))) + `(set! (@ (language scheme inline) *inline-table*) + (assq-set! (@ (language scheme inline) *inline-table*) + ,sym + (let ((make-ghil-inline (@ (language ghil) make-ghil-inline)) + (make-ghil-quote (@ (language ghil) make-ghil-quote)) + (try-inline (@ (language scheme inline) try-inline))) + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `(,(car in) + ,(consequent (cadr in))) out))))))))) + +(define (try-inline head-value args) + (and=> (assq-ref *inline-table* head-value) + (lambda (proc) (apply proc args)))) + + +(define (try-inline-with-env env loc exp) + (let ((sym (car exp))) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((mod (current-module))) + (and (not (assoc-ref table (cons (module-name mod) sym))) + (module-bound? mod sym) + (try-inline (module-ref mod sym) (cdr exp))))) + ((<ghil-env> parent table variables) + (and (not (assq-ref table sym)) + (loop parent))))))) + +(define-inline eq? (x y) + (eq? x y)) + +(define-inline eqv? (x y) + (eqv? x y)) + +(define-inline equal? (x y) + (equal? x y)) + +(define-inline = (x y) + (ee? x y)) + +(define-inline < (x y) + (lt? x y)) + +(define-inline > (x y) + (gt? x y)) + +(define-inline <= (x y) + (le? x y)) + +(define-inline >= (x y) + (ge? x y)) + +(define-inline zero? (x) + (ee? x 0)) + +(define-inline + + () 0 + (x) x + (x y) (add x y) + (x y . rest) (add x (+ y . rest))) + +(define-inline * + () 1 + (x) x + (x y) (mul x y) + (x y . rest) (mul x (* y . rest))) + +(define-inline - + (x) (sub 0 x) + (x y) (sub x y) + (x y . rest) (sub x (+ y . rest))) + +(define-inline 1- + (x) (sub x 1)) + +(define-inline / + (x) (div 1 x) + (x y) (div x y) + (x y . rest) (div x (* y . rest))) + +(define-inline quotient (x y) + (quo x y)) + +(define-inline remainder (x y) + (rem x y)) + +(define-inline modulo (x y) + (mod x y)) + +(define-inline not (x) + (not x)) + +(define-inline pair? (x) + (pair? x)) + +(define-inline cons (x y) + (cons x y)) + +(define-inline car (x) (car x)) +(define-inline cdr (x) (cdr x)) + +(define-inline set-car! (x y) (set-car! x y)) +(define-inline set-cdr! (x y) (set-cdr! x y)) + +(define-inline caar (x) (car (car x))) +(define-inline cadr (x) (car (cdr x))) +(define-inline cdar (x) (cdr (car x))) +(define-inline cddr (x) (cdr (cdr x))) +(define-inline caaar (x) (car (car (car x)))) +(define-inline caadr (x) (car (car (cdr x)))) +(define-inline cadar (x) (car (cdr (car x)))) +(define-inline caddr (x) (car (cdr (cdr x)))) +(define-inline cdaar (x) (cdr (car (car x)))) +(define-inline cdadr (x) (cdr (car (cdr x)))) +(define-inline cddar (x) (cdr (cdr (car x)))) +(define-inline cdddr (x) (cdr (cdr (cdr x)))) +(define-inline caaaar (x) (car (car (car (car x))))) +(define-inline caaadr (x) (car (car (car (cdr x))))) +(define-inline caadar (x) (car (car (cdr (car x))))) +(define-inline caaddr (x) (car (car (cdr (cdr x))))) +(define-inline cadaar (x) (car (cdr (car (car x))))) +(define-inline cadadr (x) (car (cdr (car (cdr x))))) +(define-inline caddar (x) (car (cdr (cdr (car x))))) +(define-inline cadddr (x) (car (cdr (cdr (cdr x))))) +(define-inline cdaaar (x) (cdr (car (car (car x))))) +(define-inline cdaadr (x) (cdr (car (car (cdr x))))) +(define-inline cdadar (x) (cdr (car (cdr (car x))))) +(define-inline cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-inline cddaar (x) (cdr (cdr (car (car x))))) +(define-inline cddadr (x) (cdr (cdr (car (cdr x))))) +(define-inline cdddar (x) (cdr (cdr (cdr (car x))))) +(define-inline cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-inline null? (x) + (null? x)) + +(define-inline list? (x) + (list? x)) + +(define-inline cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-inline acons + (x y z) (cons (cons x y) z)) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm new file mode 100644 index 000000000..df618581f --- /dev/null +++ b/module/language/scheme/spec.scm @@ -0,0 +1,45 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language scheme spec) + #:use-module (system base language) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) + #:export (scheme)) + +;;; +;;; Reader +;;; + +(read-enable 'positions) + +;;; +;;; Language definition +;;; + +(define-language scheme + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write + ) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm new file mode 100644 index 000000000..ad8b73176 --- /dev/null +++ b/module/language/tree-il.scm @@ -0,0 +1,474 @@ +;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (language tree-il) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (system base pmatch) + #:use-module (system base syntax) + #:export (tree-il-src + + <void> void? make-void void-src + <const> const? make-const const-src const-exp + <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name + <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name + <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + <application> application? make-application application-src application-proc application-args + <sequence> sequence? make-sequence sequence-src sequence-exps + <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body + <let> let? make-let let-src let-names let-vars let-vals let-body + <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body + <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body + <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body + + parse-tree-il + unparse-tree-il + tree-il->scheme + + tree-il-fold + make-tree-il-folder + post-order! + pre-order!)) + +(define-type (<tree-il> #:common-slots (src)) + (<void>) + (<const> exp) + (<primitive-ref> name) + (<lexical-ref> name gensym) + (<lexical-set> name gensym exp) + (<module-ref> mod name public?) + (<module-set> mod name public? exp) + (<toplevel-ref> name) + (<toplevel-set> name exp) + (<toplevel-define> name exp) + (<conditional> test then else) + (<application> proc args) + (<sequence> exps) + (<lambda> names vars meta body) + (<let> names vars vals body) + (<letrec> names vars vals body) + (<fix> names vars vals body) + (<let-values> names vars exp body)) + + + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (pair? props) props)))) + +(define (parse-tree-il exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-tree-il x)))) + (pmatch exp + ((void) + (make-void loc)) + + ((apply ,proc . ,args) + (make-application loc (retrans proc) (map retrans args))) + + ((if ,test ,then ,else) + (make-conditional loc (retrans test) (retrans then) (retrans else))) + + ((primitive ,name) (guard (symbol? name)) + (make-primitive-ref loc name)) + + ((lexical ,name) (guard (symbol? name)) + (make-lexical-ref loc name name)) + + ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) + (make-lexical-ref loc name sym)) + + ((set! (lexical ,name) ,exp) (guard (symbol? name)) + (make-lexical-set loc name name (retrans exp))) + + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) + (make-lexical-set loc name sym (retrans exp))) + + ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #t)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #t (retrans exp))) + + ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #f)) + + ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #f (retrans exp))) + + ((toplevel ,name) (guard (symbol? name)) + (make-toplevel-ref loc name)) + + ((set! (toplevel ,name) ,exp) (guard (symbol? name)) + (make-toplevel-set loc name (retrans exp))) + + ((define ,name ,exp) (guard (symbol? name)) + (make-toplevel-define loc name (retrans exp))) + + ((lambda ,names ,vars ,exp) + (make-lambda loc names vars '() (retrans exp))) + + ((lambda ,names ,vars ,meta ,exp) + (make-lambda loc names vars meta (retrans exp))) + + ((const ,exp) + (make-const loc exp)) + + ((begin . ,exps) + (make-sequence loc (map retrans exps))) + + ((let ,names ,vars ,vals ,body) + (make-let loc names vars (map retrans vals) (retrans body))) + + ((letrec ,names ,vars ,vals ,body) + (make-letrec loc names vars (map retrans vals) (retrans body))) + + ((fix ,names ,vars ,vals ,body) + (make-fix loc names vars (map retrans vals) (retrans body))) + + ((let-values ,names ,vars ,exp ,body) + (make-let-values loc names vars (retrans exp) (retrans body))) + + (else + (error "unrecognized tree-il" exp))))) + +(define (unparse-tree-il tree-il) + (record-case tree-il + ((<void>) + '(void)) + + ((<application> proc args) + `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) + + ((<conditional> test then else) + `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) + + ((<primitive-ref> name) + `(primitive ,name)) + + ((<lexical-ref> name gensym) + `(lexical ,name ,gensym)) + + ((<lexical-set> name gensym exp) + `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + + ((<module-ref> mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + ((<module-set> mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + + ((<toplevel-ref> name) + `(toplevel ,name)) + + ((<toplevel-set> name exp) + `(set! (toplevel ,name) ,(unparse-tree-il exp))) + + ((<toplevel-define> name exp) + `(define ,name ,(unparse-tree-il exp))) + + ((<lambda> names vars meta body) + `(lambda ,names ,vars ,meta ,(unparse-tree-il body))) + + ((<const> exp) + `(const ,exp)) + + ((<sequence> exps) + `(begin ,@(map unparse-tree-il exps))) + + ((<let> names vars vals body) + `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + + ((<letrec> names vars vals body) + `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + + ((<fix> names vars vals body) + `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + + ((<let-values> names vars exp body) + `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) + +(define (tree-il->scheme e) + (record-case e + ((<void>) + '(if #f #f)) + + ((<application> proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + + ((<conditional> test then else) + (if (void? else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) + + ((<primitive-ref> name) + name) + + ((<lexical-ref> name gensym) + gensym) + + ((<lexical-set> name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + ((<module-ref> mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + ((<module-set> mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + ((<toplevel-ref> name) + name) + + ((<toplevel-set> name exp) + `(set! ,name ,(tree-il->scheme exp))) + + ((<toplevel-define> name exp) + `(define ,name ,(tree-il->scheme exp))) + + ((<lambda> vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + ((<const> exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + ((<sequence> exps) + `(begin ,@(map tree-il->scheme exps))) + + ((<let> vars vals body) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + + ((<letrec> vars vals body) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + + ((<fix> vars vals body) + ;; not a typo, we really do translate back to letrec + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + + ((<let-values> vars exp body) + `(call-with-values (lambda () ,(tree-il->scheme exp)) + (lambda ,vars ,(tree-il->scheme body)))))) + + +(define (tree-il-fold leaf down up seed tree) + "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent +into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is +invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered +and SEED is the current result, intially seeded with SEED. + +This is an implementation of `foldts' as described by Andy Wingo in +``Applications of fold to XML transformation''." + (let loop ((tree tree) + (result seed)) + (if (or (null? tree) (pair? tree)) + (fold loop result tree) + (record-case tree + ((<lexical-set> exp) + (up tree (loop exp (down tree result)))) + ((<module-set> exp) + (up tree (loop exp (down tree result)))) + ((<toplevel-set> exp) + (up tree (loop exp (down tree result)))) + ((<toplevel-define> exp) + (up tree (loop exp (down tree result)))) + ((<conditional> test then else) + (up tree (loop else + (loop then + (loop test (down tree result)))))) + ((<application> proc args) + (up tree (loop (cons proc args) (down tree result)))) + ((<sequence> exps) + (up tree (loop exps (down tree result)))) + ((<lambda> body) + (up tree (loop body (down tree result)))) + ((<let> vals body) + (up tree (loop body + (loop vals + (down tree result))))) + ((<letrec> vals body) + (up tree (loop body + (loop vals + (down tree result))))) + ((<fix> vals body) + (up tree (loop body + (loop vals + (down tree result))))) + ((<let-values> exp body) + (up tree (loop body (loop exp (down tree result))))) + (else + (leaf tree result)))))) + + +(define-syntax make-tree-il-folder + (syntax-rules () + ((_ seed ...) + (lambda (tree down up seed ...) + (define (fold-values proc exps seed ...) + (if (null? exps) + (values seed ...) + (let-values (((seed ...) (proc (car exps) seed ...))) + (fold-values proc (cdr exps) seed ...)))) + (let foldts ((tree tree) (seed seed) ...) + (let*-values + (((seed ...) (down tree seed ...)) + ((seed ...) + (record-case tree + ((<lexical-set> exp) + (foldts exp seed ...)) + ((<module-set> exp) + (foldts exp seed ...)) + ((<toplevel-set> exp) + (foldts exp seed ...)) + ((<toplevel-define> exp) + (foldts exp seed ...)) + ((<conditional> test then else) + (let*-values (((seed ...) (foldts test seed ...)) + ((seed ...) (foldts then seed ...))) + (foldts else seed ...))) + ((<application> proc args) + (let-values (((seed ...) (foldts proc seed ...))) + (fold-values foldts args seed ...))) + ((<sequence> exps) + (fold-values foldts exps seed ...)) + ((<lambda> body) + (foldts body seed ...)) + ((<let> vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + ((<letrec> vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + ((<fix> vals body) + (let*-values (((seed ...) (fold-values foldts vals seed ...))) + (foldts body seed ...))) + ((<let-values> exp body) + (let*-values (((seed ...) (foldts exp seed ...))) + (foldts body seed ...))) + (else + (values seed ...))))) + (up tree seed ...))))))) + +(define (post-order! f x) + (let lp ((x x)) + (record-case x + ((<application> proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args))) + + ((<conditional> test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else))) + + ((<lexical-set> name gensym exp) + (set! (lexical-set-exp x) (lp exp))) + + ((<module-set> mod name public? exp) + (set! (module-set-exp x) (lp exp))) + + ((<toplevel-set> name exp) + (set! (toplevel-set-exp x) (lp exp))) + + ((<toplevel-define> name exp) + (set! (toplevel-define-exp x) (lp exp))) + + ((<lambda> vars meta body) + (set! (lambda-body x) (lp body))) + + ((<sequence> exps) + (set! (sequence-exps x) (map lp exps))) + + ((<let> vars vals body) + (set! (let-vals x) (map lp vals)) + (set! (let-body x) (lp body))) + + ((<letrec> vars vals body) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-body x) (lp body))) + + ((<fix> vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + + ((<let-values> vars exp body) + (set! (let-values-exp x) (lp exp)) + (set! (let-values-body x) (lp body))) + + (else #f)) + + (or (f x) x))) + +(define (pre-order! f x) + (let lp ((x x)) + (let ((x (or (f x) x))) + (record-case x + ((<application> proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args))) + + ((<conditional> test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else))) + + ((<lexical-set> name gensym exp) + (set! (lexical-set-exp x) (lp exp))) + + ((<module-set> mod name public? exp) + (set! (module-set-exp x) (lp exp))) + + ((<toplevel-set> name exp) + (set! (toplevel-set-exp x) (lp exp))) + + ((<toplevel-define> name exp) + (set! (toplevel-define-exp x) (lp exp))) + + ((<lambda> vars meta body) + (set! (lambda-body x) (lp body))) + + ((<sequence> exps) + (set! (sequence-exps x) (map lp exps))) + + ((<let> vars vals body) + (set! (let-vals x) (map lp vals)) + (set! (let-body x) (lp body))) + + ((<letrec> vars vals body) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-body x) (lp body))) + + ((<fix> vars vals body) + (set! (fix-vals x) (map lp vals)) + (set! (fix-body x) (lp body))) + + ((<let-values> vars exp body) + (set! (let-values-exp x) (lp exp)) + (set! (let-values-body x) (lp body))) + + (else #f)) + x))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..b93a0bd7e --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,617 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language tree-il analyze) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (language tree-il) + #:export (analyze-lexicals + report-unused-variables)) + +;; Allocation is the process of assigning storage locations for lexical +;; variables. A lexical variable has a distinct "address", or storage +;; location, for each procedure in which it is referenced. +;; +;; A variable is "local", i.e., allocated on the stack, if it is +;; referenced from within the procedure that defined it. Otherwise it is +;; a "closure" variable. For example: +;; +;; (lambda (a) a) ; a will be local +;; `a' is local to the procedure. +;; +;; (lambda (a) (lambda () a)) +;; `a' is local to the outer procedure, but a closure variable with +;; respect to the inner procedure. +;; +;; If a variable is ever assigned, it needs to be heap-allocated +;; ("boxed"). This is so that closures and continuations capture the +;; variable's identity, not just one of the values it may have over the +;; course of program execution. If the variable is never assigned, there +;; is no distinction between value and identity, so closing over its +;; identity (whether through closures or continuations) can make a copy +;; of its value instead. +;; +;; Local variables are stored on the stack within a procedure's call +;; frame. Their index into the stack is determined from their linear +;; postion within a procedure's binding path: +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. +;; +;; This algorithm has the problem that variables are only allocated +;; indices at the end of the binding path. If variables bound early in +;; the path are not used in later portions of the path, their indices +;; will not be recycled. This problem is particularly egregious in the +;; expansion of `or': +;; +;; (or x y z) +;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) +;; +;; As you can see, the `a' binding is only used in the ephemeral `then' +;; clause of the first `if', but its index would be reserved for the +;; whole of the `or' expansion. So we have a hack for this specific +;; case. A proper solution would be some sort of liveness analysis, and +;; not our linear allocation algorithm. +;; +;; Closure variables are captured when a closure is created, and stored +;; in a vector. Each closure variable has a unique index into that +;; vector. +;; +;; There is one more complication. Procedures bound by <fix> may, in +;; some cases, be rendered inline to their parent procedure. That is to +;; say, +;; +;; (letrec ((lp (lambda () (lp)))) (lp)) +;; => (fix ((lp (lambda () (lp)))) (lp)) +;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP; +;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop +;; +;; The upshot is that we don't have to allocate any space for the `lp' +;; closure at all, as it can be rendered inline as a loop. So there is +;; another kind of allocation, "label allocation", in which the +;; procedure is simply a label, placed at the start of the lambda body. +;; The label is the gensym under which the lambda expression is bound. +;; +;; The analyzer checks to see that the label is called with the correct +;; number of arguments. Calls to labels compile to rename + goto. +;; Lambda, the ultimate goto! +;; +;; +;; The return value of `analyze-lexicals' is a hash table, the +;; "allocation". +;; +;; The allocation maps gensyms -- recall that each lexically bound +;; variable has a unique gensym -- to storage locations ("addresses"). +;; Since one gensym may have many storage locations, if it is referenced +;; in many procedures, it is a two-level map. +;; +;; The allocation also stored information on how many local variables +;; need to be allocated for each procedure, lexicals that have been +;; translated into labels, and information on what free variables to +;; capture from its lexical parent procedure. +;; +;; That is: +;; +;; sym -> {lambda -> address} +;; lambda -> (nlocs labels . free-locs) +;; +;; address ::= (local? boxed? . index) +;; labels ::= ((sym . lambda-vars) ...) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define (make-hashq k v) + (let ((res (make-hash-table))) + (hashq-set! res k v) + res)) + +(define (analyze-lexicals x) + ;; bound-vars: lambda -> (sym ...) + ;; all identifiers bound within a lambda + (define bound-vars (make-hash-table)) + ;; free-vars: lambda -> (sym ...) + ;; all identifiers referenced in a lambda, but not bound + ;; NB, this includes identifiers referenced by contained lambdas + (define free-vars (make-hash-table)) + ;; assigned: sym -> #t + ;; variables that are assigned + (define assigned (make-hash-table)) + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion in O(1) time + (define refcounts (make-hash-table)) + ;; labels: sym -> lambda-vars + ;; for determining if fixed-point procedures can be rendered as + ;; labels. lambda-vars may be an improper list. + (define labels (make-hash-table)) + + ;; returns variables referenced in expr + (define (analyze! x proc labels-in-proc tail? tail-call-args) + (define (step y) (analyze! y proc labels-in-proc #f #f)) + (define (step-tail y) (analyze! y proc labels-in-proc tail? #f)) + (define (step-tail-call y args) (analyze! y proc labels-in-proc #f + (and tail? args))) + (define (recur/labels x new-proc labels) + (analyze! x new-proc (append labels labels-in-proc) #t #f)) + (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) + (record-case x + ((<application> proc args) + (apply lset-union eq? (step-tail-call proc args) + (map step args))) + + ((<conditional> test then else) + (lset-union eq? (step test) (step-tail then) (step-tail else))) + + ((<lexical-ref> name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (not (and tail-call-args + (memq gensym labels-in-proc) + (let ((args (hashq-ref labels gensym))) + (and (list? args) + (= (length args) (length tail-call-args)))))) + (hashq-set! labels gensym #f)) + (list gensym)) + + ((<lexical-set> name gensym exp) + (hashq-set! assigned gensym #t) + (hashq-set! labels gensym #f) + (lset-adjoin eq? (step exp) gensym)) + + ((<module-set> mod name public? exp) + (step exp)) + + ((<toplevel-set> name exp) + (step exp)) + + ((<toplevel-define> name exp) + (step exp)) + + ((<sequence> exps) + (let lp ((exps exps) (ret '())) + (cond ((null? exps) '()) + ((null? (cdr exps)) + (lset-union eq? ret (step-tail (car exps)))) + (else + (lp (cdr exps) (lset-union eq? ret (step (car exps)))))))) + + ((<lambda> vars meta body) + (let ((locally-bound (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out)))))) + (hashq-set! bound-vars x locally-bound) + (let* ((referenced (recur body x)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))) + + ((<let> vars vals body) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step-tail body) (map step vals)) + vars)) + + ((<letrec> vars vals body) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) + (lset-difference eq? + (apply lset-union eq? (step-tail body) (map step vals)) + vars)) + + ((<fix> vars vals body) + ;; Try to allocate these procedures as labels. + (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val))) + vars vals) + (hashq-set! bound-vars proc + (append (reverse vars) (hashq-ref bound-vars proc))) + ;; Step into subexpressions. + (let* ((var-refs + (map + ;; Since we're trying to label-allocate the lambda, + ;; pretend it's not a closure, and just recurse into its + ;; body directly. (Otherwise, recursing on a closure + ;; that references one of the fix's bound vars would + ;; prevent label allocation.) + (lambda (x) + (record-case x + ((<lambda> (lvars vars) body) + (let ((locally-bound + (let rev* ((lvars lvars) (out '())) + (cond ((null? lvars) out) + ((pair? lvars) (rev* (cdr lvars) + (cons (car lvars) out))) + (else (cons lvars out)))))) + (hashq-set! bound-vars x locally-bound) + ;; recur/labels, the difference from the closure case + (let* ((referenced (recur/labels body x vars)) + (free (lset-difference eq? referenced locally-bound)) + (all-bound (reverse! (hashq-ref bound-vars x)))) + (hashq-set! bound-vars x all-bound) + (hashq-set! free-vars x free) + free))))) + vals)) + (vars-with-refs (map cons vars var-refs)) + (body-refs (recur/labels body proc vars))) + (define (delabel-dependents! sym) + (let ((refs (assq-ref vars-with-refs sym))) + (if refs + (for-each (lambda (sym) + (if (hashq-ref labels sym) + (begin + (hashq-set! labels sym #f) + (delabel-dependents! sym)))) + refs)))) + ;; Stepping into the lambdas and the body might have made some + ;; procedures not label-allocatable -- which might have + ;; knock-on effects. For example: + ;; (fix ((a (lambda () (b))) + ;; (b (lambda () a))) + ;; (a)) + ;; As far as `a' is concerned, both `a' and `b' are + ;; label-allocatable. But `b' references `a' not in a proc-tail + ;; position, which makes `a' not label-allocatable. The + ;; knock-on effect is that, when back-propagating this + ;; information to `a', `b' will also become not + ;; label-allocatable, as it is referenced within `a', which is + ;; allocated as a closure. This is a transitive relationship. + (for-each (lambda (sym) + (if (not (hashq-ref labels sym)) + (delabel-dependents! sym))) + vars) + ;; Now lift bound variables with label-allocated lambdas to the + ;; parent procedure. + (for-each + (lambda (sym val) + (if (hashq-ref labels sym) + ;; Remove traces of the label-bound lambda. The free + ;; vars will propagate up via the return val. + (begin + (hashq-set! bound-vars proc + (append (hashq-ref bound-vars val) + (hashq-ref bound-vars proc))) + (hashq-remove! bound-vars val) + (hashq-remove! free-vars val)))) + vars vals) + (lset-difference eq? + (apply lset-union eq? body-refs var-refs) + vars))) + + ((<let-values> vars exp body) + (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) + (if (pair? in) + (lp (cons (car in) out) (cdr in)) + (if (null? in) out (cons in out)))))) + (hashq-set! bound-vars proc bound) + (lset-difference eq? + (lset-union eq? (step exp) (step-tail body)) + bound))) + + (else '()))) + + ;; allocation: sym -> {lambda -> address} + ;; lambda -> (nlocs labels . free-locs) + (define allocation (make-hash-table)) + + (define (allocate! x proc n) + (define (recur y) (allocate! y proc n)) + (record-case x + ((<application> proc args) + (apply max (recur proc) (map recur args))) + + ((<conditional> test then else) + (max (recur test) (recur then) (recur else))) + + ((<lexical-set> name gensym exp) + (recur exp)) + + ((<module-set> mod name public? exp) + (recur exp)) + + ((<toplevel-set> name exp) + (recur exp)) + + ((<toplevel-define> name exp) + (recur exp)) + + ((<sequence> exps) + (apply max (map recur exps))) + + ((<lambda> vars meta body) + ;; allocate closure vars in order + (let lp ((c (hashq-ref free-vars x)) (n 0)) + (if (pair? c) + (begin + (hashq-set! (hashq-ref allocation (car c)) + x + `(#f ,(hashq-ref assigned (car c)) . ,n)) + (lp (cdr c) (1+ n))))) + + (let ((nlocs + (let lp ((vars vars) (n 0)) + (if (not (null? vars)) + ;; allocate args + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! allocation v + (make-hashq + x `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body, return number of additional locals + (- (allocate! body x n) n)))) + (free-addresses + (map (lambda (v) + (hashq-ref (hashq-ref allocation v) proc)) + (hashq-ref free-vars x))) + (labels (filter cdr + (map (lambda (sym) + (cons sym (hashq-ref labels sym))) + (hashq-ref bound-vars x))))) + ;; set procedure allocations + (hashq-set! allocation x (cons* nlocs labels free-addresses))) + n) + + ((<let> vars vals body) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? body) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref assigned v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test body)) + (eq? (lexical-ref-gensym (conditional-test body)) v) + (lexical-ref? (conditional-then body)) + (eq? (lexical-ref-gensym (conditional-then body)) v)))) + (hashq-set! allocation (car vars) + (make-hashq proc `(#t #f . ,n))) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else body) proc n))) + (else + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! body proc n)) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n))))))))) + + ((<letrec> vars vals body) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))) + + ((<fix> vars vals body) + (let lp ((in vars) (n n)) + (if (null? in) + (let lp ((vars vars) (vals vals) (nmax n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((hashq-ref labels (car vars)) + ;; allocate label bindings & body inline to proc + (lp (cdr vars) + (cdr vals) + (record-case (car vals) + ((<lambda> vars body) + (let lp ((vars vars) (n n)) + (if (not (null? vars)) + ;; allocate bindings + (let ((v (if (pair? vars) (car vars) vars))) + (hashq-set! + allocation v + (make-hashq + proc `(#t ,(hashq-ref assigned v) . ,n))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))) + ;; allocate body + (max nmax (allocate! body proc n)))))))) + (else + ;; allocate closure + (lp (cdr vars) + (cdr vals) + (max nmax (allocate! (car vals) proc n)))))) + + (let ((v (car in))) + (cond + ((hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + ((hashq-ref labels v) + ;; no binding, it's a label + (lp (cdr in) n)) + (else + ;; allocate closure binding + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr in) (1+ n)))))))) + + ((<let-values> vars exp body) + (let ((nmax (recur exp))) + (let lp ((vars vars) (n n)) + (cond + ((null? vars) + (max nmax (allocate! body proc n))) + ((not (pair? vars)) + (hashq-set! allocation vars + (make-hashq proc + `(#t ,(hashq-ref assigned vars) . ,n))) + ;; the 1+ for this var + (max nmax (allocate! body proc (1+ n)))) + (else + (let ((v (car vars))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr vars) (1+ n)))))))) + + (else n))) + + (analyze! x #f '() #t #f) + (allocate! x #f 0) + + allocation) + + +;;; +;;; Unused variable analysis. +;;; + +;; <binding-info> records are used during tree traversals in +;; `report-unused-variables'. They contain a list of the local vars +;; currently in scope, a list of locals vars that have been referenced, and a +;; "location stack" (the stack of `tree-il-src' values for each parent tree). +(define-record-type <binding-info> + (make-binding-info vars refs locs) + binding-info? + (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...) + (refs binding-info-refs) ;; (GENSYM ...) + (locs binding-info-locs)) ;; (LOCATION ...) + +(define (report-unused-variables tree) + "Report about unused variables in TREE. Return TREE." + + (define (dotless-list lst) + ;; If LST is a dotted list, return a proper list equal to LST except that + ;; the very last element is a pair; otherwise return LST. + (let loop ((lst lst) + (result '())) + (cond ((null? lst) + (reverse result)) + ((pair? lst) + (loop (cdr lst) (cons (car lst) result))) + (else + (loop '() (cons lst result)))))) + + (tree-il-fold (lambda (x info) + ;; X is a leaf: extend INFO's refs accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (record-case x + ((<lexical-ref> gensym) + (make-binding-info vars (cons gensym refs) locs)) + (else info)))) + + (lambda (x info) + ;; Going down into X: extend INFO's variable list + ;; accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info)) + (src (tree-il-src x))) + (define (extend inner-vars inner-names) + (append (map (lambda (var name) + (list var name src)) + inner-vars + inner-names) + vars)) + (record-case x + ((<lexical-set> gensym) + (make-binding-info vars (cons gensym refs) + (cons src locs))) + ((<lambda> vars names) + (let ((vars (dotless-list vars)) + (names (dotless-list names))) + (make-binding-info (extend vars names) refs + (cons src locs)))) + ((<let> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<letrec> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<fix> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + ((<let-values> vars names) + (make-binding-info (extend vars names) refs + (cons src locs))) + (else info)))) + + (lambda (x info) + ;; Leaving X's scope: shrink INFO's variable list + ;; accordingly and reported unused nested variables. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (locs (binding-info-locs info))) + (define (shrink inner-vars refs) + (for-each (lambda (var) + (let ((gensym (car var))) + ;; Don't report lambda parameters as + ;; unused. + (if (and (not (memq gensym refs)) + (not (and (lambda? x) + (memq gensym + inner-vars)))) + (let ((name (cadr var)) + ;; We can get approximate + ;; source location by going up + ;; the LOCS location stack. + (loc (or (caddr var) + (find pair? locs)))) + (warning 'unused-variable loc name))))) + (filter (lambda (var) + (memq (car var) inner-vars)) + vars)) + (fold alist-delete vars inner-vars)) + + ;; For simplicity, we leave REFS untouched, i.e., with + ;; names of variables that are now going out of scope. + ;; It doesn't hurt as these are unique names, it just + ;; makes REFS unnecessarily fat. + (record-case x + ((<lambda> vars) + (let ((vars (dotless-list vars))) + (make-binding-info (shrink vars refs) refs + (cdr locs)))) + ((<let> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<letrec> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<fix> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + ((<let-values> vars) + (make-binding-info (shrink vars refs) refs + (cdr locs))) + (else info)))) + (make-binding-info '() '() '()) + tree) + tree) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..86b610f94 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,729 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language tree-il compile-glil) + #:use-module (system base syntax) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (ice-9 receive) + #:use-module (language glil) + #:use-module (system vm instruction) + #:use-module (language tree-il) + #:use-module (language tree-il optimize) + #:use-module (language tree-il analyze) + #:export (compile-glil)) + +;;; TODO: +;; +;; call-with-values -> mv-bind +;; basic degenerate-case reduction + +;; allocation: +;; sym -> {lambda -> address} +;; lambda -> (nlocs labels . free-locs) +;; +;; address := (local? boxed? . index) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define *comp-module* (make-fluid)) + +(define %warning-passes + `((unused-variable . ,report-unused-variables))) + +(define (compile-glil x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + + ;; Go throught the warning passes. + (for-each (lambda (kind) + (let ((warn (assoc-ref %warning-passes kind))) + (and (procedure? warn) + (warn x)))) + warnings) + + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x #f allocation) + (and e (cons (car e) (cddr e))) + e))))) + + + +(define *primcall-ops* (make-hash-table)) +(for-each + (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) + '(((eq? . 2) . eq?) + ((eqv? . 2) . eqv?) + ((equal? . 2) . equal?) + ((= . 2) . ee?) + ((< . 2) . lt?) + ((> . 2) . gt?) + ((<= . 2) . le?) + ((>= . 2) . ge?) + ((+ . 2) . add) + ((- . 2) . sub) + ((1+ . 1) . add1) + ((1- . 1) . sub1) + ((* . 2) . mul) + ((/ . 2) . div) + ((quotient . 2) . quo) + ((remainder . 2) . rem) + ((modulo . 2) . mod) + ((not . 1) . not) + ((pair? . 1) . pair?) + ((cons . 2) . cons) + ((car . 1) . car) + ((cdr . 1) . cdr) + ((set-car! . 2) . set-car!) + ((set-cdr! . 2) . set-cdr!) + ((null? . 1) . null?) + ((list? . 1) . list?) + (list . list) + (vector . vector) + ((@slot-ref . 2) . slot-ref) + ((@slot-set! . 3) . slot-set) + ((vector-ref . 2) . vector-ref) + ((vector-set! . 3) . vector-set) + + ((bytevector-u8-ref . 2) . bv-u8-ref) + ((bytevector-u8-set! . 3) . bv-u8-set) + ((bytevector-s8-ref . 2) . bv-s8-ref) + ((bytevector-s8-set! . 3) . bv-s8-set) + + ((bytevector-u16-ref . 3) . bv-u16-ref) + ((bytevector-u16-set! . 4) . bv-u16-set) + ((bytevector-u16-native-ref . 2) . bv-u16-native-ref) + ((bytevector-u16-native-set! . 3) . bv-u16-native-set) + ((bytevector-s16-ref . 3) . bv-s16-ref) + ((bytevector-s16-set! . 4) . bv-s16-set) + ((bytevector-s16-native-ref . 2) . bv-s16-native-ref) + ((bytevector-s16-native-set! . 3) . bv-s16-native-set) + + ((bytevector-u32-ref . 3) . bv-u32-ref) + ((bytevector-u32-set! . 4) . bv-u32-set) + ((bytevector-u32-native-ref . 2) . bv-u32-native-ref) + ((bytevector-u32-native-set! . 3) . bv-u32-native-set) + ((bytevector-s32-ref . 3) . bv-s32-ref) + ((bytevector-s32-set! . 4) . bv-s32-set) + ((bytevector-s32-native-ref . 2) . bv-s32-native-ref) + ((bytevector-s32-native-set! . 3) . bv-s32-native-set) + + ((bytevector-u64-ref . 3) . bv-u64-ref) + ((bytevector-u64-set! . 4) . bv-u64-set) + ((bytevector-u64-native-ref . 2) . bv-u64-native-ref) + ((bytevector-u64-native-set! . 3) . bv-u64-native-set) + ((bytevector-s64-ref . 3) . bv-s64-ref) + ((bytevector-s64-set! . 4) . bv-s64-set) + ((bytevector-s64-native-ref . 2) . bv-s64-native-ref) + ((bytevector-s64-native-set! . 3) . bv-s64-native-set) + + ((bytevector-ieee-single-ref . 3) . bv-f32-ref) + ((bytevector-ieee-single-set! . 4) . bv-f32-set) + ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref) + ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set) + ((bytevector-ieee-double-ref . 3) . bv-f64-ref) + ((bytevector-ieee-double-set! . 4) . bv-f64-set) + ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref) + ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set))) + + + + +(define (make-label) (gensym ":L")) + +(define (vars->bind-list ids vars allocation proc) + (map (lambda (id v) + (pmatch (hashq-ref (hashq-ref allocation v) proc) + ((#t ,boxed? . ,n) + (list id boxed? n)) + (,x (error "badness" x)))) + ids + vars)) + +;; FIXME: always emit? otherwise it's hard to pair bind with unbind +(define (emit-bindings src ids vars allocation proc emit-code) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation proc)))) + +(define (with-output-to-code proc) + (let ((out '())) + (define (emit-code src x) + (set! out (cons x out)) + (if src + (set! out (cons (make-glil-source src) out)))) + (proc emit-code) + (reverse out))) + +(define (flatten-lambda x self-label allocation) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) + (let ((nlocs (car (hashq-ref allocation x))) + (labels (cadr (hashq-ref allocation x)))) + (make-glil-program + nargs nrest nlocs (lambda-meta x) + (with-output-to-code + (lambda (emit-code) + ;; emit label for self tail calls + (if self-label + (emit-code #f (make-glil-label self-label))) + ;; write bindings and source debugging info + (if (not (null? ids)) + (emit-bindings #f ids vars allocation x emit-code)) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + ;; box args if necessary + (for-each + (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) x) + ((#t #t . ,n) + (emit-code #f (make-glil-lexical #t #f 'ref n)) + (emit-code #f (make-glil-lexical #t #t 'box n))))) + vars) + ;; and here, here, dear reader: we compile. + (flatten (lambda-body x) allocation x self-label + labels emit-code))))))) + +(define (flatten x allocation self self-label fix-labels emit-code) + (define (emit-label label) + (emit-code #f (make-glil-label label))) + (define (emit-branch src inst label) + (emit-code src (make-glil-branch inst label))) + + ;; RA: "return address"; #f unless we're in a non-tail fix with labels + ;; MVRA: "multiple-values return address"; #f unless we're in a let-values + (let comp ((x x) (context 'tail) (RA #f) (MVRA #f)) + (define (comp-tail tree) (comp tree context RA MVRA)) + (define (comp-push tree) (comp tree 'push #f #f)) + (define (comp-drop tree) (comp tree 'drop #f #f)) + (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) + (define (comp-fix tree RA) (comp tree context RA MVRA)) + + ;; A couple of helpers. Note that if we are in tail context, we + ;; won't have an RA. + (define (maybe-emit-return) + (if RA + (emit-branch #f 'br RA) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))) + + (record-case x + ((<void>) + (case context + ((push vals tail) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<const> src exp) + (case context + ((push vals tail) + (emit-code src (make-glil-const exp)))) + (maybe-emit-return)) + + ;; FIXME: should represent sequence as exps tail + ((<sequence> src exps) + (let lp ((exps exps)) + (if (null? (cdr exps)) + (comp-tail (car exps)) + (begin + (comp-drop (car exps)) + (lp (cdr exps)))))) + + ((<application> src proc args) + ;; FIXME: need a better pattern-matcher here + (cond + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@apply) + (>= (length args) 1)) + (let ((proc (car args)) + (args (cdr args))) + (cond + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push)) (not (eq? context 'vals))) + ;; tail: (lambda () (apply values '(1 2))) + ;; drop: (lambda () (apply values '(1 2)) 3) + ;; push: (lambda () (list (apply values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args) (maybe-emit-return)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values* (length args)))))) + + (else + (case context + ((tail) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'goto/apply (1+ (length args))))) + ((push) + (emit-code src (make-glil-call 'new-frame 0)) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'apply (1+ (length args)))) + (maybe-emit-return)) + ((vals) + (comp-vals + (make-application src (make-primitive-ref #f 'apply) + (cons proc args)) + MVRA) + (maybe-emit-return)) + ((drop) + ;; Well, shit. The proc might return any number of + ;; values (including 0), since it's in a drop context, + ;; yet apply does not create a MV continuation. So we + ;; mv-call out to our trampoline instead. + (comp-drop + (make-application src (make-primitive-ref #f 'apply) + (cons proc args))) + (maybe-emit-return))))))) + + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...) + (case context + ((drop) (for-each comp-drop args) (maybe-emit-return)) + ((vals) + (for-each comp-push args) + (emit-code #f (make-glil-const (length args))) + (emit-branch src 'br MVRA)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2)) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (case context + ((vals) + ;; Fall back. + (comp-vals + (make-application src (make-primitive-ref #f 'call-with-values) + args) + MVRA) + (maybe-emit-return)) + (else + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (if (not (eq? context 'tail)) + (emit-code src (make-glil-call 'new-frame 0))) + (comp-push consumer) + (emit-code src (make-glil-call 'new-frame 0)) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 1))) + (else (emit-code src (make-glil-call 'call 1)) + (emit-branch #f 'br POST))) + (emit-label MV) + (case context + ((tail) (emit-code src (make-glil-call 'goto/nargs 0))) + (else (emit-code src (make-glil-call 'call/nargs 0)) + (emit-label POST) + (if (eq? context 'drop) + (emit-code #f (make-glil-call 'drop 1))) + (maybe-emit-return))))))) + + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-current-continuation) + (= (length args) 1)) + (case context + ((tail) + (comp-push (car args)) + (emit-code src (make-glil-call 'goto/cc 1))) + ((vals) + (comp-vals + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args) + MVRA) + (maybe-emit-return)) + ((push) + (comp-push (car args)) + (emit-code src (make-glil-call 'call/cc 1)) + (maybe-emit-return)) + ((drop) + ;; Crap. Just like `apply' in drop context. + (comp-drop + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args)) + (maybe-emit-return)))) + + ((and (primitive-ref? proc) + (or (hash-ref *primcall-ops* + (cons (primitive-ref-name proc) (length args))) + (hash-ref *primcall-ops* (primitive-ref-name proc)))) + => (lambda (op) + (for-each comp-push args) + (emit-code src (make-glil-call op (length args))) + (case (instruction-pushes op) + ((0) + (case context + ((tail push vals) (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + ((1) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + (else + (error "bad primitive op: too many pushes" + op (instruction-pushes op)))))) + + ;; da capo al fine + ((and (lexical-ref? proc) + self-label (eq? (lexical-ref-gensym proc) self-label) + ;; self-call in tail position is a goto + (eq? context 'tail) + ;; make sure the arity is right + (list? (lambda-vars self)) + (= (length args) (length (lambda-vars self)))) + ;; evaluate new values + (for-each comp-push args) + ;; rename & goto + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t ,boxed? . ,index) + ;; set unboxed, as the proc prelude will box if needed + (emit-code #f (make-glil-lexical #t #f 'set index))) + (,x (error "what" x)))) + (reverse (lambda-vars self))) + (emit-branch src 'br self-label)) + + ;; lambda, the ultimate goto + ((and (lexical-ref? proc) + (assq (lexical-ref-gensym proc) fix-labels)) + ;; evaluate new values, assuming that analyze-lexicals did its + ;; job, and that the arity was right + (for-each comp-push args) + ;; rename + (for-each (lambda (sym) + (pmatch (hashq-ref (hashq-ref allocation sym) self) + ((#t #f . ,index) + (emit-code #f (make-glil-lexical #t #f 'set index))) + ((#t #t . ,index) + (emit-code #f (make-glil-lexical #t #t 'box index))) + (,x (error "what" x)))) + (reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) + ;; goto! + (emit-branch src 'br (lexical-ref-gensym proc))) + + (else + (if (not (eq? context 'tail)) + (emit-code src (make-glil-call 'new-frame 0))) + (comp-push proc) + (for-each comp-push args) + (let ((len (length args))) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args len))) + ((push) (emit-code src (make-glil-call 'call len)) + (maybe-emit-return)) + ((vals) (emit-code src (make-glil-mv-call len MVRA)) + (maybe-emit-return)) + ((drop) (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br (or RA POST)) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (if RA + (emit-branch #f 'br RA) + (emit-label POST))))))))) + + ((<conditional> src test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (emit-branch src 'br-if-not L1) + (comp-tail then) + ;; if there is an RA, comp-tail will cause a jump to it -- just + ;; have to clean up here if there is no RA. + (if (and (not RA) (not (eq? context 'tail))) + (emit-branch #f 'br L2)) + (emit-label L1) + (comp-tail else) + (if (and (not RA) (not (eq? context 'tail))) + (emit-label L2)))) + + ((<primitive-ref> src name) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((tail push vals) + (emit-code src (make-glil-toplevel 'ref name)))) + (maybe-emit-return)) + ((module-variable the-root-module name) + (case context + ((tail push vals) + (emit-code src (make-glil-module 'ref '(guile) name #f)))) + (maybe-emit-return)) + (else + (case context + ((tail push vals) + (emit-code src (make-glil-module + 'ref (module-name (fluid-ref *comp-module*)) name #f)))) + (maybe-emit-return)))) + + ((<lexical-ref> src name gensym) + (case context + ((push vals tail) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'ref index))) + (,loc + (error "badness" x loc))))) + (maybe-emit-return)) + + ((<lexical-set> src name gensym exp) + (comp-push exp) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src (make-glil-lexical local? boxed? 'set index))) + (,loc + (error "badness" x loc))) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<module-ref> src mod name public?) + (emit-code src (make-glil-module 'ref mod name public?)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + + ((<module-set> src mod name public? exp) + (comp-push exp) + (emit-code src (make-glil-module 'set mod name public?)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<toplevel-ref> src name) + (emit-code src (make-glil-toplevel 'ref name)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1)))) + (maybe-emit-return)) + + ((<toplevel-set> src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'set name)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<toplevel-define> src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'define name)) + (case context + ((tail push vals) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + + ((<lambda>) + (let ((free-locs (cddr (hashq-ref allocation x)))) + (case context + ((push vals tail) + (emit-code #f (flatten-lambda x #f allocation)) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (emit-code #f (make-glil-call 'make-closure 2))))))) + (maybe-emit-return)) + + ((<let> src names vars vals body) + (for-each comp-push vals) + (emit-bindings src names vars allocation self emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + ((<letrec> src names vars vals body) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'empty-box n))) + (,loc (error "badness" x loc)))) + vars) + (for-each comp-push vals) + (emit-bindings src names vars allocation self emit-code) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'set n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind))) + + ((<fix> src names vars vals body) + ;; The ideal here is to just render the lambda bodies inline, and + ;; wire the code together with gotos. We can do that if + ;; analyze-lexicals has determined that a given var has "label" + ;; allocation -- which is the case if it is in `fix-labels'. + ;; + ;; But even for closures that we can't inline, we can do some + ;; tricks to avoid heap-allocation for the binding itself. Since + ;; we know the vals are lambdas, we can set them to their local + ;; var slots first, then capture their bindings, mutating them in + ;; place. + (let ((RA (if (eq? context 'tail) #f (make-label)))) + (for-each + (lambda (x v) + (cond + ((hashq-ref allocation x) + ;; allocating a closure + (emit-code #f (flatten-lambda x v allocation)) + (if (not (null? (cddr (hashq-ref allocation x)))) + ;; Need to make-closure first, but with a temporary #f + ;; free-variables vector, so we are mutating fresh + ;; closures on the heap. + (begin + (emit-code #f (make-glil-const #f)) + (emit-code #f (make-glil-call 'make-closure 2)))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + (,loc (error "badness" x loc)))) + (else + ;; labels allocation: emit label & body, but jump over it + (let ((POST (make-label))) + (emit-branch #f 'br POST) + (emit-label v) + ;; we know the lambda vars are a list + (emit-bindings #f (lambda-names x) (lambda-vars x) + allocation self emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + (comp-fix (lambda-body x) RA) + (emit-code #f (make-glil-unbind)) + (emit-label POST))))) + vals + vars) + ;; Emit bindings metadata for closures + (let ((binds (let lp ((out '()) (vars vars) (names names)) + (cond ((null? vars) (reverse! out)) + ((assq (car vars) fix-labels) + (lp out (cdr vars) (cdr names))) + (else + (lp (acons (car vars) (car names) out) + (cdr vars) (cdr names))))))) + (emit-bindings src (map cdr binds) (map car binds) + allocation self emit-code)) + ;; Now go back and fix up the bindings for closures. + (for-each + (lambda (x v) + (let ((free-locs (if (hashq-ref allocation x) + (cddr (hashq-ref allocation x)) + ;; can hit this latter case for labels allocation + '()))) + (if (not (null? free-locs)) + (begin + (for-each + (lambda (loc) + (pmatch loc + ((,local? ,boxed? . ,n) + (emit-code #f (make-glil-lexical local? #f 'ref n))) + (else (error "what" x loc)))) + free-locs) + (emit-code #f (make-glil-call 'vector (length free-locs))) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code #f (make-glil-lexical #t #f 'fix n))) + (,loc (error "badness" x loc))))))) + vals + vars) + (comp-tail body) + (emit-label RA) + (emit-code #f (make-glil-unbind)))) + + ((<let-values> src names vars exp body) + (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) + (cond + ((pair? inames) + (lp (cons (car inames) names) (cons (car ivars) vars) + (cdr inames) (cdr ivars) #f)) + ((not (null? inames)) + (lp (cons inames names) (cons ivars vars) '() '() #t)) + (else + (let ((names (reverse! names)) + (vars (reverse! vars)) + (MV (make-label))) + (comp-vals exp MV) + (emit-code #f (make-glil-const 1)) + (emit-label MV) + (emit-code src (make-glil-mv-bind + (vars->bind-list names vars allocation self) + rest?)) + (for-each (lambda (v) + (pmatch (hashq-ref (hashq-ref allocation v) self) + ((#t #f . ,n) + (emit-code src (make-glil-lexical #t #f 'set n))) + ((#t #t . ,n) + (emit-code src (make-glil-lexical #t #t 'box n))) + (,loc (error "badness" x loc)))) + (reverse vars)) + (comp-tail body) + (emit-code #f (make-glil-unbind)))))))))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..9b66d9ed5 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,240 @@ +;;; transformation of letrec into simpler forms + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (language tree-il fix-letrec) + #:use-module (system base syntax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:export (fix-letrec!)) + +;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet +;; Efficient Implementation of Scheme’s Recursive Binding Construct", by +;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. + +(define fix-fold + (make-tree-il-folder unref ref set simple lambda complex)) + +(define (simple-expression? x bound-vars) + (record-case x + ((<void>) #t) + ((<const>) #t) + ((<lexical-ref> gensym) + (not (memq gensym bound-vars))) + ((<conditional> test then else) + (and (simple-expression? test bound-vars) + (simple-expression? then bound-vars) + (simple-expression? else bound-vars))) + ((<sequence> exps) + (and-map (lambda (x) (simple-expression? x bound-vars)) + exps)) + ((<application> proc args) + (and (primitive-ref? proc) + (effect-free-primitive? (primitive-ref-name proc)) + (and-map (lambda (x) (simple-expression? x bound-vars)) + args))) + (else #f))) + +(define (partition-vars x) + (let-values + (((unref ref set simple lambda* complex) + (fix-fold x + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<lexical-ref> gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + ((<lexical-set> gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + ((<letrec> vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + ((<let> vars) + (values (append vars unref) + ref + set + simple + lambda* + complex)) + (else + (values unref ref set simple lambda* complex)))) + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<letrec> (orig-vars vars) vals) + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((lambda? (car vals)) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ((simple-expression? (car vals) orig-vars) + (lp (cdr vars) (cdr vals) + (cons (car vars) s) l c)) + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + ((<let> (orig-vars vars) vals) + ;; The point is to compile let-bound lambdas as + ;; efficiently as we do letrec-bound lambdas, so + ;; we use the same algorithm for analyzing the + ;; vars. There is no problem recursing into the + ;; bindings after the let, because all variables + ;; have been renamed. + (let lp ((vars orig-vars) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? vars) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car vars) unref) + (lp (cdr vars) (cdr vals) + s l c)) + ((memq (car vars) set) + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c))) + ((and (lambda? (car vals)) + (not (memq (car vars) set))) + (lp (cdr vars) (cdr vals) + s (cons (car vars) l) c)) + ;; There is no difference between simple and + ;; complex, for the purposes of let. Just lump + ;; them all into complex. + (else + (lp (cdr vars) (cdr vals) + s l (cons (car vars) c)))))) + (else + (values unref ref set simple lambda* complex)))) + '() + '() + '() + '() + '() + '()))) + (values unref simple lambda* complex))) + +(define (fix-letrec! x) + (let-values (((unref simple lambda* complex) (partition-vars x))) + (post-order! + (lambda (x) + (record-case x + + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + ((<lexical-set> gensym exp) + (if (memq gensym unref) + (make-sequence #f (list exp (make-void #f))) + x)) + + ((<letrec> src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (s (lookup simple)) + (l (lookup lambda*)) + (c (lookup complex))) + ;; Bind "simple" bindings, and locations for complex + ;; bindings. + (make-let + src + (append (map cadr s) (map cadr c)) + (append (map car s) (map car c)) + (append (map caddr s) (map (lambda (x) (make-void #f)) c)) + ;; Bind lambdas using the fixpoint operator. + (make-fix + src (map cadr l) (map car l) (map caddr l) + (make-sequence + src + (append + ;; The right-hand-sides of the unreferenced + ;; bindings, for effect. + (map caddr u) + (if (null? c) + ;; No complex bindings, just emit the body. + (list body) + (list + ;; Evaluate the the "complex" bindings, in a `let' to + ;; indicate that order doesn't matter, and bind to + ;; their variables. + (let ((tmps (map (lambda (x) (gensym)) c))) + (make-let + #f (map cadr c) tmps (map caddr c) + (make-sequence + #f + (map (lambda (x tmp) + (make-lexical-set + #f (cadr x) (car x) + (make-lexical-ref #f (cadr x) tmp))) + c tmps)))) + ;; Finally, the body. + body))))))))) + + ((<let> src names vars vals body) + (let ((binds (map list vars names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? vars set))) + (let ((u (lookup unref)) + (l (lookup lambda*)) + (c (lookup complex))) + (make-sequence + src + (append + ;; unreferenced bindings, called for effect. + (map caddr u) + (list + ;; unassigned lambdas use fix. + (make-fix src (map cadr l) (map car l) (map caddr l) + ;; and the "complex" bindings. + (make-let src (map cadr c) (map car c) (map caddr c) + body)))))))) + + (else x))) + x))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm new file mode 100644 index 000000000..adc3f18bd --- /dev/null +++ b/module/language/tree-il/inline.scm @@ -0,0 +1,81 @@ +;;; a simple inliner + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (language tree-il inline) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (inline!)) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + +;; This is a completely brain-dead optimization pass whose sole claim to +;; fame is ((lambda () x)) => x. +(define (inline! x) + (post-order! + (lambda (x) + (record-case x + ((<application> src proc args) + (cond + + ;; ((lambda () x)) => x + ((and (lambda? proc) (null? (lambda-vars proc)) + (null? args)) + (lambda-body proc)) + + ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) + ;; => (let-values (((a b . c) foo)) bar) + ;; + ;; Note that this is a singly-binding form of let-values. Also + ;; note that Scheme's let-values expands into call-with-values, + ;; then here we reduce it to tree-il's let-values. + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2) + (lambda? (cadr args))) + (let ((producer (car args)) + (consumer (cadr args))) + (make-let-values src + (lambda-names consumer) + (lambda-vars consumer) + (if (and (lambda? producer) + (null? (lambda-names producer))) + (lambda-body producer) + (make-application src producer '())) + (lambda-body consumer)))) + + (else #f))) + + ((<let> vars body) + (if (null? vars) body x)) + + ((<letrec> vars body) + (if (null? vars) body x)) + + ((<fix> vars body) + (if (null? vars) body x)) + + (else #f))) + x)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..0e490a636 --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,35 @@ +;;; Tree-il optimizer + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language tree-il optimize) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il inline) + #:use-module (language tree-il fix-letrec) + #:export (optimize!)) + +(define (env-module e) + (if e (car e) (current-module))) + +(define (optimize! x env opts) + (inline! + (fix-letrec! + (expand-primitives! + (resolve-primitives! x (env-module env)))))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm new file mode 100644 index 000000000..955c7bf25 --- /dev/null +++ b/module/language/tree-il/primitives.scm @@ -0,0 +1,287 @@ +;;; open-coding primitive procedures + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language tree-il primitives) + #:use-module (system base pmatch) + #:use-module (rnrs bytevector) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-16) + #:export (resolve-primitives! add-interesting-primitive! + expand-primitives! effect-free-primitive?)) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + call/cc + values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + vector-ref vector-set! + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) + name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define *effect-free-primitives* + '(values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + list vector + car cdr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + vector-ref + bytevector-u8-ref bytevector-s8-ref + bytevector-u16-ref bytevector-u16-native-ref + bytevector-s16-ref bytevector-s16-native-ref + bytevector-u32-ref bytevector-u32-native-ref + bytevector-s32-ref bytevector-s32-native-ref + bytevector-u64-ref bytevector-u64-native-ref + bytevector-s64-ref bytevector-s64-native-ref + bytevector-ieee-single-ref bytevector-ieee-single-native-ref + bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) + + +(define *effect-free-primitive-table* (make-hash-table)) + +(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t)) + *effect-free-primitives*) + +(define (effect-free-primitive? prim) + (hashq-ref *effect-free-primitive-table* prim)) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + ((<toplevel-ref> src name) + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (lambda (name) (make-primitive-ref src name)))) + ((<module-ref> src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) + (and m + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (lambda (name) (make-primitive-ref src name)))))) + (else #f))) + x)) + + + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primitives! x) + (pre-order! + (lambda (x) + (record-case x + ((<application> src proc args) + (and (primitive-ref? proc) + (let ((expand (hashq-ref *primitive-expand-table* + (primitive-ref-name proc)))) + (and expand (apply expand src args))))) + (else #f))) + x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(make-application src (make-primitive-ref src ',(caar in)) + ,(inline-args (cdar in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) out))))))) + +(define-primitive-expander zero? (x) + (= x 0)) + +(define-primitive-expander + + () 0 + (x) x + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1+ x) + (if (and (const? x) + (let ((x (const-exp x))) + (and (exact? x) (= x 1)))) + (1+ y) + (+ x y))) + (x y z . rest) (+ x (+ y z . rest))) + +(define-primitive-expander * + () 1 + (x) x + (x y z . rest) (* x (* y z . rest))) + +(define-primitive-expander - + (x) (- 0 x) + (x y) (if (and (const? y) + (let ((y (const-exp y))) + (and (exact? y) (= y 1)))) + (1- x) + (- x y)) + (x y z . rest) (- x (+ y z . rest))) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z . rest) (/ x (* y z . rest))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander apply (f . args) + (@apply f . args)) + +(define-primitive-expander call-with-values (producer consumer) + (@call-with-values producer consumer)) + +(define-primitive-expander call-with-current-continuation (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander call/cc (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander values (x) x) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..2d24f7bf6 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,42 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language tree-il spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (join exps env) + (make-sequence #f exps)) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse-tree-il + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) diff --git a/module/language/value/spec.scm b/module/language/value/spec.scm new file mode 100644 index 000000000..aebba8c8d --- /dev/null +++ b/module/language/value/spec.scm @@ -0,0 +1,30 @@ +;;; Guile Lowlevel Intermediate Language + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language value spec) + #:use-module (system base language) + #:export (value)) + +(define-language value + #:title "Guile Values" + #:version "0.3" + #:reader #f + #:printer write + ) |