gambit-4.9.3/lib/psyntax69c.ss

268 ;;; whether local or global, results in a call to eval.  If, however,
352 ;;; and letrec-syntax do not create local contours, as do let and letrec.
364 ;;; no global or lexical binding, it treats it as a global-variable
381 ;;; only in code produced by the macro.  That is, a binding for a
435 ;;; it out to top level, including all macros that are local to a "body".
456 ;;; All identifiers defined within a local module are folded into the
527                      (lambda (x update)
528                        (vector-set! x index update)))
558 ; top-level-eval-hook is used to create "permanent" code (e.g., local
560 (define local-eval-hook
594 (define read-only-binding?
598 ; should return #f if symbol has no binding for token
599 (define get-import-binding
603 ; remove binding if x is false
604 (define put-import-binding
730  ; each type is either global (exported) or local (not exported)
805 ;;; <environment>              ::= ((<label> . <binding>)*)
809 ;;; <binding> ::= <procedure>                     macro keyword
817 ;;;               (local-syntax . <boolean>)      let-syntax (#f)/letrec-syntax (#t) keyword
841 ;;; any identifier for which no top-level syntax definition or local
842 ;;; binding of any kind has been seen is assumed to be a global
853 (define sanitize-binding
856       ((procedure? b) (make-binding 'macro b))
857       ((binding? b)
858        (and (case (binding-type b)
859               ((core macro macro! deferred) (and (procedure? (binding-value b))))
860               (($module) (interface? (binding-value b)))
861               ((lexical) (lexical-var? (binding-value b)))
862              ((global meta-variable) (symbol? (binding-value b)))
863               ((syntax) (let ((x (binding-value b)))
868 …   ((begin define define-syntax set! $module-key $import eval-when meta) (null? (binding-value b)))
869               ((local-syntax) (boolean? (binding-value b)))
870               ((displaced-lexical) (eq? (binding-value b) #f))
875 (define-syntax make-binding
879 (define binding-type car)
880 (define binding-value cdr)
881 (define set-binding-type! set-car!)
882 (define set-binding-value! set-cdr!)
883 (define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
888   (lambda (label binding r)
889     (cons (cons label binding) r)))
899   ; variant of extend-env* that forms "lexical" binding
904           (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
910            (eq? (binding-type b) 'displaced-lexical)))))
922   ; anyway because a temporary binding may have been established by
928        (or (get-global-definition-hook x) (make-binding 'global x)))
929       (else (make-binding 'displaced-lexical #f)))))
933     (define whack-binding!
935         (set-binding-type! b (binding-type *b))
936         (set-binding-value! b (binding-value *b))))
938       (when (eq? (binding-type b) 'deferred)
939         (whack-binding! b (make-transformer-binding ((binding-value b)))))
942 (define make-transformer-binding
944     (or (sanitize-binding b)
950         (make-binding 'deferred (lambda () (eval x)))
951         (make-transformer-binding (eval x)))))
955     (put-cte-hook sym (make-binding type val))))
1114 (define lookup-import-binding-name
1116     (let ((new (get-import-binding sym token)))
1126 (define store-import-binding
1134     (define weed ; remove existing binding for id, if any
1146           (let ((x (weed marks (get-import-binding sym token))))
1147             (put-import-binding sym token
1155 ;;; make-binding-wrap creates vector-based ribcages
1156 (define make-binding-wrap
1261   (define new-binding
1268           (store-import-binding id token)
1276           ((lookup-import-binding-name sym token marks) =>
1279                  (if (read-only-binding? id)
1280                      (new-binding sym marks token)
1283           (else (new-binding sym marks token))))))
1289           ((lookup-import-binding-name sym token marks) =>
1293            (let-values (((sym id) (new-binding sym (wrap-marks top-wrap) token)))
1330                ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
1520 ;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
1521 ;;;    local-syntax-form      rec?          syntax definition
1542               (type (binding-type b)))
1544 …      ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w ae rib) r empty-wrap #f rib))
1545            (else (values type (binding-value b) e w ae)))))
1551                     (type (binding-type b)))
1553                  ((lexical) (values 'lexical-call (binding-value b) e w ae))
1555                   (syntax-type (chi-macro (binding-value b) e r w ae rib)
1557                  ((core) (values type (binding-value b) e w ae))
1567                  ((local-syntax)
1568                   (values 'local-syntax-form (binding-value b) e w ae))
1610         ((local-syntax-form)
1611          (let-values (((forms r mr w ae) (chi-local-syntax value e r r w ae)))
1616            (let ((ctem (update-mode-set when-list ctem))
1617                  (rtem (update-mode-set when-list rtem)))
1634                  (when (read-only-binding? valsym)
1655                  (when (read-only-binding? valsym)
1664                                (build-data no-source (make-binding 'meta-variable valsym))
1673                                (build-data no-source (make-binding 'global valsym))
1696                (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
1697                  (case (binding-type binding)
1698 …        (($module) (do-top-import only? top-ribcage mid (interface-token (binding-value binding))))
1713                  (when (read-only-binding? valsym)
1720                        (build-data no-source (make-binding 'do-alias #f))
1765 (define-structure (module-binding type id label imps val exported))
1766 (define create-module-binding
1768     (make-module-binding type id label imps val #f)))
1784              ; local vars, or local compile-time entities
1785              ; dts: type (local/global)
1794                          ; expansion of des use local versions of modules and macros
1796                          ; local code can use exported compile-time values (modules, macros,
1805                                               (make-binding '$module
1814                                       (when (read-only-binding? valsym)
1827                       (let ((t (module-binding-type b)))
1828                         (case (module-binding-type b)
1830                            (let ((label (get-indirect-label (module-binding-label b))))
1831                              (if (module-binding-exported b)
1832                                  (let ((var (module-binding-id b)))
1834                                      (cons (module-binding-val b) des)))
1835                                  (let ((var (gen-var (module-binding-id b))))
1838                                      (extend-env label (make-binding 'lexical var) r)
1839                                      (cons 'local dts) (cons var dvs)
1840                                      (cons (module-binding-val b) des))))))
1842 …                      (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))))
1851                         (if (free-id=? (module-binding-id b) id)
1852                             (if (module-binding-exported b)
1854                                 (let* ((t (module-binding-type b))
1855                                        (label (module-binding-label b))
1856                                        (imps (module-binding-imps b))
1858                                   (set-module-binding-exported! b #t)
1865                                      (let ((b (module-binding-val b)))
1868                                            (let ((sym (binding-value b)))
1878                                            (let ((local-label (get-indirect-label label)))
1882 …                                        (lambda () (put-cte-hook sym (car (module-binding-val b))))
1883 …                               (lambda () (build-cte-install sym (cdr (module-binding-val b)) #f)))
1887                                            (exports (module-binding-val b)))
1892 …                          (let ((x (make-binding '$module (make-resolved-interface2 exports sym))))
1904 …                                (syntax-error (module-binding-id b) "unexported target of alias")))
1906 …                        (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
1929 …             (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
1984                (if (lookup-import-binding-name (id-sym-name id) token
2021     (define update-imp-exports
2025                  (let ((id (module-binding-id b)))
2028                        (create-module-binding
2029                          (module-binding-type b)
2031                          (module-binding-label b)
2032                          (append (get-implicit-exports id) (module-binding-imps b))
2033                          (module-binding-val b)))))
2051                                (b (make-binding 'meta-variable sym)))
2062 …                             (cons (create-module-binding 'ctdefine-form id label imps b) bindings)
2068                           (cons (create-module-binding type id label
2085                          (cons (create-module-binding type id label imps (cons b exp))
2103                            (let ((l (get-indirect-label label)) (b (make-binding '$module iface)))
2108                                (cons (create-module-binding type id label imps *exports) bindings)
2114                     (let ((binding (lookup mlabel r)))
2115                       (case (binding-type binding)
2117                          (let ((iface (binding-value binding)))
2122                              (update-imp-exports bindings (vector->list (interface-exports iface)))
2135                       (cons (create-module-binding type new-id label imps #f)
2160                 ((local-syntax-form)
2161                  (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2197         (make-binding 'do-import (cons import-only? token)))
2200 (define update-mode-set
2314       ((local-syntax-form)
2315        (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2360            (case (binding-type b)
2363                 (syntax-type (chi-macro (binding-value b)
2376                       (case (binding-type b)
2377                         ((lexical) (build-lexical-assignment ae (binding-value b) val))
2379                          (let ((sym (binding-value b)))
2380                            (when (read-only-binding? n)
2386                              (build-global-assignment ae (binding-value b) val)
2494                           (let ((mr (extend-env label (make-binding 'meta-variable sym) mr)))
2503                             (extend-env label (make-binding 'lexical var) r)
2516                      (let ((b (defer-or-eval-transformer local-eval-hook exp)))
2536                            (let ((b (make-binding '$module iface)))
2543                     (let ((binding (lookup mlabel r)))
2544                       (case (car binding)
2546                          (let ((iface (cdr binding)))
2583                 ((local-syntax-form)
2584                  (let-values (((forms r mr w ae) (chi-local-syntax value e r mr w ae)))
2720                            (make-binding-wrap ids labels w)
2737                            (make-binding-wrap old-ids labels w)
2741 (define chi-local-syntax
2751                (let ((new-w (make-binding-wrap ids labels w)))
2755                                       local-eval-hook
2855            (lambda (id) (store-import-binding id token))
2857      (define (put-cte id binding token)
2859         (store-import-binding id token)
2861           ; global binding is assumed; if global pass #f to remove existing binding, if any
2862            (if (and (eq? (binding-type binding) 'global)
2863                     (eq? (binding-value binding) sym))
2865                binding))))
2866      (let ((binding (make-transformer-binding b)))
2867        (case (binding-type binding)
2869           (let ((iface (binding-value binding)))
2871           (put-cte id binding top-token))
2872          ((do-alias) (store-import-binding id top-token))
2874           ; fake binding: id is module id binding-value is pair containing
2876           (let ((import-only? (car (binding-value b)))
2877                  (token (cdr (binding-value b))))
2879                (case (binding-type b)
2881                   (let* ((iface (binding-value b))
2887          (else (put-cte id binding top-token))))
2893 (global-extend 'local-syntax 'letrec-syntax #t)
2894 (global-extend 'local-syntax 'let-syntax #f)
2905              (case (binding-type (lookup n r))
2911                             local-eval-hook
2936                 (if (eq? (binding-type b) 'syntax)
2938                                   (let ((var.lev (binding-value b)))
3107                (let ((w (make-binding-wrap ids labels w))
3202                                     (make-binding 'syntax `(,var . ,level)))
3207                          (make-binding-wrap ids labels empty-wrap)
3222                ; fat finger binding and references to temp variable y
3261                               (extend-env label (make-binding 'syntax `(,var . 0)) r)
3263                               (make-binding-wrap (syntax (pat))
3281                  ; fat finger binding and references to temp variable x
3315         (case (binding-type b)
3320                  (interface-exports (binding-value b))))
3491 ;;; using the following table.  See also update-mode-set.
3815                            (binding (car bindings)))
3816                (syntax (let (binding) body)))))))))