Changeset 15057 in project for chicken


Ignore:
Timestamp:
06/25/09 09:39:06 (10 years ago)
Author:
felix winkelmann
Message:

fix for begin-capturing bug (#47), removed uses of define-macro

Location:
chicken/trunk
Files:
12 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/compiler.scm

    r15053 r15057  
    623623                                        (compiler-warning
    624624                                         'ext "extension `~A' is currently not installed" id))
    625                                       `(begin ,exp ,(loop (cdr ids))) ) ) ) )
     625                                      `(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
    626626                            e se dest) ) )
    627627
     
    969969                         '(##core#undefined) )
    970970
    971                         ((begin)
    972                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
     971                        ((begin ##core#begin)
     972                         (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
    973973                         (if (pair? (cdr x))
    974974                             (canonicalize-begin-body
  • chicken/trunk/eval.scm

    r15038 r15057  
    377377                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
    378378
    379                          [(begin)
    380                           (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
     379                         [(begin ##core#begin)
     380                          (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
    381381                          (let* ([body (##sys#slot x 1)]
    382382                                 [len (length body)] )
     
    390390                               (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
    391391                                      [x2 (compile (cadr body) e #f tf cntr se)]
    392                                       [x3 (compile `(,(rename 'begin se) ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
     392                                      [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
    393393                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
    394394
     
    11931193           (lambda () (list id)))))
    11941194      (define (impform x id builtin?)
    1195         `(begin
     1195        `(##core#begin
    11961196           ,x
    11971197           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
    1198                  `((import ,id))
     1198                 `((import ,id))        ;XXX make hygienic
    11991199                 '())))
    12001200      (define (doit id)
     
    12091209                 (if comp?
    12101210                     `(##core#declare (uses ,id))
    1211                      `(load-library ',id) )
     1211                     `(##sys#load-library ',id #f) )
    12121212                 id #t)
    12131213                #t) )
     
    12161216                      (s (assq 'syntax info)))
    12171217                 (values
    1218                   `(begin
     1218                  `(##core#begin
    12191219                     ,@(if s `((##core#require-for-syntax ',id)) '())
    12201220                     ,(impform
    12211221                       (if comp?
    12221222                           `(##core#declare (uses ,id))
    1223                            `(load-library ',id) )
     1223                           `(##sys#load-library ',id #f) )
    12241224                       id #f))
    12251225                  #t) ) )
     
    12321232                          (values
    12331233                           (impform
    1234                             `(begin
     1234                            `(##core#begin
    12351235                               ,@(if s `((##core#require-for-syntax ',id)) '())
    12361236                               ,@(if (and (not rr) s)
     
    12591259                                    (f #f) )
    12601260                           (if (null? specs)
    1261                                (values `(begin ,@(reverse exps)) f)
     1261                               (values `(##core#begin ,@(reverse exps)) f)
    12621262                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
    12631263                                 (loop (cdr specs)
  • chicken/trunk/expand.scm

    r15049 r15057  
    507507              (if (not (pair? body2))
    508508                  (cons
    509                    (macro-alias 'begin se)
     509                   '##core#begin
    510510                   body) ; no more defines, otherwise we would have called `expand'
    511511                  (let ([x (car body2)])
     
    516516                                        (eq? (or (lookup d se) d) 'define-values)))) )
    517517                        (cons
    518                          (macro-alias 'begin se)
     518                         '##core#begin
    519519                         (##sys#append (reverse exps) (list (expand body2))))
    520520                        (loop (cdr body2) (cons x exps)) ) ) ) )
  • chicken/trunk/private-namespace.scm

    r15038 r15057  
    2626
    2727
    28 (cond-expand
    29  (hygienic-macros
    30   (define-syntax private
    31     (lambda (form r c)
    32       (let ((namespace (cadr form))
    33             (vars (cddr form)))
    34         (##sys#check-symbol namespace 'private)
    35         (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
    36                (prefix (string-append
    37                         (string (integer->char (string-length str)))
    38                         (symbol->string namespace))))
    39           (for-each
    40            (lambda (var)
    41              (put!
    42               var 'c:namespace
    43               (##sys#string->qualified-symbol prefix (symbol->string var))))
    44            vars)
    45           '(##core#undefined) ) ) ) ) )
    46  (else
    47   (define-macro (private . args)
    48     (let ((namespace (car args))
    49           (vars (cdr args)))
     28(define-syntax private
     29  (lambda (form r c)
     30    (let ((namespace (cadr form))
     31          (vars (cddr form)))
    5032      (##sys#check-symbol namespace 'private)
    51       (let* ((str (symbol->string namespace))
     33      (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
    5234             (prefix (string-append
    5335                      (string (integer->char (string-length str)))
     
    5941            (##sys#string->qualified-symbol prefix (symbol->string var))))
    6042         vars)
    61         '(void) ) ) ) ) )
     43        '(##core#undefined) ) ) ) )
    6244
    6345(set! ##sys#alias-global-hook
  • chicken/trunk/rules.make

    r15049 r15057  
    897897        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)/$(CHICKEN_STATUS_PROGRAM)
    898898endif
     899# this might be left over from older version and will break `chicken-install -update-db'
     900        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IEGGDIR)/compiler.import.so
    899901ifneq ($(CROSS_CHICKEN),1)
    900902ifeq ($(DESTDIR),)
  • chicken/trunk/scheduler.scm

    r12937 r15057  
    8787
    8888
    89 (cond-expand
    90  (hygienic-macros
    91   (define-syntax dbg
    92     (syntax-rules ()
    93       ((_ . _) #f))) )
    94  (else
    95   (define-macro (dbg . args) #f)
    96   #;(define-macro (dbg . args)
    97   `(print "DBG: " ,@args) ) ) )
     89(define-syntax dbg
     90  (syntax-rules ()
     91    ((_ . _) #f)))
    9892
    9993
  • chicken/trunk/srfi-13.scm

    r15038 r15057  
    172172;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    173173
    174 (cond-expand
    175  ((not hygienic-macros)
    176   (define-macro (let-string-start+end2 s-e proc s1 s2 args . body)
    177     (let ([procv (gensym)]
    178           [rest (gensym)] )
    179       `(let ((,procv ,proc))
    180          (let-string-start+end
    181           (,(car s-e) ,(cadr s-e) ,rest) ,procv ,s1 ,args
    182           (let-string-start+end
    183            ,(cddr s-e) ,procv ,s2 ,rest
    184            ,@body) ) ) ) ) )
    185  (else
    186   (define-syntax let-string-start+end2
    187     (syntax-rules ()
    188       ((_ (s-e1 s-e2 s-e3 s-e4) proc s1 s2 args . body)
    189        (let ((procv proc))
    190          (let-string-start+end
    191           (s-e1 s-e2 rest) procv s1 args
    192           (let-string-start+end
    193            (s-e3 s-e4) procv s2 rest
    194            . body) ) ) ) ) ) ) )
    195 
    196 (cond-expand
    197  ((not hygienic-macros)
    198   (define-macro (let-string-start+end s-e-r proc s-exp args-exp . body)
    199     (if (pair? (cddr s-e-r))
    200         `(receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
    201              (string-parse-start+end ,proc ,s-exp ,args-exp)
    202            ,@body)
    203         `(receive ,s-e-r
    204              (string-parse-final-start+end ,proc ,s-exp ,args-exp)
    205            ,@body) ) ) )
    206  (else
    207   (define-syntax let-string-start+end
    208     (lambda (form r c)
    209       (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
    210       (let ((s-e-r (cadr form))
    211             (proc (caddr form))
    212             (s-exp (cadddr form))
    213             (args-exp (car (cddddr form)))
    214             (body (cdr (cddddr form)))
    215             (%receive (r 'receive))
    216             (%string-parse-start+end (r 'string-parse-start+end))
    217             (%string-parse-final-start+end (r 'string-parse-final-start+end)))
    218         (if (pair? (cddr s-e-r))
    219             `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
    220                         (,%string-parse-start+end ,proc ,s-exp ,args-exp)
    221                         ,@body)
    222             `(,%receive ,s-e-r
    223                         (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
    224                         ,@body) ) )))) )
     174(define-syntax let-string-start+end2
     175  (syntax-rules ()
     176    ((_ (s-e1 s-e2 s-e3 s-e4) proc s1 s2 args . body)
     177     (let ((procv proc))
     178       (let-string-start+end
     179        (s-e1 s-e2 rest) procv s1 args
     180        (let-string-start+end
     181         (s-e3 s-e4) procv s2 rest
     182         . body) ) ) ) ) )
     183
     184(define-syntax let-string-start+end
     185  (lambda (form r c)
     186    (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
     187    (let ((s-e-r (cadr form))
     188          (proc (caddr form))
     189          (s-exp (cadddr form))
     190          (args-exp (car (cddddr form)))
     191          (body (cdr (cddddr form)))
     192          (%receive (r 'receive))
     193          (%string-parse-start+end (r 'string-parse-start+end))
     194          (%string-parse-final-start+end (r 'string-parse-final-start+end)))
     195      (if (pair? (cddr s-e-r))
     196          `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
     197                      (,%string-parse-start+end ,proc ,s-exp ,args-exp)
     198                      ,@body)
     199          `(,%receive ,s-e-r
     200                      (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
     201                      ,@body) ) )))
    225202
    226203
  • chicken/trunk/srfi-18.scm

    r13138 r15057  
    5555(register-feature! 'srfi-18)
    5656
    57 (cond-expand
    58  (hygienic-macros
    59   (define-syntax dbg
    60     (syntax-rules ()
    61       ((_ . _) #f))) )
    62  (else
    63   (define-macro (dbg . args) #f)
    64   #;(define-macro (dbg . args)
    65   `(print "DBG: " ,@args) ) ) )
     57(define-syntax dbg
     58  (syntax-rules ()
     59    ((_ . _) #f)))
    6660
    6761
  • chicken/trunk/tests/runtests.sh

    r15001 r15057  
    3030if test -n "$MSYSTEM"; then
    3131    dos2unix scrutiny.out
     32fi
     33
     34# this is sensitive to gensym-names, so make it optional
     35if test \! -f scrutiny.expected; then
     36    cp scrutiny.out scrutiny.expected
    3237fi
    3338
  • chicken/trunk/tests/scrutiny.expected

    r14993 r15057  
    88  expected value of type boolean in conditional but were given a value of type `number' which is always true:
    99
    10 (if x10 '1 '2)
     10(if x7 '1 '2)
    1111
    1212Warning: in toplevel procedure `foo':
    1313  branches in conditional expression differ in the number of results:
    1414
    15 (if x14 (values '1 '2) (values '1 '2 (+ ...)))
     15(if x10 (values '1 '2) (values '1 '2 (+ ...)))
    1616
    1717Warning: at toplevel:
    18   expected argument #2 of type `number' in procedure call to `bar17' (line 18), but where given an argument of type `symbol'
     18  expected argument #2 of type `number' in procedure call to `bar12' (line 18), but where given an argument of type `symbol'
    1919
    2020Warning: at toplevel:
     
    2828
    2929Warning: at toplevel:
    30   expected in procedure call to `x23' (line 26) a value of type `(procedure () *)', but were given a value of type `fixnum'
     30  expected in procedure call to `x17' (line 26) a value of type `(procedure () *)', but were given a value of type `fixnum'
    3131
    3232Warning: at toplevel:
  • chicken/trunk/tests/syntax-tests.scm

    r15047 r15057  
    353353  (c:condition-case
    354354   (c:abort "ugh")
    355    (ex () (c:print "aborted"))))
     355   (ex () (c:print "caught"))))
    356356
    357357(module prefixed-self-reference3 (a)
     
    364364  (import (prefix scheme s.))
    365365  (s.define (a x y) (s.and x y)))
     366
     367
     368;;; canonicalization of body captures 'begin (reported by Abdulaziz Ghuloum)
     369
     370(let ((begin (lambda (x y) (bomb)))) 1 2)
  • chicken/trunk/unsafe-declarations.scm

    r10439 r15057  
    2727(cond-expand
    2828 (unsafe
    29   (eval-when (compile)
    30     (cond-expand
    31      (hygienic-macros
    32       (define-syntax ##sys#check-closure
    33         (syntax-rules ()
    34           ((_ . _) (##core#undefined))))
    35       (define-syntax ##sys#check-inexact
    36         (syntax-rules ()
    37           ((_ . _) (##core#undefined))))
    38       (define-syntax ##sys#check-range
    39         (syntax-rules ()
    40           ((_ . _) (##core#undefined))))
    41       (define-syntax ##sys#check-pair
    42         (syntax-rules ()
    43           ((_ . _) (##core#undefined))))
    44       (define-syntax ##sys#check-blob
    45         (syntax-rules ()
    46           ((_ . _) (##core#undefined))))
    47       (define-syntax ##sys#check-list
    48         (syntax-rules ()
    49           ((_ . _) (##core#undefined))))
    50       (define-syntax ##sys#check-symbol
    51         (syntax-rules ()
    52           ((_ . _) (##core#undefined))))
    53       (define-syntax ##sys#check-string
    54         (syntax-rules ()
    55           ((_ . _) (##core#undefined))))
    56       (define-syntax ##sys#check-char
    57         (syntax-rules ()
    58           ((_ . _) (##core#undefined))))
    59       (define-syntax ##sys#check-exact
    60         (syntax-rules ()
    61           ((_ . _) (##core#undefined))))
    62       (define-syntax ##sys#check-port
    63         (syntax-rules ()
    64           ((_ . _) (##core#undefined))))
    65       (define-syntax ##sys#check-port-mode
    66         (syntax-rules ()
    67           ((_ . _) (##core#undefined))))
    68       (define-syntax ##sys#check-port*
    69         (syntax-rules ()
    70           ((_ . _) (##core#undefined))))
    71       (define-syntax ##sys#check-number
    72         (syntax-rules ()
    73           ((_ . _) (##core#undefined))))
    74       (define-syntax ##sys#check-special
    75         (syntax-rules ()
    76           ((_ . _) (##core#undefined))))
    77       (define-syntax ##sys#check-byte-vector
    78         (syntax-rules ()
    79           ((_ . _) '(##core#undefined)) ) ) )
    80      (else                              ;***
    81       (define-macro (##sys#check-closure . _) '(##core#undefined))
    82       (define-macro (##sys#check-inexact . _) '(##core#undefined))
    83       (define-macro (##sys#check-structure . _) '(##core#undefined))
    84       (define-macro (##sys#check-range . _) '(##core#undefined))
    85       (define-macro (##sys#check-pair . _) '(##core#undefined))
    86       (define-macro (##sys#check-list . _) '(##core#undefined))
    87       (define-macro (##sys#check-symbol . _) '(##core#undefined))
    88       (define-macro (##sys#check-string . _) '(##core#undefined))
    89       (define-macro (##sys#check-blob . _) '(##core#undefined))
    90       (define-macro (##sys#check-char . _) '(##core#undefined))
    91       (define-macro (##sys#check-exact . _) '(##core#undefined))
    92       (define-macro (##sys#check-port . _) '(##core#undefined))
    93       (define-macro (##sys#check-port* . _) '(##core#undefined))
    94       (define-macro (##sys#check-port-mode . _) '(##core#undefined))
    95       (define-macro (##sys#check-special . _) '(##core#undefined))
    96       (define-macro (##sys#check-number . _) '(##core#undefined))
    97       (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ) ) )
     29  (define-syntax ##sys#check-closure
     30    (syntax-rules ()
     31      ((_ . _) (##core#undefined))))
     32  (define-syntax ##sys#check-inexact
     33    (syntax-rules ()
     34      ((_ . _) (##core#undefined))))
     35  (define-syntax ##sys#check-range
     36    (syntax-rules ()
     37      ((_ . _) (##core#undefined))))
     38  (define-syntax ##sys#check-pair
     39    (syntax-rules ()
     40      ((_ . _) (##core#undefined))))
     41  (define-syntax ##sys#check-blob
     42    (syntax-rules ()
     43      ((_ . _) (##core#undefined))))
     44  (define-syntax ##sys#check-list
     45    (syntax-rules ()
     46      ((_ . _) (##core#undefined))))
     47  (define-syntax ##sys#check-symbol
     48    (syntax-rules ()
     49      ((_ . _) (##core#undefined))))
     50  (define-syntax ##sys#check-string
     51    (syntax-rules ()
     52      ((_ . _) (##core#undefined))))
     53  (define-syntax ##sys#check-char
     54    (syntax-rules ()
     55      ((_ . _) (##core#undefined))))
     56  (define-syntax ##sys#check-exact
     57    (syntax-rules ()
     58      ((_ . _) (##core#undefined))))
     59  (define-syntax ##sys#check-port
     60    (syntax-rules ()
     61      ((_ . _) (##core#undefined))))
     62  (define-syntax ##sys#check-port-mode
     63    (syntax-rules ()
     64      ((_ . _) (##core#undefined))))
     65  (define-syntax ##sys#check-port*
     66    (syntax-rules ()
     67      ((_ . _) (##core#undefined))))
     68  (define-syntax ##sys#check-number
     69    (syntax-rules ()
     70      ((_ . _) (##core#undefined))))
     71  (define-syntax ##sys#check-special
     72    (syntax-rules ()
     73      ((_ . _) (##core#undefined))))
     74  (define-syntax ##sys#check-byte-vector
     75    (syntax-rules ()
     76      ((_ . _) '(##core#undefined)) ) ))
    9877 (else))
Note: See TracChangeset for help on using the changeset viewer.