Changeset 14340 in project


Ignore:
Timestamp:
04/22/09 11:09:11 (11 years ago)
Author:
felix winkelmann
Message:

possible fix for let-syntax/local var (#15) bug reported by Alex Shinn

Location:
chicken/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/compiler.scm

    r14236 r14340  
    303303
    304304
     305(define (d arg1 . more)
     306  (if (null? more)
     307      (pp arg1)
     308      (apply print arg1 more)))
     309
     310(define-syntax d (syntax-rules () ((_ . _) (void))))
     311
    305312(include "tweaks")
    306313
     
    474481        x) )
    475482
    476   (define (resolve-variable x0 se dest)
     483  (define (resolve-variable x0 e se dest)
    477484    (let ((x (lookup x0 se)))
     485      (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
    478486      (cond ((not (symbol? x)) x0)      ; syntax?
    479487            [(and constants-used (##sys#hash-table-ref constant-table x))
    480              => (lambda (val) (walk (car val) se dest)) ]
     488             => (lambda (val) (walk (car val) e se dest)) ]
    481489            [(and inline-table-used (##sys#hash-table-ref inline-table x))
    482              => (lambda (val) (walk val se dest)) ]
     490             => (lambda (val) (walk val e se dest)) ]
    483491            [(assq x foreign-variables)
    484492             => (lambda (fv)
     
    490498                      (finish-foreign-result ft body)
    491499                      t)
    492                      se dest)))]
     500                     e se dest)))]
    493501            [(assq x location-pointer-map)
    494502             => (lambda (a)
     
    500508                      (finish-foreign-result ft body)
    501509                      t)
    502                      se dest))) ]
    503             ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
     510                     e se dest))) ]
     511            ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
    504512            ((##sys#get x '##core#primitive))
    505513            (else x))))
     
    514522       '() ) ))
    515523
    516   (define (walk x se dest)
     524  (define (walk x e se dest)
    517525    (cond ((symbol? x)
    518526           (cond ((keyword? x) `(quote ,x))
     
    521529                   'var
    522530                   "reference to variable `~s' possibly unintended" x) ))
    523            (resolve-variable x se dest))
     531           (resolve-variable x e se dest))
    524532          ((not-pair? x)
    525533           (if (constant? x)
     
    538546                    (xexpanded (##sys#expand x se)))
    539547               (cond ((not (eq? x xexpanded))
    540                       (walk xexpanded se dest))
     548                      (walk xexpanded e se dest))
    541549                     
    542550                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
    543551                      => (lambda (val)
    544                            (walk (cons val (cdr x)) se dest)) ]
     552                           (walk (cons val (cdr x)) e se dest)) ]
    545553                     
    546554                     [else
     
    551559                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
    552560                         `(if
    553                            ,(walk (cadr x) se #f)
    554                            ,(walk (caddr x) se #f)
     561                           ,(walk (cadr x) e se #f)
     562                           ,(walk (caddr x) e se #f)
    555563                           ,(if (null? (cdddr x))
    556564                                '(##core#undefined)
    557                                 (walk (cadddr x) se #f) ) ) )
     565                                (walk (cadddr x) e se #f) ) ) )
    558566
    559567                        ((quote syntax)
     
    564572                         (if unsafe
    565573                             ''#t
    566                              (walk (cadr x) se dest) ) )
     574                             (walk (cadr x) e se dest) ) )
    567575
    568576                        ((##core#immutable)
     
    585593                         `(##core#inline_loc_ref
    586594                           ,(##sys#strip-syntax (cadr x))
    587                            ,(walk (caddr x) se dest)))
     595                           ,(walk (caddr x) e se dest)))
    588596
    589597                        ((##core#require-for-syntax)
     
    613621                                         'ext "extension `~A' is currently not installed" id))
    614622                                      `(begin ,exp ,(loop (cdr ids))) ) ) ) )
    615                             se dest) ) )
     623                            e se dest) ) )
    616624
    617625                        ((let ##core#let)
     
    624632                           `(let
    625633                             ,(map (lambda (alias b)
    626                                      (list alias (walk (cadr b) se (car b))) )
     634                                     (list alias (walk (cadr b) e se (car b))) )
    627635                                   aliases bindings)
    628636                             ,(walk (##sys#canonicalize-body (cddr x) se2)
     637                                    (append aliases e)
    629638                                    se2 dest) ) ) )
    630639
     
    635644                            (walk
    636645                             `(##core#let
    637                                ,(##sys#map (lambda (b)
    638                                              (list (car b) '(##core#undefined)))
    639                                            bindings)
    640                                ,@(##sys#map (lambda (b)
    641                                               `(##core#set! ,(car b) ,(cadr b)))
    642                                             bindings)
     646                               ,(map (lambda (b)
     647                                       (list (car b) '(##core#undefined)))
     648                                     bindings)
     649                               ,@(map (lambda (b)
     650                                        `(##core#set! ,(car b) ,(cadr b)))
     651                                      bindings)
    643652                               (##core#let () ,@body) )
    644                              se dest)))
     653                             e se dest)))
    645654
    646655                        ((lambda ##core#lambda)
     
    659668                                     (se2 (append (map cons vars aliases) se))
    660669                                     (body0 (##sys#canonicalize-body obody se2))
    661                                      (body (walk body0 se2 #f))
     670                                     (body (walk body0 (append aliases e) se2 #f))
    662671                                     (llist2
    663672                                      (build-lambda-list
     
    703712                           (walk
    704713                            (##sys#canonicalize-body (cddr x) se2)
    705                             se2
     714                            e se2
    706715                            dest) ) )
    707716                               
     
    722731                          (walk
    723732                           (##sys#canonicalize-body (cddr x) se2)
    724                            se2 dest)))
     733                           e se2 dest)))
    725734                               
    726735                       ((define-syntax)
     
    749758                                 (##sys#er-transformer ,body)) ;*** possibly wrong se?
    750759                               '(##core#undefined) )
    751                            se dest)) )
     760                           e se dest)) )
    752761
    753762                       ((define-compiled-syntax)
     
    774783                             (##sys#er-transformer
    775784                              ,body)) ;*** possibly wrong se?
    776                            se dest)))
     785                           e se dest)))
    777786
    778787                       ((##core#define-rewrite-rule)
     
    851860                                                 (cons (walk
    852861                                                        (car body)
     862                                                        e ;?
    853863                                                        (##sys#current-environment)
    854864                                                        #f)
     
    860870                                (map
    861871                                 (lambda (x)
    862                                    (walk x (##sys#current-meta-environment) #f) )
     872                                   (walk
     873                                    x
     874                                    e   ;?
     875                                    (##sys#current-meta-environment) #f) )
    863876                                 mreg))
    864877                              body)))))
    865878
    866879                       ((##core#named-lambda)
    867                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
     880                        (walk `(,(macro-alias 'lambda se) ,@(cddr x)) e se (cadr x)) )
    868881
    869882                       ((##core#loop-lambda)
     
    875888                                (walk
    876889                                 (##sys#canonicalize-body obody se2)
     890                                 (append aliases e)
    877891                                 se2 #f) ] )
    878892                          (set-real-names! aliases vars)
     
    899913                                               (,(third fv) ,type)
    900914                                               ,(foreign-type-check tmp type) ) )
    901                                            se #f))))
     915                                           e se #f))))
    902916                                 ((assq var location-pointer-map)
    903917                                  => (lambda (a)
     
    910924                                              ,(second a)
    911925                                              ,(foreign-type-check tmp type) ) )
    912                                           se #f))))
     926                                          e se #f))))
    913927                                 (else
    914928                                  (when (eq? var var0) ; global?
     
    928942                                    (syntax-error
    929943                                     'set! "assignment to syntactic identifier" var))
    930                                   `(set! ,var ,(walk val se var0))))))
     944                                  `(set! ,var ,(walk val e se var0))))))
    931945
    932946                        ((##core#inline)
    933                          `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
     947                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
    934948
    935949                        ((##core#inline_allocate)
    936950                         `(##core#inline_allocate
    937951                           ,(map (cut unquotify <> se) (second x))
    938                            ,@(mapwalk (cddr x) se)))
     952                           ,@(mapwalk (cddr x) e se)))
    939953
    940954                        ((##core#inline_update)
    941                          `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
     955                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f)) )
    942956
    943957                        ((##core#inline_loc_update)
    944958                         `(##core#inline_loc_update
    945959                           ,(cadr x)
    946                            ,(walk (caddr x) se #f)
    947                            ,(walk (cadddr x) se #f)) )
     960                           ,(walk (caddr x) e se #f)
     961                           ,(walk (cadddr x) e se #f)) )
    948962
    949963                        ((##core#compiletimetoo ##core#elaborationtimetoo)
    950964                         (let ((exp (cadr x)))
    951965                           (eval/meta exp)
    952                            (walk exp se dest) ) )
     966                           (walk exp e se dest) ) )
    953967
    954968                        ((##core#compiletimeonly ##core#elaborationtimeonly)
     
    964978                                      [r (cdr xs)] )
    965979                                  (if (null? r)
    966                                       (list (walk x se dest))
    967                                       (cons (walk x se #f) (fold r)) ) ) ) )
     980                                      (list (walk x e se dest))
     981                                      (cons (walk x e se #f) (fold r)) ) ) ) )
    968982                             '(##core#undefined) ) )
    969983
    970984                        ((foreign-lambda)
    971                          (walk (expand-foreign-lambda x) se dest) )
     985                         (walk (expand-foreign-lambda x) e se dest) )
    972986
    973987                        ((foreign-safe-lambda)
    974                          (walk (expand-foreign-callback-lambda x) se dest) )
     988                         (walk (expand-foreign-callback-lambda x) e se dest) )
    975989
    976990                        ((foreign-lambda*)
    977                          (walk (expand-foreign-lambda* x) se dest) )
     991                         (walk (expand-foreign-lambda* x) e se dest) )
    978992
    979993                        ((foreign-safe-lambda*)
    980                          (walk (expand-foreign-callback-lambda* x) se dest) )
     994                         (walk (expand-foreign-callback-lambda* x) e se dest) )
    981995
    982996                        ((foreign-primitive)
    983                          (walk (expand-foreign-primitive x) se dest) )
     997                         (walk (expand-foreign-primitive x) e se dest) )
    984998
    985999                        ((define-foreign-variable)
     
    10151029                                         ,ret
    10161030                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
    1017                                      se dest) ) ]
     1031                                     e se dest) ) ]
    10181032                                 [else
    10191033                                  (##sys#hash-table-set! foreign-type-table name type)
     
    10571071                                      '() )
    10581072                                ,(if init (fifth x) (fourth x)) ) )
    1059                             (alist-cons var alias se)
     1073                            e (alist-cons var alias se)
    10601074                            dest) ) )
    10611075
     
    10901104                                    (mark-variable var '##compiler#constant)
    10911105                                    (mark-variable var '##compiler#always-bound)
    1092                                     (walk `(define ,var ',val) se #f) ) ] ) ) )
     1106                                    (walk `(define ,var ',val) e se #f) ) ] ) ) )
    10931107
    10941108                        ((##core#declare)
     
    10981112                                      (process-declaration d se))
    10991113                                    (cdr x) ) )
    1100                           '() #f) )
     1114                          e '() #f) )
    11011115             
    11021116                        ((##core#foreign-callback-wrapper)
     
    11181132                                vars atypes) )
    11191133                             `(##core#foreign-callback-wrapper
    1120                                ,@(mapwalk args se)
     1134                               ,@(mapwalk args e se)
    11211135                               ,(walk `(##core#lambda
    11221136                                        ,vars
     
    11731187                                                (else (cddr lam)) ) )
    11741188                                           rtype) ) )
    1175                                       se #f) ) ) ) )
     1189                                      e se #f) ) ) ) )
    11761190
    11771191                        (else
    11781192                         (let ([handle-call
    11791193                                (lambda ()
    1180                                   (let* ([x2 (mapwalk x se)]
     1194                                  (let* ([x2 (mapwalk x e se)]
    11811195                                         [head2 (car x2)]
    11821196                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
     
    11961210                                                    (walk
    11971211                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
    1198                                                      se #f) ) ]
     1212                                                     e se #f) ) ]
    11991213                                              [(assq sym external-to-pointer)
    1200                                                => (lambda (a) (walk (cdr a) se #f)) ]
     1214                                               => (lambda (a) (walk (cdr a) e se #f)) ]
    12011215                                              [(memq sym callback-names)
    12021216                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
    12031217                                              [else
    1204                                                (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
    1205                                         (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
     1218                                               (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
     1219                                        (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
    12061220                                 
    12071221                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
     
    12131227           (emit-syntax-trace-info x #f)
    12141228           (compiler-warning 'syntax "literal in operator position: ~S" x)
    1215            (mapwalk x se) )
     1229           (mapwalk x e se) )
    12161230
    12171231          ((and (pair? (car x))
     
    12251239               (if (and (proper-list? llist) (= (llist-length llist) (length args)))
    12261240                   (walk `(,(macro-alias 'let se)
    1227                            ,(map list llist args) ,@(cddr lexp)) se dest)
     1241                           ,(map list llist args) ,@(cddr lexp))
     1242                         e se dest)
    12281243                   (let ((var (gensym 't)))
    12291244                     (walk
     
    12311246                        ((,var ,(car x)))
    12321247                        (,var ,@(cdr x)) )
    1233                       se dest) ) ) ) ) )
     1248                      e se dest) ) ) ) ) )
    12341249         
    12351250          (else
    12361251           (emit-syntax-trace-info x #f)
    1237            (mapwalk x se)) ) )
     1252           (mapwalk x e se)) ) )
    12381253 
    1239   (define (mapwalk xs se)
    1240     (map (lambda (x) (walk x se #f)) xs) )
     1254  (define (mapwalk xs e se)
     1255    (map (lambda (x) (walk x e se #f)) xs) )
    12411256
    12421257  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
     
    12511266         (set! extended-bindings (append internal-bindings extended-bindings))
    12521267         exp) )
    1253    (##sys#current-environment)
     1268   '() (##sys#current-environment)
    12541269   #f) )
    12551270
  • chicken/trunk/eval.scm

    r14236 r14340  
    3939      (apply print arg1 more)))
    4040
    41 (cond-expand
    42  (hygienic-macros
    43   (define-syntax d (syntax-rules () ((_ . _) (void)))) )
    44  (else
    45   (define-macro (d . _) '(void))))      ;*** remove later
     41(define-syntax d (syntax-rules () ((_ . _) (void))))
    4642
    4743#>
  • chicken/trunk/expand.scm

    r14268 r14340  
    4949(cond-expand
    5050 ((not debugbuild)
    51   (declare
    52     (no-bound-checks)
    53     (no-procedure-checks))
    54   (cond-expand
    55    (hygienic-macros
    56     (define-syntax dd (syntax-rules () ((_ . _) (void)))))
    57    (else                                        ;*** remove later
    58     (define-macro (dd . _) '(void))))
    59   (cond-expand
    60    (hygienic-macros
    61     (define-syntax dm (syntax-rules () ((_ . _) (void)))))
    62    (else                                        ;*** remove later
    63     (define-macro (dm . _) '(void)))))
     51  (begin
     52    (declare
     53      (no-bound-checks)
     54      (no-procedure-checks))
     55    (define-syntax dd (syntax-rules () ((_ . _) (void))))
     56    (define-syntax dm (syntax-rules () ((_ . _) (void))))))
    6457 (else))
    6558
Note: See TracChangeset for help on using the changeset viewer.