expand.pp 36.3 KB
Newer Older
eg's avatar
eg committed
1
(begin ((lambda () (letrec ((lambda-var-list (lambda (vars) ((letrec ((lvl (lambda (vars ls) (if (pair? vars) (lvl (cdr vars) (cons (car vars) ls)) (if (id? vars) (cons vars ls) (if (null? vars) ls (if (syntax-object? vars) (lvl (unwrap vars) ls) (cons vars ls)))))))) lvl) vars '()))) (gen-var (lambda (id) (gen-sym (id-sym-name id)))) (gen-sym (lambda (sym) (sc:new-symbol-hook (symbol->string sym)))) (strip (lambda (x) (if (syntax-object? x) (strip (syntax-object-expression x)) (if (pair? x) ((lambda (a d) (if (if (eq? a (car x)) (eq? d (cdr x)) #f) x (cons a d))) (strip (car x)) (strip (cdr x))) (if (vector? x) ((lambda (old) ((lambda (new) (if (sc:andmap eq? old new) x (list->vector new))) (map strip old))) (vector->list x)) x))))) (regen (lambda (x) ((lambda (G139) (if (memv G139 '(ref)) (sc:build-lexical-reference (cadr x)) (if (memv G139 '(primitive)) (sc:build-global-reference (cadr x)) (if (memv G139 '(id)) (sc:build-identifier (cadr x)) (if (memv G139 '(quote)) (sc:build-data (cadr x)) (if (memv G139 '(lambda)) (sc:build-lambda (cadr x) (regen (caddr x))) (begin G139 (sc:build-application (sc:build-global-reference (car x)) (map regen (cdr x)))))))))) (car x)))) (gen-vector (lambda (x) (if (eq? (car x) 'list) (list* 'vector (cdr x)) (if (eq? (car x) 'quote) (list 'quote (list->vector (cadr x))) (list 'list->vector x))))) (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) (gen-cons (lambda (x y) (if (eq? (car y) 'list) (list* 'list x (cdr y)) (if (if (eq? (car x) 'quote) (eq? (car y) 'quote) #f) (list 'quote (cons (cadr x) (cadr y))) (if (equal? y ''()) (list 'list x) (list 'cons x y)))))) (gen-map (lambda (e map-env) ((lambda (formals actuals) (if (eq? (car e) 'ref) (car actuals) (if (sc:andmap (lambda (x) (if (eq? (car x) 'ref) (memq (cadr x) formals) #f)) (cdr e)) (list* 'map (list 'primitive (car e)) (map ((lambda (r) (lambda (x) (cdr (assq (cadr x) r)))) (map cons formals actuals)) (cdr e))) (list* 'map (list 'lambda formals e) actuals)))) (map cdr map-env) (map (lambda (x) (list 'ref (car x))) map-env)))) (gen-ref (lambda (var level maps k) (if (= level 0) (k var maps) (gen-ref var (- level 1) (cdr maps) (lambda (outer-var outer-maps) ((lambda (b) (if b (k (cdr b) maps) ((lambda (inner-var) (k inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))) (gen-sym var)))) (assq outer-var (car maps)))))))) (chi-syntax (lambda (src exp r w) ((letrec ((gen (lambda (e maps k) (if (id? e) ((lambda (n) ((lambda (b) (if (eq? (binding-type b) 'syntax) ((lambda (level) (if (< (length maps) level) (sc:syntax-error src "missing ellipsis in") (gen-ref n level maps (lambda (x maps) (k (list 'ref x) maps))))) (binding-value b)) (if (ellipsis? (wrap e w)) (sc:syntax-error src "invalid context for ... in") (k (list 'id (wrap e w)) maps)))) (lookup n e r))) (id-var-name e w)) ((lambda (G141) ((lambda (G142) ((lambda (G140) (if (not (eq? G140 'no)) ((lambda (_dots1 _dots2) (if (if (ellipsis? (wrap _dots1 w)) (ellipsis? (wrap _dots2 w)) #f) (k (list 'id (wrap _dots1 w)) maps) (G142))) (car G140) (cadr G140)) (G142))) (sc:syntax-dispatch G141 '(pair (any) pair (any) atom) (vector)))) (lambda () ((lambda (G144) ((lambda (G145) ((lambda (G143) (if (not (eq? G143 'no)) ((lambda (_x _dots _y) (if (ellipsis? (wrap _dots w)) (gen _y maps (lambda (y maps) (gen _x (cons '() maps) (lambda (x maps) (if (null? (car maps)) (sc:syntax-error src "extra ellipsis in") (k (gen-append (gen-map x (car maps)) y) (cdr maps))))))) (G145))) (car G143) (cadr G143) (caddr G143)) (G145))) (sc:syntax-dispatch G144 '(pair (any) pair (any) any) (vector)))) (lambda () ((lambda (G147) ((lambda (G146) (if (not (eq? G146 'no)) ((lambda (_x _y) (gen _x maps (lambda (x maps) (gen _y maps (lambda (y maps) (k (gen-cons x y) maps)))))) (car G146) (cadr G146)) ((lambda (G149) ((lambda (G148) (if (not (eq? G148 'no)) ((lambda (_e1 _e2) (gen (cons _e1 _e2) maps (lambda (e maps) (k (gen-vector e) maps)))) (car G148) (cadr G148)) ((lambda (G151) ((lambda (G150) (if (not (eq? G150 'no)) ((lambda (__) (k (list 'quote (wrap e w)) maps)) (car G150)) (sc:syntax-error G151))) (sc:syntax-dispatch G151 '(any) (vector)))) G149))) (sc:syntax-dispatch G149 '(vector pair (any) each any) (vector)))) G147))) (sc:syntax-dispatch G147 '(pair (any) any) (vector)))) G144)))) G141)))) e))))) gen) exp '() (lambda (e maps) (regen e))))) (ellipsis? (lambda (x) (if (sc:identifier? x) (free-id=? x '...) #f))) (chi-syntax-definition (lambda (e w) ((lambda (G153) ((lambda (G154) ((lambda (G152) (if (not (eq? G152 'no)) ((lambda (__ _name _val) (if (id? _name) (list _name _val) (G154))) (car G152) (cadr G152) (caddr G152)) (G154))) (sc:syntax-dispatch G153 '(pair (any) pair (any) pair (any) atom) (vector)))) (lambda () (sc:syntax-error G153)))) (wrap e w)))) (chi-definition (lambda (e w) ((lambda (G156) ((lambda (G157) ((lambda (G155) (if (not (eq? G155 'no)) (apply (lambda (__ _name _args _e1 _e2) (if (if (id? _name) (valid-bound-ids? (lambda-var-list _args)) #f) (list _name (cons '#(syntax-object lambda (top)) (cons _args (cons _e1 _e2)))) (G157))) G155) (G157))) (sc:syntax-dispatch G156 '(pair (any) pair (pair (any) any) pair (any) each any) (vector)))) (lambda () ((lambda (G159) ((lambda (G158) (if (not (eq? G158 'no)) ((lambda (__ _name _val) (list _name _val)) (car G158) (cadr G158) (caddr G158)) ((lambda (G161) ((lambda (G162) ((lambda (G160) (if (not (eq? G160 'no)) ((lambda (__ _name) (if (id? _name) (list _name (list '#(syntax-object void (top)))) (G162))) (car G160) (cadr G160)) (G162))) (sc:syntax-dispatch G161 '(pair (any) pair (any) atom) (vector)))) (lambda () (sc:syntax-error G161)))) G159))) (sc:syntax-dispatch G159 '(pair (any) pair (any) pair (any) atom) (vector)))) G156)))) (wrap e w)))) (chi-sequence (lambda (e w) ((lambda (G164) ((lambda (G163) (if (not (eq? G163 'no)) ((lambda (__ _e) _e) (car G163) (cadr G163)) (sc:syntax-error G164))) (sc:syntax-dispatch G164 '(pair (any) each any) (vector)))) (wrap e w)))) (chi-macro-def (lambda (def r w) (sc:eval-hook (chi def null-env w)))) (chi-local-syntax (lambda (e r w) ((lambda (G166) ((lambda (G167) ((lambda (G165) (if (not (eq? G165 'no)) (apply (lambda (_who _var _val _e1 _e2) (if (valid-bound-ids? _var) ((lambda (new-vars) ((lambda (new-w) (chi-body (cons _e1 _e2) e (extend-macro-env new-vars ((lambda (w) (map (lambda (x) (chi-macro-def x r w)) _val)) (if (free-id=? _who '#(syntax-object letrec-syntax (top))) new-w w)) r) new-w)) (make-binding-wrap _var new-vars w))) (map gen-var _var)) (G167))) G165) (G167))) (sc:syntax-dispatch G166 '(pair (any) pair (each pair (any) pair (any) atom) pair (any) each any) (vector)))) (lambda () ((lambda (G169) ((lambda (G168) (if (not (eq? G168 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G168)) (sc:syntax-error G169))) (sc:syntax-dispatch G169 '(any) (vector)))) G166)))) e))) (chi-body (lambda (body source r w) (if (null? (cdr body)) (chi (car body) r w) ((letrec ((parse1 (lambda (body var-ids var-vals macro-ids macro-vals) (if (null? body) (sc:syntax-error (wrap source w) "no expressions in body") ((letrec ((parse2 (lambda (e) ((lambda (b) ((lambda (G170) (if (memv G170 '(macro)) (parse2 (chi-macro (binding-value b) e r empty-wrap (lambda (e r w) (wrap e w)))) (if (memv G170 '(definition)) (parse1 (cdr body) (cons (cadr b) var-ids) (cons (caddr b) var-vals) macro-ids macro-vals) (if (memv G170 '(syntax-definition)) (parse1 (cdr body) var-ids var-vals (cons (cadr b) macro-ids) (cons (caddr b) macro-vals)) (if (memv G170 '(sequence)) (parse1 (append (cdr b) (cdr body)) var-ids var-vals macro-ids macro-vals) (begin G170 (if (valid-bound-ids? (append var-ids macro-ids)) ((lambda (new-var-names new-macro-names) ((lambda (w) ((lambda (r) (sc:build-letrec new-var-names (map (lambda (x) (chi x r w)) var-vals) (sc:build-sequence (map (lambda (x) (chi x r w)) body)))) (extend-macro-env new-macro-names (map (lambda (x) (chi-macro-def x r w)) macro-vals) (extend-var-env new-var-names r)))) (make-binding-wrap (append macro-ids var-ids) (append new-macro-names new-var-names) empty-wrap))) (map gen-var var-ids) (map gen-var macro-ids)) (sc:syntax-error (wrap source w) "invalid identifier")))))))) (car b))) (syntax-type e r empty-wrap))))) parse2) (car body)))))) parse1) (map (lambda (x) (wrap x w)) body) '() '() '() '())))) (syntax-type (lambda (e r w) (if (syntax-object? e) (syntax-type (syntax-object-expression e) r (join-wraps (syntax-object-wrap e) w)) (if (if (pair? e) (sc:identifier? (car e)) #f) ((lambda (n) ((lambda (b) ((lambda (G171) (if (memv G171 '(special)) (if (memv n '(define)) (cons 'definition (chi-definition e w)) (if (memv n '(define-syntax)) (cons 'syntax-definition (chi-syntax-definition e w)) (if (memv n '(begin)) (cons 'sequence (chi-sequence e w)) (begin n (void))))) (begin G171 b))) (binding-type b))) (lookup n (car e) r))) (id-var-name (car e) w)) '(other))))) (chi-args (lambda (args r w source source-w) (if (pair? args) (cons (chi (car args) r w) (chi-args (cdr args) r w source source-w)) (if (null? args) '() (if (syntax-object? args) (chi-args (syntax-object-expression args) r (join-wraps w (syntax-object-wrap args)) source source-w) (sc:syntax-error (wrap source source-w))))))) (chi-ref (lambda (e name binding w) ((lambda (G172) (if (memv G172 '(lexical)) (sc:build-lexical-reference name) (if (memv G172 '(global global-unbound)) (sc:build-global-reference name) (begin G172 (id-error (wrap e w)))))) (binding-type binding)))) (chi-macro (letrec ((check-macro-output (lambda (x) (if (pair? x) (begin (check-macro-output (car x)) (check-macro-output (cdr x))) ((lambda (G173) (if G173 G173 (if (vector? x) ((lambda (n) ((letrec ((G174 (lambda (i) (if (= i n) (void) (begin (check-macro-output (vector-ref x i)) (G174 (+ i 1))))))) G174) 0)) (vector-length x)) (if (symbol? x) (sc:syntax-error x "encountered raw symbol") (void))))) (syntax-object? x)))))) (lambda (p e r w k) ((lambda (mw) ((lambda (x) (check-macro-output x) (k x r mw)) (p (wrap e (join-wraps mw w))))) (new-mark-wrap))))) (chi-pair (lambda (e r w k) ((lambda (first rest) (if (id? first) ((lambda (n) ((lambda (b) ((lambda (G175) (if (memv G175 '(core)) ((binding-value b) e r w) (if (memv G175 '(macro)) (chi-macro (binding-value b) e r w k) (if (memv G175 '(special)) ((binding-value b) e r w k) (begin G175 (sc:build-application (chi-ref first n b w) (chi-args rest r w e w))))))) (binding-type b))) (lookup n first r))) (id-var-name first w)) (sc:build-application (chi first r w) (chi-args rest r w e w)))) (car e) (cdr e)))) (chi (lambda (e r w) (if (symbol? e) ((lambda (n) (chi-ref e n (lookup n e r) w)) (id-var-name e w)) (if (pair? e) (chi-pair e r w chi) (if (syntax-object? e) (chi (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e))) (if ((lambda (G176) (if G176 G176 ((lambda (G177) (if G177 G177 ((lambda (G178) (if G178 G178 (char? e))) (string? e)))) (number? e)))) (boolean? e)) (sc:build-data e) (sc:syntax-error (wrap e w)))))))) (chi-top (lambda (e r w) (if (pair? e) (chi-pair e r w chi-top) (if (syntax-object? e) (chi-top (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e))) (chi e r w))))) (wrap (lambda (x w) (if (null? w) x (if (syntax-object? x) (make-syntax-object (syntax-object-expression x) (join-wraps w (syntax-object-wrap x))) (if (null? x) x (make-syntax-object x w)))))) (unwrap (lambda (x) (if (syntax-object? x) ((lambda (e w) (if (pair? e) (cons (wrap (car e) w) (wrap (cdr e) w)) (if (vector? e) (list->vector (map (lambda (x) (wrap x w)) (vector->list e))) e))) (syntax-object-expression x) (syntax-object-wrap x)) x))) (bound-id-member? (lambda (x list) (if (not (null? list)) ((lambda (G179) (if G179 G179 (bound-id-member? x (cdr list)))) (bound-id=? x (car list))) #f))) (valid-bound-ids? (lambda (ids) (if ((letrec ((all-ids? (lambda (ids) ((lambda (G181) (if G181 G181 (if (id? (car ids)) (all-ids? (cdr ids)) #f))) (null? ids))))) all-ids?) ids) ((letrec ((unique? (lambda (ids) ((lambda (G180) (if G180 G180 (if (not (bound-id-member? (car ids) (cdr ids))) (unique? (cdr ids)) #f))) (null? ids))))) unique?) ids) #f))) (bound-id=? (lambda (i j) (if (eq? (id-sym-name i) (id-sym-name j)) ((lambda (i j) (if (eq? (car i) (car j)) (same-marks? (cdr i) (cdr j)) #f)) (id-var-name&marks i empty-wrap) (id-var-name&marks j empty-wrap)) #f))) (free-id=? (lambda (i j) (if (eq? (id-sym-name i) (id-sym-name j)) (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)) #f))) (id-var-name&marks (lambda (id w) (if (null? w) (if (symbol? id) (list id) (id-var-name&marks (syntax-object-expression id) (syntax-object-wrap id))) ((lambda (n&m first) (if (pair? first) ((lambda (n) ((letrec ((search (lambda (rib) (if (null? rib) n&m (if (if (eq? (caar rib) n) (same-marks? (cdr n&m) (cddar rib)) #f) (cdar rib) (search (cdr rib))))))) search) first)) (car n&m)) (cons (car n&m) (if ((lambda (G182) (if G182 G182 (not (eqv? first (cadr n&m))))) (null? (cdr n&m))) (cons first (cdr n&m)) (cddr n&m))))) (id-var-name&marks id (cdr w)) (car w))))) (id-var-name (lambda (id w) (if (null? w) (if (symbol? id) id (id-var-name (syntax-object-expression id) (syntax-object-wrap id))) (if (pair? (car w)) (car (id-var-name&marks id w)) (id-var-name id (cdr w)))))) (same-marks? (lambda (x y) (if (null? x) (null? y) (if (not (null? y)) (if (eqv? (car x) (car y)) (same-marks? (cdr x) (cdr y)) #f) #f)))) (join-wraps2 (lambda (w1 w2) ((lambda (x w1) (if (null? w1) (if (if (not (pair? x)) (eqv? x (car w2)) #f) (cdr w2) (cons x w2)) (cons x (join-wraps2 w1 w2)))) (car w1) (cdr w1)))) (join-wraps1 (lambda (w1 w2) (if (null? w1) w2 (cons (car w1) (join-wraps1 (cdr w1) w2))))) (join-wraps (lambda (w1 w2) (if (null? w2) w1 (if (null? w1) w2 (if (pair? (car w2)) (join-wraps1 w1 w2) (join-wraps2 w1 w2)))))) (make-wrap-rib (lambda (ids new-names w) (if (null? ids) '() (cons ((lambda (n&m) (cons (car n&m) (cons (car new-names) (cdr n&m)))) (id-var-name&marks (car ids) w)) (make-wrap-rib (cdr ids) (cdr new-names) w))))) (make-binding-wrap (lambda (ids new-names w) (if (null? ids) w (cons (make-wrap-rib ids new-names w) w)))) (new-mark-wrap (lambda () (set! current-mark (+ current-mark 1)) (list current-mark))) (current-mark 0) (top-wrap '(top)) (empty-wrap '()) (id-sym-name (lambda (x) (if (symbol? x) x (syntax-object-expression x)))) (id? (lambda (x) ((lambda (G183) (if G183 G183 (if (syntax-object? x) (symbol? (syntax-object-expression x)) #f))) (symbol? x)))) (global-extend (lambda (type sym val) (extend-global-env sym (cons type val)))) (lookup (lambda (name id r) (if (eq? name (id-sym-name id)) (global-lookup name) ((letrec ((search (lambda (r name) (if (null? r) '(displaced-lexical) (if (pair? (car r)) (if (eq? (caar r) name) (cdar r) (search (cdr r) name)) (if (eq? (car r) name) '(lexical) (search (cdr r) name))))))) search) r name)))) (extend-syntax-env (lambda (vars vals r) (if (null? vars) r (cons (cons (car vars) (cons 'syntax (car vals))) (extend-syntax-env (cdr vars) (cdr vals) r))))) (extend-var-env append) (extend-macro-env (lambda (vars vals r) (if (null? vars) r (cons (cons (car vars) (cons 'macro (car vals))) (extend-macro-env (cdr vars) (cdr vals) r))))) (null-env '()) (global-lookup (lambda (sym) ((lambda (G184) (if G184 G184 '(global-unbound))) (sc:get-global-definition-hook sym)))) (extend-global-env (lambda (sym binding) (sc:put-global-definition-hook sym binding))) (binding-value cdr) (binding-type car) (arg-check (lambda (pred? x who) (if (not (pred? x)) (sc:error-hook who "invalid argument" x) (void)))) (id-error (lambda (x) (sc:syntax-error x "invalid context for identifier"))) (scope-error (lambda (id) (sc:syntax-error id "invalid context for bound identifier"))) (syntax-object-wrap (lambda (x) (vector-ref x 2))) (syntax-object-expression (lambda (x) (vector-ref x 1))) (make-syntax-object (lambda (expression wrap) (vector 'syntax-object expression wrap))) (syntax-object? (lambda (x) (if (vector? x) (if (= (vector-length x) 3) (eq? (vector-ref x 0) 'syntax-object) #f) #f)))) (global-extend 'core 'letrec-syntax chi-local-syntax) (global-extend 'core 'let-syntax chi-local-syntax) (global-extend 'core 'quote (lambda (e r w) ((lambda (G136) ((lambda (G135) (if (not (eq? G135 'no)) ((lambda (__ _e) (sc:build-data (strip _e))) (car G135) (cadr G135)) ((lambda (G138) ((lambda (G137) (if (not (eq? G137 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G137)) (sc:syntax-error G138))) (sc:syntax-dispatch G138 '(any) (vector)))) G136))) (sc:syntax-dispatch G136 '(pair (any) pair (any) atom) (vector)))) e))) (global-extend 'core 'syntax (lambda (e r w) ((lambda (G132) ((lambda (G131) (if (not (eq? G131 'no)) ((lambda (__ _x) (chi-syntax e _x r w)) (car G131) (cadr G131)) ((lambda (G134) ((lambda (G133) (if (not (eq? G133 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G133)) (sc:syntax-error G134))) (sc:syntax-dispatch G134 '(any) (vector)))) G132))) (sc:syntax-dispatch G132 '(pair (any) pair (any) atom) (vector)))) e))) (global-extend 'core 'syntax-lambda (lambda (e r w) ((lambda (G127) ((lambda (G128) ((lambda (G126) (if (not (eq? G126 'no)) ((lambda (__ _id _level _exp) (if (if (valid-bound-ids? _id) (map (lambda (x) (if (integer? x) (if (exact? x) (not (negative? x)) #f) #f)) (map unwrap _level)) #f) ((lambda (new-vars) (sc:build-lambda new-vars (chi _exp (extend-syntax-env new-vars (map unwrap _level) r) (make-binding-wrap _id new-vars w)))) (map gen-var _id)) (G128))) (car G126) (cadr G126) (caddr G126) (cadddr G126)) (G128))) (sc:syntax-dispatch G127 '(pair (any) pair (each pair (any) pair (any) atom) pair (any) atom) (vector)))) (lambda () ((lambda (G130) ((lambda (G129) (if (not (eq? G129 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G129)) (sc:syntax-error G130))) (sc:syntax-dispatch G130 '(any) (vector)))) G127)))) e))) (global-extend 'core 'lambda (lambda (e r w) ((lambda (G121) ((lambda (G120) (if (not (eq? G120 'no)) ((lambda (__ _id _e1 _e2) (if (not (valid-bound-ids? _id)) (sc:syntax-error (wrap e w) "invalid parameter list") ((lambda (new-vars) (sc:build-lambda new-vars (chi-body (cons _e1 _e2) e (extend-var-env new-vars r) (make-binding-wrap _id new-vars w)))) (map gen-var _id)))) (car G120) (cadr G120) (caddr G120) (cadddr G120)) ((lambda (G123) ((lambda (G122) (if (not (eq? G122 'no)) ((lambda (__ _ids _e1 _e2) ((lambda (old-ids) (if (not (valid-bound-ids? (lambda-var-list _ids))) (sc:syntax-error (wrap e w) "invalid parameter list") ((lambda (new-vars) (sc:build-improper-lambda (reverse (cdr new-vars)) (car new-vars) (chi-body (cons _e1 _e2) e (extend-var-env new-vars r) (make-binding-wrap old-ids new-vars w)))) (map gen-var old-ids)))) (lambda-var-list _ids))) (car G122) (cadr G122) (caddr G122) (cadddr G122)) ((lambda (G125) ((lambda (G124) (if (not (eq? G124 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G124)) (sc:syntax-error G125))) (sc:syntax-dispatch G125 '(any) (vector)))) G123))) (sc:syntax-dispatch G123 '(pair (any) pair (any) pair (any) each any) (vector)))) G121))) (sc:syntax-dispatch G121 '(pair (any) pair (each any) pair (any) each any) (vector)))) e))) (global-extend 'core 'letrec (lambda (e r w) ((lambda (G116) ((lambda (G117) ((lambda (G115) (if (not (eq? G115 'no)) (apply (lambda (__ _id _val _e1 _e2) (if (valid-bound-ids? _id) ((lambda (new-vars) ((lambda (w r) (sc:build-letrec new-vars (map (lambda (x) (chi x r w)) _val) (chi-body (cons _e1 _e2) e r w))) (make-binding-wrap _id new-vars w) (extend-var-env new-vars r))) (map gen-var _id)) (G117))) G115) (G117))) (sc:syntax-dispatch G116 '(pair (any) pair (each pair (any) pair (any) atom) pair (any) each any) (vector)))) (lambda () ((lambda (G119) ((lambda (G118) (if (not (eq? G118 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G118)) (sc:syntax-error G119))) (sc:syntax-dispatch G119 '(any) (vector)))) G116)))) e))) (global-extend 'core 'if (lambda (e r w) ((lambda (G110) ((lambda (G109) (if (not (eq? G109 'no)) ((lambda (__ _test _then) (sc:build-conditional (chi _test r w) (chi _then r w) (chi (list '#(syntax-object void (top))) r empty-wrap))) (car G109) (cadr G109) (caddr G109)) ((lambda (G112) ((lambda (G111) (if (not (eq? G111 'no)) ((lambda (__ _test _then _else) (sc:build-conditional (chi _test r w) (chi _then r w) (chi _else r w))) (car G111) (cadr G111) (caddr G111) (cadddr G111)) ((lambda (G114) ((lambda (G113) (if (not (eq? G113 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G113)) (sc:syntax-error G114))) (sc:syntax-dispatch G114 '(any) (vector)))) G112))) (sc:syntax-dispatch G112 '(pair (any) pair (any) pair (any) pair (any) atom) (vector)))) G110))) (sc:syntax-dispatch G110 '(pair (any) pair (any) pair (any) atom) (vector)))) e))) (global-extend 'core 'set! (lambda (e r w) ((lambda (G104) ((lambda (G105) ((lambda (G103) (if (not (eq? G103 'no)) ((lambda (__ _id _val) (if (id? _id) ((lambda (val n) ((lambda (G108) (if (memv G108 '(lexical)) (sc:build-lexical-assignment n val) (if (memv G108 '(global global-unbound)) (sc:build-global-assignment n val) (begin G108 (id-error (wrap _id w)))))) (binding-type (lookup n _id r)))) (chi _val r w) (id-var-name _id w)) (G105))) (car G103) (cadr G103) (caddr G103)) (G105))) (sc:syntax-dispatch G104 '(pair (any) pair (any) pair (any) atom) (vector)))) (lambda () ((lambda (G107) ((lambda (G106) (if (not (eq? G106 'no)) ((lambda (__) (sc:syntax-error (wrap e w))) (car G106)) (sc:syntax-error G107))) (sc:syntax-dispatch G107 '(any) (vector)))) G104)))) e))) (global-extend 'special 'begin (lambda (e r w k) ((lambda (body) (if (null? body) (if (eqv? k chi-top) (chi (list '#(syntax-object void (top))) r empty-wrap) (sc:syntax-error (wrap e w) "no expressions in body of")) (sc:build-sequence ((letrec ((dobody (lambda (body) (if (null? body) '() ((lambda (first) (cons first (dobody (cdr body)))) (k (car body) r empty-wrap)))))) dobody) body)))) (chi-sequence e w)))) (global-extend 'special 'define (lambda (e r w k) (if (eqv? k chi-top) ((lambda (n&v) ((lambda (n) (global-extend 'global n '()) (sc:build-global-definition n (chi (cadr n&v) r empty-wrap))) (id-var-name (car n&v) empty-wrap))) (chi-definition e w)) (sc:syntax-error (wrap e w) "invalid context for definition")))) (global-extend 'special 'define-syntax (lambda (e r w k) (if (eqv? k chi-top) ((lambda (n&v) (global-extend 'macro (id-var-name (car n&v) empty-wrap) (chi-macro-def (cadr n&v) r empty-wrap)) (chi (list '#(syntax-object void (top))) r empty-wrap)) (chi-syntax-definition e w)) (sc:syntax-error (wrap e w) "invalid context for definition")))) (set! sc:expand-syntax (lambda (x) (chi-top x null-env top-wrap))) (set! sc:implicit-identifier (lambda (id sym) (arg-check id? id 'sc:implicit-identifier) (arg-check symbol? sym 'sc:implicit-identifier) (if (syntax-object? id) (wrap sym (syntax-object-wrap id)) sym))) (set! sc:syntax-object->datum (lambda (x) (strip x))) (set! sc:generate-temporaries (lambda (ls) (arg-check list? ls 'sc:generate-temporaries) (map (lambda (x) (wrap (gensym) top-wrap)) ls))) (set! sc:free-identifier=? (lambda (x y) (arg-check id? x 'sc:free-identifier=?) (arg-check id? y 'sc:free-identifier=?) (free-id=? x y))) (set! sc:bound-identifier=? (lambda (x y) (arg-check id? x 'sc:bound-identifier=?) (arg-check id? y 'sc:bound-identifier=?) (bound-id=? x y))) (set! sc:identifier? (lambda (x) (id? x))) (set! sc:syntax-error (lambda (object . messages) (for-each (lambda (x) (arg-check string? x 'sc:syntax-error)) messages) ((lambda (message) (sc:error-hook 'sc:expand-syntax message (strip object))) (if (null? messages) "invalid syntax" (apply string-append messages))))) (set! sc:install-global-transformer (lambda (sym p) (global-extend 'macro sym p))) ((lambda () (letrec ((match (lambda (e p k w r) (if (eq? r 'no) r ((lambda (G100) (if (memv G100 '(any)) (cons (wrap e w) r) (if (memv G100 '(free-id)) (if (if (sc:identifier? e) (free-id=? (wrap e w) (vector-ref k (cdr p))) #f) r 'no) (begin G100 (if (syntax-object? e) (match* (syntax-object-expression e) p k (join-wraps w (syntax-object-wrap e)) r) (match* e p k w r)))))) (car p))))) (match* (lambda (e p k w r) ((lambda (G101) (if (memv G101 '(pair)) (if (pair? e) (match (car e) (cadr p) k w (match (cdr e) (cddr p) k w r)) 'no) (if (memv G101 '(each)) (if (eq? (cadr p) 'any) ((lambda (l) (if (eq? l 'no) l (cons l r))) (match-each-any e w)) (if (null? e) (match-empty (cdr p) r) ((lambda (l) (if (eq? l 'no) l ((letrec ((collect (lambda (l) (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))) collect) l))) (match-each e (cdr p) k w)))) (if (memv G101 '(atom)) (if (equal? (cdr p) e) r 'no) (if (memv G101 '(vector)) (if (vector? e) (match (vector->list e) (cdr p) k w r) 'no) (begin G101 (void))))))) (car p)))) (match-empty (lambda (p r) ((lambda (G102) (if (memv G102 '(any)) (cons '() r) (if (memv G102 '(each)) (match-empty (cdr p) r) (if (memv G102 '(pair)) (match-empty (cadr p) (match-empty (cddr p) r)) (if (memv G102 '(free-id atom)) r (if (memv G102 '(vector)) (match-empty (cdr p) r) (begin G102 (void)))))))) (car p)))) (match-each-any (lambda (e w) (if (pair? e) ((lambda (l) (if (eq? l 'no) l (cons (wrap (car e) w) l))) (match-each-any (cdr e) w)) (if (null? e) '() (if (syntax-object? e) (match-each-any (syntax-object-expression e) (join-wraps w (syntax-object-wrap e))) 'no))))) (match-each (lambda (e p k w) (if (pair? e) ((lambda (first) (if (eq? first 'no) first ((lambda (rest) (if (eq? rest 'no) rest (cons first rest))) (match-each (cdr e) p k w)))) (match (car e) p k w '())) (if (null? e) '() (if (syntax-object? e) (match-each (syntax-object-expression e) p k (join-wraps w (syntax-object-wrap e))) 'no)))))) (set! sc:syntax-dispatch (lambda (expression pattern keys) (match expression pattern keys empty-wrap '()))))))))) (sc:install-global-transformer 'let (lambda (x) ((lambda (G95) ((lambda (G96) ((lambda (G94) (if (not (eq? G94 'no)) (apply (lambda (__ _x _v _e1 _e2) (if (sc:andmap sc:identifier? _x) (cons (cons '#(syntax-object lambda (top)) (cons _x (cons _e1 _e2))) _v) (G96))) G94) (G96))) (sc:syntax-dispatch G95 '(pair (any) pair (each pair (any) pair (any) atom) pair (any) each any) (vector)))) (lambda () ((lambda (G98) ((lambda (G99) ((lambda (G97) (if (not (eq? G97 'no)) (apply (lambda (__ _f _x _v _e1 _e2) (if (sc:andmap sc:identifier? (cons _f _x)) (cons (list '#(syntax-object letrec (top)) (list (list _f (cons '#(syntax-object lambda (top)) (cons _x (cons _e1 _e2))))) _f) _v) (G99))) G97) (G99))) (sc:syntax-dispatch G98 '(pair (any) pair (any) pair (each pair (any) pair (any) atom) pair (any) each any) (vector)))) (lambda () (sc:syntax-error G98)))) G95)))) x))) (sc:install-global-transformer 'syntax-case ((lambda () (letrec ((sc:build-dispatch-call (lambda (args body val) ((lambda (G46) ((lambda (G45) (if (not (eq? G45 'no)) body ((lambda (G48) ((lambda (G47) (if (not (eq? G47 'no)) ((lambda (_arg1) ((lambda (G66) ((lambda (G65) (if (not (eq? G65 'no)) ((lambda (_body _val) (list (list '#(syntax-object syntax-lambda (top)) (list _arg1) _body) (list '#(syntax-object car (top)) _val))) (car G65) (cadr G65)) (sc:syntax-error G66))) (sc:syntax-dispatch G66 '(pair (any) pair (any) atom) (vector)))) (list body val))) (car G47)) ((lambda (G50) ((lambda (G49) (if (not (eq? G49 'no)) ((lambda (_arg1 _arg2) ((lambda (G64) ((lambda (G63) (if (not (eq? G63 'no)) ((lambda (_body _val) (list (list '#(syntax-object syntax-lambda (top)) (list _arg1 _arg2) _body) (list '#(syntax-object car (top)) _val) (list '#(syntax-object cadr (top)) _val))) (car G63) (cadr G63)) (sc:syntax-error G64))) (sc:syntax-dispatch G64 '(pair (any) pair (any) atom) (vector)))) (list body val))) (car G49) (cadr G49)) ((lambda (G52) ((lambda (G51) (if (not (eq? G51 'no)) ((lambda (_arg1 _arg2 _arg3) ((lambda (G62) ((lambda (G61) (if (not (eq? G61 'no)) ((lambda (_body _val) (list (list '#(syntax-object syntax-lambda (top)) (list _arg1 _arg2 _arg3) _body) (list '#(syntax-object car (top)) _val) (list '#(syntax-object cadr (top)) _val) (list '#(syntax-object caddr (top)) _val))) (car G61) (cadr G61)) (sc:syntax-error G62))) (sc:syntax-dispatch G62 '(pair (any) pair (any) atom) (vector)))) (list body val))) (car G51) (cadr G51) (caddr G51)) ((lambda (G54) ((lambda (G53) (if (not (eq? G53 'no)) ((lambda (_arg1 _arg2 _arg3 _arg4) ((lambda (G60) ((lambda (G59) (if (not (eq? G59 'no)) ((lambda (_body _val) (list (list '#(syntax-object syntax-lambda (top)) (list _arg1 _arg2 _arg3 _arg4) _body) (list '#(syntax-object car (top)) _val) (list '#(syntax-object cadr (top)) _val) (list '#(syntax-object caddr (top)) _val) (list '#(syntax-object cadddr (top)) _val))) (car G59) (cadr G59)) (sc:syntax-error G60))) (sc:syntax-dispatch G60 '(pair (any) pair (any) atom) (vector)))) (list body val))) (car G53) (cadr G53) (caddr G53) (cadddr G53)) ((lambda (G56) ((lambda (G55) (if (not (eq? G55 'no)) ((lambda (_arg) ((lambda (G58) ((lambda (G57) (if (not (eq? G57 'no)) ((lambda (_body _val) (list '#(syntax-object apply (top)) (list '#(syntax-object syntax-lambda (top)) _arg _body) _val)) (car G57) (cadr G57)) (sc:syntax-error G58))) (sc:syntax-dispatch G58 '(pair (any) pair (any) atom) (vector)))) (list body val))) (car G55)) (sc:syntax-error G56))) (sc:syntax-dispatch G56 '(each any) (vector)))) G54))) (sc:syntax-dispatch G54 '(pair (any) pair (any) pair (any) pair (any) atom) (vector)))) G52))) (sc:syntax-dispatch G52 '(pair (any) pair (any) pair (any) atom) (vector)))) G50))) (sc:syntax-dispatch G50 '(pair (any) pair (any) atom) (vector)))) G48))) (sc:syntax-dispatch G48 '(pair (any) atom) (vector)))) G46))) (sc:syntax-dispatch G46 '(atom) (vector)))) args))) (extract-bound-syntax-ids (lambda (pattern keys) ((letrec ((gen (lambda (p n ids) (if (sc:identifier? p) (if (key? p keys) ids (cons (list p n) ids)) ((lambda (G68) ((lambda (G69) ((lambda (G67) (if (not (eq? G67 'no)) ((lambda (_x _dots) (if (ellipsis? _dots) (gen _x (+ n 1) ids) (G69))) (car G67) (cadr G67)) (G69))) (sc:syntax-dispatch G68 '(pair (any) pair (any) atom) (vector)))) (lambda () ((lambda (G71) ((lambda (G70) (if (not (eq? G70 'no)) ((lambda (_x _y) (gen _x n (gen _y n ids))) (car G70) (cadr G70)) ((lambda (G73) ((lambda (G72) (if (not (eq? G72 'no)) ((lambda (_x) (gen _x n ids)) (car G72)) ((lambda (G75) ((lambda (G74) (if (not (eq? G74 'no)) ((lambda (_x) ids) (car G74)) (sc:syntax-error G75))) (sc:syntax-dispatch G75 '(any) (vector)))) G73))) (sc:syntax-dispatch G73 '(vector each any) (vector)))) G71))) (sc:syntax-dispatch G71 '(pair (any) any) (vector)))) G68)))) p))))) gen) pattern 0 '()))) (valid-syntax-pattern? (lambda (pattern keys) (letrec ((check? (lambda (p ids) (if (sc:identifier? p) (if (eq? ids 'no) ids (if (key? p keys) ids (if (if (not (ellipsis? p)) (not (memid p ids)) #f) (cons p ids) 'no))) ((lambda (G77) ((lambda (G78) ((lambda (G76) (if (not (eq? G76 'no)) ((lambda (_x _dots) (if (ellipsis? _dots) (check? _x ids) (G78))) (car G76) (cadr G76)) (G78))) (sc:syntax-dispatch G77 '(pair (any) pair (any) atom) (vector)))) (lambda () ((lambda (G80) ((lambda (G79) (if (not (eq? G79 'no)) ((lambda (_x _y) (check? _x (check? _y ids))) (car G79) (cadr G79)) ((lambda (G82) ((lambda (G81) (if (not (eq? G81 'no)) ((lambda (_x) (check? _x ids)) (car G81)) ((lambda (G84) ((lambda (G83) (if (not (eq? G83 'no)) ((lambda (_x) ids) (car G83)) (sc:syntax-error G84))) (sc:syntax-dispatch G84 '(any) (vector)))) G82))) (sc:syntax-dispatch G82 '(vector each any) (vector)))) G80))) (sc:syntax-dispatch G80 '(pair (any) any) (vector)))) G77)))) p))))) (not (eq? (check? pattern '()) 'no))))) (valid-keyword? (lambda (k) (if (sc:identifier? k) (not (sc:free-identifier=? k '...)) #f))) (convert-sc:syntax-dispatch-pattern (lambda (pattern keys) ((letrec ((gen (lambda (p) (if (sc:identifier? p) (if (key? p keys) (cons '#(syntax-object free-id (top)) (key-index p keys)) (list '#(syntax-object any (top)))) ((lambda (G86) ((lambda (G87) ((lambda (G85) (if (not (eq? G85 'no)) ((lambda (_x _dots) (if (ellipsis? _dots) (cons '#(syntax-object each (top)) (gen _x)) (G87))) (car G85) (cadr G85)) (G87))) (sc:syntax-dispatch G86 '(pair (any) pair (any) atom) (vector)))) (lambda () ((lambda (G89) ((lambda (G88) (if (not (eq? G88 'no)) ((lambda (_x _y) (cons '#(syntax-object pair (top)) (cons (gen _x) (gen _y)))) (car G88) (cadr G88)) ((lambda (G91) ((lambda (G90) (if (not (eq? G90 'no)) ((lambda (_x) (cons '#(syntax-object vector (top)) (gen _x))) (car G90)) ((lambda (G93) ((lambda (G92) (if (not (eq? G92 'no)) ((lambda (_x) (cons '#(syntax-object atom (top)) p)) (car G92)) (sc:syntax-error G93))) (sc:syntax-dispatch G93 '(any) (vector)))) G91))) (sc:syntax-dispatch G91 '(vector each any) (vector)))) G89))) (sc:syntax-dispatch G89 '(pair (any) any) (vector)))) G86)))) p))))) gen) pattern))) (key-index (lambda (p keys) (- (length keys) (length (memid p keys))))) (key? (lambda (p keys) (if (sc:identifier? p) (memid p keys) #f))) (memid (lambda (i ids) (if (not (null? ids)) (if (sc:bound-identifier=? i (car ids)) ids (memid i (cdr ids))) #f))) (ellipsis? (lambda (x) (if (sc:identifier? x) (sc:free-identifier=? x '...) #f)))) (lambda (x) ((lambda (G30) ((lambda (G31) ((lambda (G29) (if (not (eq? G29 'no)) ((lambda (__ _val _key) (if (sc:andmap valid-keyword? _key) (list '#(syntax-object sc:syntax-error (top)) _val) (G31))) (car G29) (cadr G29) (caddr G29)) (G31))) (sc:syntax-dispatch G30 '(pair (any) pair (any) pair (each any) atom) (vector)))) (lambda () ((lambda (G33) ((lambda (G34) ((lambda (G32) (if (not (eq? G32 'no)) (apply (lambda (__ _val _key _pat _exp) (if (if (sc:identifier? _pat) (if (sc:andmap valid-keyword? _key) (sc:andmap (lambda (x) (not (sc:free-identifier=? _pat x))) (cons '... _key)) #f) #f) (list (list '#(syntax-object syntax-lambda (top)) (list (list _pat 0)) _exp) _val) (G34))) G32) (G34))) (sc:syntax-dispatch G33 '(pair (any) pair (any) pair (each any) pair (pair (any) pair (any) atom) atom) (vector)))) (lambda () ((lambda (G36) ((lambda (G37) ((lambda (G35) (if (not (eq? G35 'no)) (apply (lambda (__ _val _key _pat _exp _e1 _e2 _e3) (if (if (sc:andmap valid-keyword? _key) (valid-syntax-pattern? _pat _key) #f) ((lambda (G44) ((lambda (G43) (if (not (eq? G43 'no)) ((lambda (_pattern _y _call) (list '#(syntax-object let (top)) (list (list '#(syntax-object x (top)) _val)) (list '#(syntax-object let (top)) (list (list _y (list '#(syntax-object sc:syntax-dispatch (top)) '#(syntax-object x (top)) (list '#(syntax-object quote (top)) _pattern) (list '#(syntax-object syntax (top)) (list->vector _key))))) (list '#(syntax-object if (top)) (list '#(syntax-object not (top)) (list '#(syntax-object eq? (top)) _y (list '#(syntax-object quote (top)) '#(syntax-object no (top))))) _call (cons '#(syntax-object syntax-case (top)) (cons '#(syntax-object x (top)) (cons _key (map (lambda (__e1 __e2 __e3) (cons __e1 (cons __e2 __e3))) _e1 _e2 _e3)))))))) (car G43) (cadr G43) (caddr G43)) (sc:syntax-error G44))) (sc:syntax-dispatch G44 '(pair (any) pair (any) pair (any) atom) (vector)))) (list (convert-sc:syntax-dispatch-pattern _pat _key) '#(syntax-object y (top)) (sc:build-dispatch-call (extract-bound-syntax-ids _pat _key) _exp '#(syntax-object y (top))))) (G37))) G35) (G37))) (sc:syntax-dispatch G36 '(pair (any) pair (any) pair (each any) pair (pair (any) pair (any) atom) each pair (any) pair (any) each any) (vector)))) (lambda () ((lambda (G39) ((lambda (G40) ((lambda (G38) (if (not (eq? G38 'no)) (apply (lambda (__ _val _key _pat _fender _exp _e1 _e2 _e3) (if (if (sc:andmap valid-keyword? _key) (valid-syntax-pattern? _pat _key) #f) ((lambda (G42) ((lambda (G41) (if (not (eq? G41 'no)) ((lambda (_pattern _y _dorest _call) (list '#(syntax-object let (top)) (list (list '#(syntax-object x (top)) _val)) (list '#(syntax-object let (top)) (list (list _dorest (list '#(syntax-object lambda (top)) '() (cons '#(syntax-object syntax-case (top)) (cons '#(syntax-object x (top)) (cons _key (map (lambda (__e1 __e2 __e3) (cons __e1 (cons __e2 __e3))) _e1 _e2 _e3))))))) (list '#(syntax-object let (top)) (list (list _y (list '#(syntax-object sc:syntax-dispatch (top)) '#(syntax-object x (top)) (list '#(syntax-object quote (top)) _pattern) (list '#(syntax-object syntax (top)) (list->vector _key))))) (list '#(syntax-object if (top)) (list '#(syntax-object not (top)) (list '#(syntax-object eq? (top)) _y (list '#(syntax-object quote (top)) '#(syntax-object no (top))))) _call (list _dorest)))))) (car G41) (cadr G41) (caddr G41) (cadddr G41)) (sc:syntax-error G42))) (sc:syntax-dispatch G42 '(pair (any) pair (any) pair (any) pair (any) atom) (vector)))) (list (convert-sc:syntax-dispatch-pattern _pat _key) '#(syntax-object y (top)) '#(syntax-object dorest (top)) (sc:build-dispatch-call (extract-bound-syntax-ids _pat _key) (list '#(syntax-object if (top)) _fender _exp (list '#(syntax-object dorest (top)))) '#(syntax-object y (top))))) (G40))) G38) (G40))) (sc:syntax-dispatch G39 '(pair (any) pair (any) pair (each any) pair (pair (any) pair (any) pair (any) atom) each pair (any) pair (any) each any) (vector)))) (lambda () (sc:syntax-error G39)))) G36)))) G33)))) G30)))) x)))))))