* mes.c (sc_expand_env): New function.
(builtin_eval): Use it.
* module/mes/psyntax-0.mes: New file.
* module/mes/psyntax-1.mes: New file.
* tests/psyntax.test: New file.
* GNUmakefile (TESTS): Add it.
tests/scm.test\
tests/record.test\
tests/let-syntax.test\
+ tests/psyntax.test\
tests/match.test\
#
guile-check:
set -e; for i in $(TESTS); do\
- guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|base-0|loop-0|srfi-0') $$i);\
+ guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|base-0|loop-0|psyntax-|srfi-0') $$i);\
done
set -e; for i in $(TESTS); do\
guile -s <(cat $(MES-0) module/mes/test.mes $$i);\
scm symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
scm symbol_sc_expand = {SYMBOL, "sc-expand"};
+scm symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
+scm symbol_noexpand = {SYMBOL, "noexpand"};
scm symbol_syntax = {SYMBOL, "syntax"};
scm symbol_quasisyntax = {SYMBOL, "quasisyntax"};
scm symbol_unsyntax = {SYMBOL, "unsyntax"};
return e;
else if (e->car->type != PAIR)
{
+ if (e->car->type == STRING && string_to_symbol (e->car) == &symbol_noexpand)
+ e = cadr (e);
+ else
+ e = sc_expand_env (e, a);
if (e->car == &symbol_quote)
return cadr (e);
#if QUASISYNTAX
return e;
}
+scm *
+sc_expand_env (scm *e, scm *a)
+{
+ scm *expanders;
+ scm *macro;
+ if (e->type == PAIR
+ && car (e)->type == SYMBOL
+ && car (e) != &symbol_quasiquote
+ && car (e) != &symbol_quote
+ && car (e) != &symbol_unquote
+ && car (e) != &symbol_unquote_splicing
+ && ((expanders = assq_ref_cache (&symbol_sc_expander_alist, a)) != &scm_undefined)
+ && ((macro = assq (car (e), expanders)) != &scm_f))
+ {
+ scm *sc_expand = assq_ref_cache (&symbol_sc_expand, a);
+ if (sc_expand != &scm_undefined)
+ return apply_env (sc_expand, cons (e, &scm_nil), a);
+ }
+ return e;
+}
+
scm *
begin (scm *e, scm *a)
{
#include "define.environment.i"
#include "type.environment.i"
+ a = add_environment (a, "sc-expand", &scm_f);
+
a = cons (cons (&scm_closure, a), a);
return a;
}
--- /dev/null
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+
+(define (interaction-environment) (current-module))
+
+;; (define c:eval (assq-ref %builtins 'eval))
+;; (define (eval x . environment)
+;; (display "***EVAL x=***=\n")
+;; (display x)
+;; (newline)
+;; (c:eval (if (and (pair? x)
+;; (equal? (car x) "noexpand"))
+;; (cadr x)
+;; (sc-expand x))
+;; (interaction-environment)))
+
+(define annotation? (lambda (x) #f))
+(define (self-evaluating? x)
+ (or (boolean? x) (number? x) (string? x) (char? x) (null? x)))
+
+(define (void) (if #f #f))
+
+
+(define sc-expand #f)
+(define sc-chi #f)
+(define sc-expand3 #f)
+(define install-global-transformer #f)
+(define syntax-dispatch #f)
+(define syntax-error #f)
+
+(define bound-identifier=? #f)
+(define datum->syntax-object #f)
+(define define-syntax (void))
+(define fluid-let-syntax #f)
+(define free-identifier=? #f)
+(define generate-temporaries #f)
+(define identifier? #f)
+(define identifier-syntax #f)
+(define let-syntax #f)
+(define letrec-syntax #f)
+(define syntax #f)
+(define syntax-case #f)
+(define syntax-object->datum #f)
+(define syntax-rules #f)
+(define with-syntax #f)
+
+(define andmap
+ (lambda (f . lists)
+ (if (null? (car lists)) (and)
+ (if (null? (cdr (car lists))) (apply f (map car lists))
+ (and (apply f (map car lists))
+ (apply andmap f (map cdr lists)))))))
+
+(define ormap
+ (lambda (proc list1)
+ (and (not (null? list1))
+ (or (proc (car list1)) (ormap proc (cdr list1))))))
+
+(define *sc-expander-alist* '())
+
+(define putprop #f)
+(define getprop #f)
+
+;;(define properties *sc-expander-alist*)
+(let ((xproperties '()))
+ (set! putprop
+ (lambda (symbol key value)
+ (let ((plist (assq symbol *sc-expander-alist*)))
+ (if (pair? plist)
+ (let ((couple (assq key (cdr plist))))
+ (if (pair? couple)
+ (set-cdr! couple value)
+ (set-cdr! plist (cons (cons key value)
+ (cdr plist)))))
+ (let ((plist (list symbol (cons key value))))
+ (set! *sc-expander-alist* (cons plist *sc-expander-alist*)))))
+ value))
+ (set! getprop
+ (lambda (symbol key)
+ (let ((plist (assq symbol *sc-expander-alist*)))
+ (if (pair? plist)
+ (let ((couple (assq key (cdr plist))))
+ (if (pair? couple)
+ (cdr couple)
+ #f))
+ #f)))))
+;; (define fx+ +)
+;; (define fx- -)
+;; (define fx= =)
+;; (define fx< <)
--- /dev/null
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; psyntax-1.mes - post psyntax.pp hook. psyntax-1.mes is loaded
+;;; after psyntax-pp.mes.
+
+;;; Code:
+
+(define datum->syntax datum->syntax-object)
+(define syntax->datum syntax-object->datum)
+
+(define-macro (define-syntax macro-name transformer)
+ `(define-macro ,macro-name
+ `(lambda args
+ (eval
+ (syntax-object->datum
+ (,transformer (cons ,macro-name args)))
+ (current-module)))))
--- /dev/null
+;;; psyntax.pp
+;;; automatically generated from psyntax.ss
+;;; Mon Aug 18 13:18:06 EST 1997
+;;; see copyright notice in psyntax.ss
+
+((lambda ()
+ ((lambda ()
+ (letrec ((g115 (lambda (g800)
+ ((letrec ((g801 (lambda (g804 g802 g803)
+ (if (pair? g804)
+ (g801 (cdr g804)
+ (cons (g94 (car g804)
+ g803)
+ g802)
+ g803)
+ (if (g66 g804)
+ (cons (g94 g804 g803)
+ g802)
+ (if (null? g804)
+ g802
+ (if (g52 g804)
+ (g801 (g53 g804)
+ g802
+ (g85 g803
+ (g54 g804)))
+ (if (g43 g804)
+ (g801 (annotation-expression
+ g804)
+ g802
+ g803)
+ (cons g804
+ g802)))))))))
+ g801)
+ g800
+ '()
+ '(()))))
+ (g114 (lambda (g322)
+ ((lambda (g323) (if (g43 g323) (gensym) (gensym)))
+ (if (g52 g322) (g53 g322) g322))))
+ (g113 (lambda (g792 g791)
+ (if (memq 'top (g69 g791))
+ (if ((lambda (g793)
+ (if g793
+ g793
+ (if (pair? g792)
+ (g43 (car g792))
+ '#f)))
+ (g43 g792))
+ (g112 g792 '#f)
+ g792)
+ ((letrec ((g794 (lambda (g795)
+ (if (g52 g795)
+ (g113 (g53 g795)
+ (g54 g795))
+ (if (pair? g795)
+ ((lambda (g797 g796)
+ (if (if (eq? g797
+ (car g795))
+ (eq? g796
+ (cdr g795))
+ '#f)
+ g795
+ (cons g797
+ g796)))
+ (g794 (car g795))
+ (g794 (cdr g795)))
+ (if (vector? g795)
+ ((lambda (g798)
+ ((lambda (g799)
+ (if (andmap
+ eq?
+ g798
+ g799)
+ g795
+ (list->vector
+ g799)))
+ (map g794
+ g798)))
+ (vector->list
+ g795))
+ g795))))))
+ g794)
+ g792))))
+ (g112 (lambda (g325 g324)
+ (if (pair? g325)
+ ((lambda (g326)
+ (begin (when g324
+ (set-annotation-stripped!
+ g324
+ g326))
+ (set-car! g326 (g112 (car g325) '#f))
+ (set-cdr! g326 (g112 (cdr g325) '#f))
+ g326))
+ (cons '#f '#f))
+ (if (g43 g325)
+ ((lambda (g327)
+ (if g327
+ g327
+ (g112 (annotation-expression g325)
+ g325)))
+ (annotation-stripped g325))
+ (if (vector? g325)
+ ((lambda (g328)
+ (begin (when g324
+ (set-annotation-stripped!
+ g324
+ g328))
+ ((letrec ((g329 (lambda (g330)
+ (unless (g42 g330
+ '0)
+ (vector-set!
+ g328
+ g330
+ (g112 (vector-ref
+ g325
+ g330)
+ '#f))
+ (g329 (g40 g330
+ '1))))))
+ g329)
+ (- (vector-length g325) '1))
+ g328))
+ (make-vector (vector-length g325)))
+ g325)))))
+ (g111 (lambda (g790)
+ (if (g65 g790)
+ (g89 g790
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ strip-annotation
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ 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
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ 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-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ 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)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (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"))
+ #(ribcage
+ (define-structure)
+ ((top))
+ ("i"))
+ #(ribcage
+ (define-structure)
+ ((top))
+ ("i")))))
+ '#f)))
+ (g110 (lambda () (list 'void)))
+ (g109 (lambda (g788)
+ ((lambda (g789)
+ (if (procedure? g789)
+ g789
+ (syntax-error
+ g789
+ '"nonprocedure transfomer")))
+ (g45 g788))))
+ (g108 (lambda (g336 g331 g335 g332 g334 g333)
+ ((lambda (g337)
+ ((lambda (g338)
+ (if g338
+ (apply
+ (lambda (g343 g339 g342 g340 g341)
+ ((lambda (g344)
+ (if (not (g91 g344))
+ (syntax-error
+ g331
+ '"duplicate bound keyword in")
+ ((lambda (g345)
+ ((lambda (g346)
+ (g333 (cons g340 g341)
+ (g60 g345
+ ((lambda (g348
+ g347)
+ (map (lambda (g350)
+ (cons 'macro
+ (g109 (g102 g350
+ g347
+ g348))))
+ g342))
+ (if g336
+ g346
+ g332)
+ (g62 g335))
+ g335)
+ g346
+ g334))
+ (g83 g344 g345 g332)))
+ (g72 g344))))
+ g339))
+ g338)
+ ((lambda (g353)
+ (syntax-error (g95 g331 g332 g334)))
+ g337)))
+ (syntax-dispatch
+ g337
+ '(any #(each (any any)) any . each-any))))
+ g331)))
+ (g107 (lambda (g765 g761 g764 g762 g763)
+ ((lambda (g766)
+ ((lambda (g767)
+ (if g767
+ (apply
+ (lambda (g770 g768 g769)
+ ((lambda (g771)
+ (if (not (g91 g771))
+ (syntax-error
+ g765
+ '"invalid parameter list in")
+ ((lambda (g773 g772)
+ (g763 g772
+ (g106 (cons g768 g769)
+ g765
+ (g61 g773
+ g772
+ g764)
+ (g83 g771
+ g773
+ g762))))
+ (g72 g771)
+ (map g114 g771))))
+ g770))
+ g767)
+ ((lambda (g776)
+ (if g776
+ (apply
+ (lambda (g779 g777 g778)
+ ((lambda (g780)
+ (if (not (g91 g780))
+ (syntax-error
+ g765
+ '"invalid parameter list in")
+ ((lambda (g782 g781)
+ (g763 ((letrec ((g784 (lambda (g786
+ g785)
+ (if (null?
+ g786)
+ g785
+ (g784 (cdr g786)
+ (cons (car g786)
+ g785))))))
+ g784)
+ (cdr g781)
+ (car g781))
+ (g106 (cons g777
+ g778)
+ g765
+ (g61 g782
+ g781
+ g764)
+ (g83 g780
+ g782
+ g762))))
+ (g72 g780)
+ (map g114 g780))))
+ (g115 g779)))
+ g776)
+ ((lambda (g787)
+ (syntax-error g765))
+ g766)))
+ (syntax-dispatch
+ g766
+ '(any any . each-any)))))
+ (syntax-dispatch
+ g766
+ '(each-any any . each-any))))
+ g761)))
+ (g106 (lambda (g357 g354 g356 g355)
+ ((lambda (g358)
+ ((lambda (g359)
+ ((lambda (g360)
+ ((lambda ()
+ ((letrec ((g361 (lambda (g367
+ g362
+ g366
+ g363
+ g365
+ g364)
+ (if (null? g367)
+ (syntax-error
+ g354
+ '"no expressions in body")
+ ((lambda (g369
+ g368)
+ (call-with-values
+ (lambda ()
+ (g100 g369
+ g368
+ '(())
+ '#f
+ g359))
+ (lambda (g374
+ g370
+ g373
+ g371
+ g372)
+ ((lambda (g375)
+ (if (memv g375
+ '(define-form))
+ ((lambda (g377
+ g376)
+ ((lambda (g378)
+ (begin (g82 g359
+ g377
+ g376)
+ (g361 (cdr g367)
+ (cons g377
+ g362)
+ (cons g376
+ g366)
+ (cons g378
+ g363)
+ (cons (cons g368
+ (g94 g373
+ g371))
+ g365)
+ (cons (cons 'lexical
+ g378)
+ g364))))
+ (g114 g377)))
+ (g94 g370
+ g371)
+ (g71))
+ (if (memv g375
+ '(define-syntax-form))
+ ((lambda (g380
+ g379)
+ (begin (g82 g359
+ g380
+ g379)
+ (g361 (cdr g367)
+ (cons g380
+ g362)
+ (cons g379
+ g366)
+ g363
+ g365
+ (cons (cons 'macro
+ (cons g368
+ (g94 g373
+ g371)))
+ g364))))
+ (g94 g370
+ g371)
+ (g71))
+ (if (memv g375
+ '(begin-form))
+ ((lambda (g381)
+ ((lambda (g382)
+ (if g382
+ (apply
+ (lambda (g384
+ g383)
+ (g361 ((letrec ((g385 (lambda (g386)
+ (if (null?
+ g386)
+ (cdr g367)
+ (cons (cons g368
+ (g94 (car g386)
+ g371))
+ (g385 (cdr g386)))))))
+ g385)
+ g383)
+ g362
+ g366
+ g363
+ g365
+ g364))
+ g382)
+ (syntax-error
+ g381)))
+ (syntax-dispatch
+ g381
+ '(any .
+ each-any))))
+ g373)
+ (if (memv g375
+ '(local-syntax-form))
+ (g108 g370
+ g373
+ g368
+ g371
+ g372
+ (lambda (g391
+ g388
+ g390
+ g389)
+ (g361 ((letrec ((g392 (lambda (g393)
+ (if (null?
+ g393)
+ (cdr g367)
+ (cons (cons g388
+ (g94 (car g393)
+ g390))
+ (g392 (cdr g393)))))))
+ g392)
+ g391)
+ g362
+ g366
+ g363
+ g365
+ g364)))
+ (if (null?
+ g362)
+ (g49 '#f
+ (map (lambda (g394)
+ (g102 (cdr g394)
+ (car g394)
+ '(())))
+ (cons (cons g368
+ (g95 g373
+ g371
+ g372))
+ (cdr g367))))
+ (begin (if (not (g91 g362))
+ (syntax-error
+ g354
+ '"invalid or duplicate identifier in definition")
+ (void))
+ ((letrec ((g395 (lambda (g398
+ g396
+ g397)
+ (if (not (null?
+ g398))
+ ((lambda (g399)
+ ((lambda ()
+ (if (eq? (car g399)
+ 'macro)
+ ((lambda (g400)
+ ((lambda (g401)
+ ((lambda ()
+ (begin (set-cdr!
+ g399
+ (g109 (g102 (cddr g399)
+ g401
+ '(()))))
+ (g395 (cdr g398)
+ g400
+ g401)))))
+ (if (eq? g400
+ g396)
+ g397
+ (g62 g400))))
+ (cadr g399))
+ (g395 (cdr g398)
+ g396
+ g397)))))
+ (car g398))
+ (void)))))
+ g395)
+ g364
+ '#f
+ '#f)
+ (set-cdr!
+ g358
+ (g60 g366
+ g364
+ (cdr g358)))
+ (g50 '#f
+ g363
+ (map (lambda (g403)
+ (g102 (cdr g403)
+ (car g403)
+ '(())))
+ g365)
+ (g49 '#f
+ (map (lambda (g402)
+ (g102 (cdr g402)
+ (car g402)
+ '(())))
+ (cons (cons g368
+ (g95 g373
+ g371
+ g372))
+ (cdr g367))))))))))))
+ g374))))
+ (cdar g367)
+ (caar g367))))))
+ g361)
+ (map (lambda (g404)
+ (cons g358 (g94 g404 g360)))
+ g357)
+ '()
+ '()
+ '()
+ '()
+ '()))))
+ (g68 (g69 g355) (cons g359 (g70 g355)))))
+ (g73 '() '() '())))
+ (cons '("placeholder" placeholder) g356))))
+ (g105 (lambda (g750 g746 g749 g747 g748)
+ (letrec ((g751 (lambda (g753 g752)
+ (if (pair? g753)
+ (cons (g751 (car g753) g752)
+ (g751 (cdr g753) g752))
+ (if (g52 g753)
+ ((lambda (g754)
+ ((lambda (g756 g755)
+ (g51 (g53 g753)
+ (if (if (pair?
+ g756)
+ (eq? (car g756)
+ '#f)
+ '#f)
+ (g68 (cdr g756)
+ (if g748
+ (cons g748
+ (cdr g755))
+ (cdr g755)))
+ (g68 (cons g752
+ g756)
+ (if g748
+ (cons g748
+ (cons 'shift
+ g755))
+ (cons 'shift
+ g755))))))
+ (g69 g754)
+ (g70 g754)))
+ (g54 g753))
+ (if (vector? g753)
+ ((lambda (g757)
+ ((lambda (g758)
+ ((lambda ()
+ ((letrec ((g759 (lambda (g760)
+ (if (g41 g760
+ g757)
+ g758
+ (begin (vector-set!
+ g758
+ g760
+ (g751 (vector-ref
+ g753
+ g760)
+ g752))
+ (g759 (g39 g760
+ '1)))))))
+ g759)
+ '0))))
+ (make-vector
+ g757)))
+ (vector-length g753))
+ (if (symbol? g753)
+ (syntax-error
+ g753
+ '"encountered raw symbol in macro output")
+ g753)))))))
+ (g751 (g750 (g94 g746 (g81 g747)))
+ (string '#\m)))))
+ (g104 (lambda (g409 g405 g408 g406 g407)
+ ((lambda (g410)
+ ((lambda (g411)
+ (if g411
+ (apply
+ (lambda (g413 g412)
+ (cons g409
+ (map (lambda (g415)
+ (g102 g415 g408 g406))
+ g412)))
+ g411)
+ (syntax-error g410)))
+ (syntax-dispatch g410 '(any . each-any))))
+ g405)))
+ (g103 (lambda (g729 g724 g728 g725 g727 g726)
+ ((lambda (g730)
+ (if (memv g730 '(lexical))
+ g724
+ (if (memv g730 '(core))
+ (g724 g728 g725 g727 g726)
+ (if (memv g730 '(lexical-call))
+ (g104 g724 g728 g725 g727 g726)
+ (if (memv g730 '(global-call))
+ (g104 g724 g728 g725 g727 g726)
+ (if (memv g730 '(constant))
+ (list 'quote
+ (g113 (g95 g728
+ g727
+ g726)
+ '(())))
+ (if (memv g730 '(global))
+ g724
+ (if (memv g730 '(call))
+ (g104 (g102 (car g728)
+ g725
+ g727)
+ g728
+ g725
+ g727
+ g726)
+ (if (memv g730
+ '(begin-form))
+ ((lambda (g731)
+ ((lambda (g732)
+ (if g732
+ (apply
+ (lambda (g735
+ g733
+ g734)
+ (g96 (cons g733
+ g734)
+ g725
+ g727
+ g726))
+ g732)
+ (syntax-error
+ g731)))
+ (syntax-dispatch
+ g731
+ '(any any
+ .
+ each-any))))
+ g728)
+ (if (memv g730
+ '(local-syntax-form))
+ (g108 g724
+ g728
+ g725
+ g727
+ g726
+ g96)
+ (if (memv g730
+ '(eval-when-form))
+ ((lambda (g737)
+ ((lambda (g738)
+ (if g738
+ (apply
+ (lambda (g742
+ g739
+ g741
+ g740)
+ ((lambda (g743)
+ (if (memq 'eval
+ g743)
+ (g96 (cons g741
+ g740)
+ g725
+ g727
+ g726)
+ (g110)))
+ (g99 g728
+ g739
+ g727)))
+ g738)
+ (syntax-error
+ g737)))
+ (syntax-dispatch
+ g737
+ '(any each-any
+ any
+ .
+ each-any))))
+ g728)
+ (if (memv g730
+ '(define-form
+ define-syntax-form))
+ (syntax-error
+ (g94 g724
+ g727)
+ '"invalid context for definition of")
+ (if (memv g730
+ '(syntax))
+ (syntax-error
+ (g95 g728
+ g727
+ g726)
+ '"reference to pattern variable outside syntax form")
+ (if (memv g730
+ '(displaced-lexical))
+ (syntax-error
+ (g95 g728
+ g727
+ g726)
+ '"reference to identifier outside its scope")
+ (syntax-error
+ (g95 g728
+ g727
+ g726))))))))))))))))
+ g729)))
+ (g102 (lambda (g418 g416 g417)
+ (call-with-values
+ (lambda () (g100 g418 g416 g417 '#f '#f))
+ (lambda (g423 g419 g422 g420 g421)
+ (g103 g423 g419 g422 g416 g420 g421)))))
+ (g101 (lambda (g678 g674 g677 g675 g676)
+ (call-with-values
+ (lambda () (g100 g678 g674 g677 '#f '#f))
+ (lambda (g689 g685 g688 g686 g687)
+ ((lambda (g690)
+ (if (memv g690 '(begin-form))
+ ((lambda (g691)
+ ((lambda (g692)
+ (if g692
+ (apply
+ (lambda (g693) (g110))
+ g692)
+ ((lambda (g694)
+ (if g694
+ (apply
+ (lambda (g697
+ g695
+ g696)
+ (g97 (cons g695
+ g696)
+ g674
+ g686
+ g687
+ g675
+ g676))
+ g694)
+ (syntax-error g691)))
+ (syntax-dispatch
+ g691
+ '(any any . each-any)))))
+ (syntax-dispatch g691 '(any))))
+ g688)
+ (if (memv g690 '(local-syntax-form))
+ (g108 g685
+ g688
+ g674
+ g686
+ g687
+ (lambda (g702 g699 g701 g700)
+ (g97 g702
+ g699
+ g701
+ g700
+ g675
+ g676)))
+ (if (memv g690 '(eval-when-form))
+ ((lambda (g703)
+ ((lambda (g704)
+ (if g704
+ (apply
+ (lambda (g708
+ g705
+ g707
+ g706)
+ ((lambda (g710
+ g709)
+ (if (eq? g675
+ 'e)
+ (if (memq 'eval
+ g710)
+ (g97 g709
+ g674
+ g686
+ g687
+ 'e
+ '(eval))
+ (g110))
+ (if (memq 'load
+ g710)
+ (if ((lambda (g711)
+ (if g711
+ g711
+ (if (eq? g675
+ 'c&e)
+ (memq 'eval
+ g710)
+ '#f)))
+ (memq 'compile
+ g710))
+ (g97 g709
+ g674
+ g686
+ g687
+ 'c&e
+ '(compile
+ load))
+ (if (memq g675
+ '(c c&e))
+ (g97 g709
+ g674
+ g686
+ g687
+ 'c
+ '(load))
+ (g110)))
+ (if ((lambda (g712)
+ (if g712
+ g712
+ (if (eq? g675
+ 'c&e)
+ (memq 'eval
+ g710)
+ '#f)))
+ (memq 'compile
+ g710))
+ (begin (g44 (g97 g709
+ g674
+ g686
+ g687
+ 'e
+ '(eval)))
+ (g110))
+ (g110)))))
+ (g99 g688
+ g705
+ g686)
+ (cons g707 g706)))
+ g704)
+ (syntax-error g703)))
+ (syntax-dispatch
+ g703
+ '(any each-any
+ any
+ .
+ each-any))))
+ g688)
+ (if (memv g690
+ '(define-syntax-form))
+ ((lambda (g716 g715)
+ ((lambda (g717)
+ (if (memv g717 '(c))
+ (if (memq 'compile
+ g676)
+ ((lambda (g718)
+ (begin (g44 g718)
+ (if (memq 'load
+ g676)
+ g718
+ (g110))))
+ (g98 g716
+ (g102 g688
+ g715
+ g686)))
+ (if (memq 'load
+ g676)
+ (g98 g716
+ (g102 g688
+ g715
+ g686))
+ (g110)))
+ (if (memv g717
+ '(c&e))
+ ((lambda (g719)
+ (begin (g44 g719)
+ g719))
+ (g98 g716
+ (g102 g688
+ g715
+ g686)))
+ (begin (if (memq 'eval
+ g676)
+ (g44 (g98 g716
+ (g102 g688
+ g715
+ g686)))
+ (void))
+ (g110)))))
+ g675))
+ (g88 g685 g686)
+ (g62 g674))
+ (if (memv g690
+ '(define-form))
+ ((lambda (g720)
+ ((lambda (g721)
+ (if (memv g721
+ '(global))
+ ((lambda (g722)
+ (begin (if (eq? g675
+ 'c&e)
+ (g44 g722)
+ (void))
+ g722))
+ (list 'define
+ g720
+ (g102 g688
+ g674
+ g686)))
+ (if (memv g721
+ '(displaced-lexical))
+ (syntax-error
+ (g94 g685
+ g686)
+ '"identifier out of context")
+ (syntax-error
+ (g94 g685
+ g686)
+ '"cannot define keyword at top level"))))
+ (g58 (g63 g720
+ g674))))
+ (g88 g685 g686))
+ ((lambda (g723)
+ (begin (if (eq? g675
+ 'c&e)
+ (g44 g723)
+ (void))
+ g723))
+ (g103 g689
+ g685
+ g688
+ g674
+ g686
+ g687))))))))
+ g689)))))
+ (g100 (lambda (g428 g424 g427 g425 g426)
+ (if (symbol? g428)
+ ((lambda (g429)
+ ((lambda (g430)
+ ((lambda (g431)
+ ((lambda ()
+ ((lambda (g432)
+ (if (memv g432 '(lexical))
+ (values
+ g431
+ (g59 g430)
+ g428
+ g427
+ g425)
+ (if (memv g432 '(global))
+ (values
+ g431
+ g429
+ g428
+ g427
+ g425)
+ (if (memv g432 '(macro))
+ (g100 (g105 (g59 g430)
+ g428
+ g424
+ g427
+ g426)
+ g424
+ '(())
+ g425
+ g426)
+ (values
+ g431
+ (g59 g430)
+ g428
+ g427
+ g425)))))
+ g431))))
+ (g58 g430)))
+ (g63 g429 g424)))
+ (g88 g428 g427))
+ (if (pair? g428)
+ ((lambda (g433)
+ (if (g66 g433)
+ ((lambda (g434)
+ ((lambda (g435)
+ ((lambda (g436)
+ ((lambda ()
+ ((lambda (g437)
+ (if (memv g437
+ '(lexical))
+ (values
+ 'lexical-call
+ (g59 g435)
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(global))
+ (values
+ 'global-call
+ g434
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(macro))
+ (g100 (g105 (g59 g435)
+ g428
+ g424
+ g427
+ g426)
+ g424
+ '(())
+ g425
+ g426)
+ (if (memv g437
+ '(core))
+ (values
+ g436
+ (g59 g435)
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(local-syntax))
+ (values
+ 'local-syntax-form
+ (g59 g435)
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(begin))
+ (values
+ 'begin-form
+ '#f
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(eval-when))
+ (values
+ 'eval-when-form
+ '#f
+ g428
+ g427
+ g425)
+ (if (memv g437
+ '(define))
+ ((lambda (g438)
+ ((lambda (g439)
+ (if (if g439
+ (apply
+ (lambda (g442
+ g440
+ g441)
+ (g66 g440))
+ g439)
+ '#f)
+ (apply
+ (lambda (g445
+ g443
+ g444)
+ (values
+ 'define-form
+ g443
+ g444
+ g427
+ g425))
+ g439)
+ ((lambda (g446)
+ (if (if g446
+ (apply
+ (lambda (g451
+ g447
+ g450
+ g448
+ g449)
+ (if (g66 g447)
+ (g91 (g115 g450))
+ '#f))
+ g446)
+ '#f)
+ (apply
+ (lambda (g456
+ g452
+ g455
+ g453
+ g454)
+ (values
+ 'define-form
+ (g94 g452
+ g427)
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_
+ name
+ args
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(t)
+ #(("m" top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(type)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(b)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(n)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(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-annotation
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ 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
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ 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-global-definition
+ build-global-assignment
+ build-global-reference
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ 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)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (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"))
+ #(ribcage
+ (define-structure)
+ ((top))
+ ("i"))
+ #(ribcage
+ (define-structure)
+ ((top))
+ ("i"))))
+ (g94 (cons g455
+ (cons g453
+ g454))
+ g427))
+ '(())
+ g425))
+ g446)
+ ((lambda (g458)
+ (if (if g458
+ (apply
+ (lambda (g460
+ g459)
+ (g66 g459))
+ g458)
+ '#f)
+ (apply
+ (lambda (g462
+ g461)
+ (values
+ 'define-form
+ (g94 g461
+ g427)
+ '(#(syntax-object
+ void
+ ((top)
+ #(ribcage
+ #(_
+ name)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(t)
+ #(("m" top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(type)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(b)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(n)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(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-annotation
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+
projects / mes.git / commitdiff