$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
- $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/compile-ghil.scm \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
- language/scheme/decompile-tree-il.scm \
- language/scheme/inline.scm
+ language/scheme/decompile-tree-il.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
-
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
language/glil/decompile-assembly.scm
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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))))
-
-\f
-;;;
-;;; Language definition
-;;;
-
-(define-language elisp
- #:title "Emacs Lisp"
- #:version "0.0"
- #:reader read
- #:expander id
- #:translator translate
- )
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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>))
-
-
-\f
-;;;
-;;; Variables
-;;;
-
-(define-record <ghil-var> env name kind (index #f))
-
-\f
-;;;
-;;; Modules
-;;;
-
-\f
-;;;
-;;; 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))
-
-
-\f
-;;;
-;;; 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))
-
-\f
-;;;
-;;; 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))))
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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)))
-
-\f
-;;;
-;;; 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))
+++ /dev/null
-;;; 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))
- )
+++ /dev/null
-;;; 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
+++ /dev/null
-;;; 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)
+++ /dev/null
-;;; 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:
+++ /dev/null
-;;; 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)))
+++ /dev/null
-;;; 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))))))))))
-
+++ /dev/null
-;;; 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))
-
-\f
-;;;
-;;; 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))))))
-
-\f
-;;;
-;;; 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)
- )
+++ /dev/null
-;;; 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)))
-
-\f
-
-(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))))))))
-
-\f
-;;;
-;;; 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))))
+++ /dev/null
-;;; 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))
HCoop / bpt / guile.git / commitdiff