Changeset 15047 in project for chicken/trunk


Ignore:
Timestamp:
06/22/09 13:19:06 (10 years ago)
Author:
felix winkelmann
Message:

possibly really fixed prefix/import problem

Location:
chicken/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/c-platform.scm

    r14882 r15047  
    106106
    107107(define eq-inline-operator "C_eqp")
    108 (define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref))
     108(define optimizable-rest-argument-operators
     109  '(car cadr caddr cadddr length pair? null? list-ref))
    109110(define membership-test-operators
    110111  '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
  • chicken/trunk/chicken-syntax.scm

    r15020 r15047  
    5151           (slots (cddr x))
    5252           (prefix (symbol->string name))
     53           (%quote (r 'quote))
    5354           (setters (memq #:record-setters ##sys#features))
    5455           (%begin (r 'begin))
     
    5960          (,%define
    6061           ,(string->symbol (string-append "make-" prefix))
    61            (,%lambda ,slots (##sys#make-structure ',name ,@slots)) )
     62           (,%lambda ,slots (##sys#make-structure (,%quote ,name) ,@slots)) )
    6263          (,%define
    6364           ,(string->symbol (string-append prefix "?"))
     
    7475                         ,setr
    7576                         (,%lambda (x val)
    76                                    (##core#check (##sys#check-structure x ',name))
     77                                   (##core#check (##sys#check-structure x (,%quote ,name)))
    7778                                   (##sys#block-set! x ,i val) ) )
    7879                        (,%define
     
    8182                              `(,%getter-with-setter
    8283                                (,%lambda (x)
    83                                           (##core#check (##sys#check-structure x ',name))
     84                                          (##core#check (##sys#check-structure x (,%quote ,name)))
    8485                                          (##sys#block-ref x ,i) )
    8586                                ,setr)
    8687                              `(,%lambda (x)
    87                                          (##core#check (##sys#check-structure x ',name))
     88                                         (##core#check (##sys#check-structure x (,%quote ,name)))
    8889                                         (##sys#block-ref x ,i) ) ) ) )
    8990                     (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
     
    417418
    418419(##sys#extend-macro-environment
    419  'nth-value '()
     420 'nth-value
     421 `((list-ref . ,(##sys#primitive-alias 'list-ref)))
    420422 (##sys#er-transformer
    421423  (lambda (form r c)
    422424    (##sys#check-syntax 'nth-value form '(_ _ _))
    423425    (let ((v (r 'tmp))
    424           (%list-ref (r 'list-ref))
    425426          (%lambda (r 'lambda)))
    426427      `(##sys#call-with-values
    427428        (,%lambda () ,(caddr form))
    428         (,%lambda ,v (,%list-ref ,v ,(cadr form))))))))
     429        (,%lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
    429430
    430431(##sys#extend-macro-environment
     
    480481          (%else (r 'else))
    481482          (%or (r 'or))
    482           (%eqv? (r 'eqv?))
    483483          (%begin (r 'begin)))
    484484      `(,(r 'let) ((,tmp ,exp))
     
    491491                 (if (c %else (car clause))
    492492                     `(,%begin ,@(cdr clause))
    493                      `(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x))
     493                     `(,%if (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x))
    494494                                         (car clause) ) )
    495495                            (,%begin ,@(cdr clause))
     
    574574
    575575(##sys#extend-macro-environment
    576  'let-optionals '()
     576 'let-optionals
     577 `((car . ,(##sys#primitive-alias 'car))
     578   (cdr . ,(##sys#primitive-alias 'cdr)))
    577579 (##sys#er-transformer
    578580  (lambda (form r c)
     
    581583          (var/defs (caddr form))
    582584          (body (cdddr form))
    583           (%null? (r 'null?))
    584585          (%if (r 'if))
    585586          (%let (r 'let))
    586           (%car (r 'car))
    587           (%cdr (r 'cdr))
    588587          (%lambda (r 'lambda)))
    589588
     
    612611        (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
    613612          (if (null? vars)
    614               `(,%if (##core#check (,%null? ,rest))
     613              `(,%if (##core#check (,(r 'null?) ,rest))
    615614                     (,body-proc . ,(reverse non-defaults))
    616615                     (##sys#error (##core#immutable '"too many optional arguments") ,rest))
     
    618617                `(,%if (null? ,rest)
    619618                       (,(car defaulters) . ,(reverse non-defaults))
    620                        (,%let ((,v (,%car ,rest))
    621                                (,rest (,%cdr ,rest)))
     619                       (,%let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
     620                               (,rest (,(r 'cdr) ,rest)))
    622621                              ,(recur (cdr vars)
    623622                                      (cdr defaulters)
     
    669668
    670669(##sys#extend-macro-environment
    671  'optional '()
     670 'optional
     671 `((null? . ,(##sys#primitive-alias 'null?))
     672   (car . ,(##sys#primitive-alias 'car))
     673   (cdr . ,(##sys#primitive-alias 'cdr)) )
    672674 (##sys#er-transformer
    673675  (lambda (form r c)
    674676    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
    675677    (let ((var (r 'tmp))
    676           (%null? (r 'null?))
    677678          (%if (r 'if)))
    678679      `(,(r 'let) ((,var ,(cadr form)))
    679         (,%if (,%null? ,var)
     680        (,%if (,(r 'null?) ,var)
    680681              ,(optional (cddr form) #f)
    681               (,%if (##core#check (,%null? (,(r 'cdr) ,var)))
     682              (,%if (##core#check (,(r 'null?) (,(r 'cdr) ,var)))
    682683                    (,(r 'car) ,var)
    683684                    (##sys#error
     
    702703
    703704(##sys#extend-macro-environment
    704  'let-optionals* '()
     705 'let-optionals*
     706 `((null? . ,(##sys#primitive-alias 'null?)))
    705707 (##sys#er-transformer
    706708  (lambda (form r c)
     
    710712          (body (cdddr form))
    711713          (%let (r 'let))
    712           (%if (r 'if))
    713714          (%null? (r 'null?))
    714715          (%car (r 'car))
    715           (%cdr (r 'cdr)))
     716          (%cdr (r 'cdr))
     717          (%if (r 'if)))
    716718      (let ((rvar (r 'tmp)))
    717719        `(,%let ((,rvar ,args))
     
    739741
    740742(##sys#extend-macro-environment
    741  'case-lambda '()
     743 'case-lambda
     744 `((>= . ,(##sys#primitive-alias '>=))
     745   (car . ,(##sys#primitive-alias 'car))
     746   (cdr . ,(##sys#primitive-alias 'cdr))
     747   (eq? . ,(##sys#primitive-alias 'eq?)))
    742748 (##sys#er-transformer
    743749  (lambda (form r c)
     
    748754            '()
    749755            (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
    750     (require 'srfi-1)                   ; Urgh...
     756    (require 'srfi-1)                   ; ugh...
    751757    (let* ((mincount (apply min (map (lambda (c)
    752758                                       (##sys#decompose-lambda-list
     
    759765           (%lambda (r 'lambda))
    760766           (%let (r 'let))
     767           (%>= (r '>=))
     768           (%eq? (r 'eq?))
     769           (%car (r 'car))
     770           (%cdr (r 'cdr))
    761771           (%if (r 'if)))
    762772      `(,%lambda ,(append minvars rvar)
     
    772782                                             (if (zero? a2)
    773783                                                 #t
    774                                                  `(,(r '>=) ,lvar ,a2) )
    775                                              `(,(r 'eq?) ,lvar ,a2) ) )
     784                                                 `(,%>= ,lvar ,a2) )
     785                                             `(,%eq? ,lvar ,a2) ) )
    776786                                      ,(receive (vars1 vars2)
    777787                                           (split-at! (take vars argc) mincount)
     
    783793                                                            (else `(,%let () ,@(cdr c))) )
    784794                                                      (let ((vrest2 (r (gensym))))
    785                                                         `(,%let ((,(car vars2) (,(r 'car) ,vrest))
    786                                                                  (,vrest2 (,(r 'cdr) ,vrest)) )
     795                                                        `(,%let ((,(car vars2) (,%car ,vrest))
     796                                                                 (,vrest2 (,%cdr ,vrest)) )
    787797                                                                ,(if (pair? (cdr vars2))
    788798                                                                     (build (cdr vars2) vrest2)
     
    820830
    821831(##sys#extend-macro-environment
    822  'handle-exceptions '()
     832 'handle-exceptions
     833 `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation))
     834   (with-exception-handler . ,(##sys#primitive-alias 'with-exception-handler)))
    823835 (##sys#er-transformer
    824836  (lambda (form r c)
     
    839851
    840852(##sys#extend-macro-environment
    841  'condition-case '()
     853 'condition-case
     854 `((else . ,(##sys#primitive-alias 'else))
     855   (memv . ,(##sys#primitive-alias 'memv)))
    842856 (##sys#er-transformer
    843857  (lambda (form r c)
     
    847861          (%and (r 'and))
    848862          (%let (r 'let))
     863          (%quote (r 'quote))
    849864          (%memv (r 'memv))
    850865          (%else (r 'else)))
     
    858873                     `(,%let ([,var ,exvar]) ,@body)
    859874                     `(,%let () ,@body) ) )
    860               `((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
     875              `((,%and ,kvar ,@(map (lambda (k) `(,%memv (,%quote ,k) ,kvar)) kinds))
    861876                ,(if var
    862877                     `(,%let ([,var ,exvar]) ,@body)
    863878                     `(,%let () ,@body) ) ) ) ) )
    864879      `(,(r 'handle-exceptions) ,exvar
    865         (,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition)
     880        (,%let ([,kvar (,%and (##sys#structure? ,exvar (,%quote condition) )
    866881                              (##sys#slot ,exvar 1))])
    867882               (,(r 'cond) ,@(map parse-clause (cddr form))
     
    873888
    874889(##sys#extend-macro-environment
    875  'define-record-type '()
     890 'define-record-type
     891 `((getter-with-setter . (##sys#primitive-alias 'getter-with-setter)))
    876892 (##sys#er-transformer
    877893  (lambda (form r c)
     
    884900          (%lambda (r 'lambda))
    885901          (%define (r 'define))
     902          (%quote (r 'quote))
     903          (%getter-with-setter (r 'getter-with-setter))
    886904          (vars (cdr conser))
    887905          (x (r 'x))
    888906          (y (r 'y))
    889           (%getter-with-setter (r 'getter-with-setter))
    890907          (slotnames (map car slots)))
    891908      `(,%begin
    892909        (,%define ,conser
    893910                  (##sys#make-structure
    894                    ',t
     911                   (,%quote ,t)
    895912                   ,@(map (lambda (sname)
    896913                            (if (memq sname vars)
     
    898915                                '(##core#undefined) ) )
    899916                          slotnames) ) )
    900         (,%define (,pred ,x) (##sys#structure? ,x ',t))
     917        (,%define (,pred ,x) (##sys#structure? ,x (,%quote ,t)))
    901918        ,@(let loop ([slots slots] [i 1])
    902919            (if (null? slots)
     
    906923                       (setr? (pair? (cddr slot)))
    907924                       (getr `(,%lambda (,x)
    908                                         (##core#check (##sys#check-structure ,x ',t))
     925                                        (##core#check (##sys#check-structure ,x (,%quote ,t)))
    909926                                        (##sys#block-ref ,x ,i) ) ) )
    910927                  `(,@(if setr?
    911928                          `((,%define (,(caddr slot) ,x ,y)
    912                                       (##core#check (##sys#check-structure ,x ',t))
     929                                      (##core#check (##sys#check-structure ,x (,%quote ,t)))
    913930                                      (##sys#block-set! ,x ,i ,y)) )
    914931                          '() )
     
    923940
    924941(##sys#extend-macro-environment
    925  'cut '()
     942 'cut
     943 `((apply . (##sys#primitive-alias 'apply)))
    926944 (##sys#er-transformer
    927945  (lambda (form r c)
     
    947965
    948966(##sys#extend-macro-environment
    949  'cute '()
     967 'cute
     968 `((apply . ,(##sys#primitive-alias 'apply)))
    950969 (##sys#er-transformer
    951970  (lambda (form r c)
    952971    (let ((%let (r 'let))
    953972          (%lambda (r 'lambda))
     973          (%apply (r 'apply))
    954974          (%<> (r '<>))
    955           (%<...> (r '<...>))
    956           (%apply (r 'apply)))
     975          (%<...> (r '<...>)))
    957976      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
    958977        (if (null? xs)
     
    10681087
    10691088
    1070 (##sys#macro-subset me0)))
     1089(##sys#macro-subset me0 ##sys#default-macro-environment)))
     1090
     1091;; register features
    10711092
    10721093(eval-when (compile load eval)
  • chicken/trunk/expand.scm

    r15038 r15047  
    345345    (cond ((##sys#current-module) =>
    346346           (lambda (mod)
    347              (dm "(ALIAS) global alias " sym " -> " (module-name mod))
     347             (dm "(ALIAS) global alias " sym " in " (module-name mod))
    348348             (unless assign (##sys#register-undefined sym mod))
    349349             (##sys#module-rename sym (module-name mod))))
     
    10731073            (%if (r 'if))
    10741074            (%or (r 'or))
    1075             (%eqv? '##sys#eqv?)
    10761075            (%else (r 'else)))
    10771076        `(let ((,tmp ,exp))
     
    10851084                        `(,%begin ,@(cdr clause))
    10861085                        `(,%if (,%or ,@(##sys#map
    1087                                         (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
     1086                                        (lambda (x) `(##sys#eqv? ,tmp ',x)) (car clause)))
    10881087                               (,%begin ,@(cdr clause))
    10891088                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
     
    13281327;;; the base macro environment ("scheme", essentially)
    13291328
    1330 (define ##sys#default-macro-environment (##sys#macro-environment))
     1329(define (##sys#macro-subset me0 #!optional parent-env)
     1330  (let ((se (let loop ((me (##sys#macro-environment)))
     1331              (if (or (null? me) (eq? me me0))
     1332                  '()
     1333                  (cons (car me) (loop (cdr me)))))))
     1334    (##sys#fixup-macro-environment se parent-env)))
     1335
     1336(define (##sys#fixup-macro-environment se #!optional parent-env)
     1337  (let ((se2 (if parent-env (##sys#append se parent-env) se)))
     1338    (for-each                           ; fixup se
     1339     (lambda (sdef)
     1340       (when (pair? (cdr sdef))
     1341         (set-car!
     1342          (cdr sdef)
     1343          (if (null? (cadr sdef))
     1344              se2
     1345              (##sys#append (cadr sdef) se2)))))
     1346     se)
     1347    se))
     1348
     1349(define ##sys#default-macro-environment
     1350  (##sys#fixup-macro-environment (##sys#macro-environment)))
    13311351
    13321352
     
    15921612    mod))
    15931613
     1614(define (##sys#primitive-alias sym)
     1615  (let ((palias
     1616         (##sys#string->symbol
     1617          (##sys#string-append "#%" (##sys#slot sym 1)))))
     1618    (##sys#put! palias '##core#primitive sym)
     1619    palias))
     1620
    15941621(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
    15951622  (let* ((me (##sys#macro-environment))
     
    15981625               (map (lambda (ve)
    15991626                      (if (symbol? ve)
    1600                           (let ((palias
    1601                                  (##sys#string->symbol
    1602                                   (##sys#string-append "#%" (##sys#slot ve 1)))))
    1603                             (##sys#put! palias '##core#primitive ve)
    1604                             (cons ve palias))
     1627                          (cons ve (##sys#primitive-alias ve))
    16051628                          ve))
    16061629                    vexports)
     
    17211744
    17221745(define ##sys#module-table '())
    1723 
    1724 (define (##sys#macro-subset me0)
    1725   (let ((se (let loop ((me (##sys#macro-environment)))
    1726               (if (or (null? me) (eq? me me0))
    1727                   '()
    1728                   (cons (car me) (loop (cdr me)))))))
    1729     (for-each                           ; fixup se
    1730      (lambda (sdef)
    1731        (when (pair? (cdr sdef))
    1732          (set-car! (cdr sdef) se)))
    1733      se)
    1734     se))
  • chicken/trunk/library.scm

    r15001 r15047  
    43464346(define ##sys#null? null?)
    43474347(define ##sys#map-n map)
     4348(define ##sys#list-ref list-ref)
    43484349
    43494350
  • chicken/trunk/scheme.import.scm

    r15038 r15047  
    5454       with-output-to-file dynamic-wind values call-with-values eval
    5555       char-ready? imag-part real-part magnitude numerator denominator
    56        scheme-report-environment null-environment interaction-environment)
     56       scheme-report-environment null-environment interaction-environment
     57       else)
    5758 ##sys#default-macro-environment)
  • chicken/trunk/tests/syntax-tests.scm

    r15038 r15047  
    343343;;; (reported by Jack Trades)
    344344
    345 (module prefixed-self-reference (a b c)
     345(module prefixed-self-reference1 (a b c)
    346346  (import scheme (prefix chicken c:))
    347347  (c:define-values (a b c) (values 1 2 3)) )
     348
     349(module prefixed-self-reference2 ()
     350  (import scheme (prefix chicken c:))
     351  (c:define-values (a b c) (values 1 2 3))
     352  (c:print "ok")
     353  (c:condition-case
     354   (c:abort "ugh")
     355   (ex () (c:print "aborted"))))
     356
     357(module prefixed-self-reference3 (a)
     358  (import (prefix scheme s.) (prefix chicken c.))
     359  (s.define (a x y)
     360            (c.condition-case (s.+ x y) ((exn) "not numbers")))
     361  )
     362
     363(module prefixed-self-reference4 (a)
     364  (import (prefix scheme s.))
     365  (s.define (a x y) (s.and x y)))
Note: See TracChangeset for help on using the changeset viewer.