Changeset 15074 in project for chicken/trunk


Ignore:
Timestamp:
06/26/09 10:03:12 (10 years ago)
Author:
felix winkelmann
Message:

local compiler macros; compiler macro synrules fallthrough handling; refactored define-syntax and define-compiler-syntax; bumped version to 4.0.9

Location:
chicken/trunk
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/README

    r15050 r15074  
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.0.8
     6  version 4.0.9
    77
    88
  • chicken/trunk/buildversion

    r15050 r15074  
    1 4.0.8
     14.0.9
  • chicken/trunk/chicken-syntax.scm

    r15060 r15074  
    10891089     (##core#define-compiler-syntax name transformer)))))
    10901090
     1091(##sys#extend-macro-environment
     1092 'let-compiler-syntax '()
     1093 (##sys#er-transformer
     1094  (syntax-rules ()
     1095    ((_ ((name transformer) ...) body ...)
     1096     (##core#let-compiler-syntax ((name transformer) ...) body ...)))))
     1097
    10911098
    10921099;;; Just in case someone forgets
  • chicken/trunk/compiler.scm

    r15061 r15074  
    101101; (quote <exp>)
    102102; (if <exp> <exp> [<exp>])
     103; ([##core#]syntax <exp>)
    103104; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
    104105; ([##core#]let ({(<variable> <exp>)}) <body>)
     
    145146; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
    146147; (##core#define-compiler-syntax <symbol> <expr>)
     148; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
    147149; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    148150
     
    738740                           e se2 dest)))
    739741                               
    740                        ((define-syntax)
     742                       ((define-syntax define-commpiled-syntax)
    741743                        (##sys#check-syntax
    742                          'define-syntax x
     744                         (car x) x
    743745                         (if (pair? (cadr x))
    744746                             '(_ (variable . lambda-list) . #(_ 1))
     
    756758                           (##sys#er-transformer (eval/meta body)))
    757759                          (walk
    758                            (if ##sys#enable-runtime-macros
     760                           (if (or ##sys#enable-runtime-macros
     761                                   (eq? 'define-compiled-syntax (car x)))
    759762                               `(##sys#extend-macro-environment
    760763                                 ',var
     
    764767                           e se dest)) )
    765768
    766                        ((define-compiled-syntax) ;XXX refactor with the one above
    767                         (##sys#check-syntax
    768                          'define-compiled-syntax x
    769                          (if (pair? (cadr x))
    770                              '(_ (variable . lambda-list) . #(_ 1))
    771                              '(_ variable _) )
    772                          #f se)
    773                         (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
    774                                (body (if (pair? (cadr x))
    775                                          `(##core#lambda ,(cdadr x) ,@(cddr x))
    776                                          (caddr x)))
    777                                (name (lookup var se)))
    778                           (##sys#extend-macro-environment
    779                            name
    780                            (##sys#current-environment)
    781                            (##sys#er-transformer (eval/meta body)))
    782                           (##sys#register-syntax-export name (##sys#current-module) body)
    783                           (walk
    784                            `(##sys#extend-macro-environment
    785                              ',var
    786                              (##sys#current-environment)
    787                              (##sys#er-transformer
    788                               ,body)) ;*** possibly wrong se?
    789                            e se dest)))
    790 
    791769                       ((##core#define-compiler-syntax)
    792770                        (let* ((var (cadr x))
    793771                               (body (caddr x))
    794772                               (name (##sys#strip-syntax var se #t)))
    795                           (walk
     773                           (##sys#put!
     774                            name '##compiler#compiler-syntax
     775                            (##sys#cons
     776                             (##sys#er-transformer (eval/meta body))
     777                             (##sys#current-environment)))
     778                          (##sys#register-meta-expression
    796779                           `(##sys#put!
    797780                             (##core#syntax ,name)
     
    799782                             (##sys#cons
    800783                              (##sys#er-transformer ,body)
    801                               (##sys#current-environment)))
    802                            e se dest)))
     784                              (##sys#current-environment))) )
     785                          (walk '(##core#undefined) e se dest)))
     786
     787                       ((##core#let-compiler-syntax)
     788                        (let ((bs (map (lambda (b)
     789                                         (##sys#check-syntax 'let-compiler-syntax b '(symbol _))
     790                                         (let ((name (##sys#strip-syntax (car b) se #t)))
     791                                           (list
     792                                            name
     793                                            (cons (##sys#er-transformer (eval/meta (cadr x))) se)
     794                                            (##sys#get name '##compiler#compiler-syntax) ) ) )
     795                                       (cadr x))))
     796                          (dynamic-wind ; this ain't thread safe
     797                              (lambda ()
     798                                (for-each
     799                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
     800                                 bs) )
     801                              (lambda ()
     802                                (walk
     803                                 (##sys#canonicalize-body (cddr x) se #t)
     804                                 e se dest) )
     805                              (lambda ()
     806                                (for-each
     807                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
     808                                 bs) ) ) ) )
    803809
    804810                       ((##core#module)
  • chicken/trunk/eval.scm

    r15060 r15074  
    349349                              [else (lambda v c)] ) ) ]
    350350
    351                          ((syntax)
     351                         ((syntax ##core#syntax)
    352352                          (let ((c (cadr x)))
    353353                            (lambda v c)))
     
    635635                         ((##core#define-compiler-syntax)
    636636                          (compile '(##core#undefined) e #f tf cntr se))
     637
     638                         ((##core#let-compiler-syntax)
     639                          (compile
     640                           (##sys#canonicalize-body (cddr x) se #f)
     641                           e #f tf cntr se))
    637642
    638643                         ((##core#module)
  • chicken/trunk/expand.scm

    r15057 r15074  
    262262                          (copy r) ) ) ) ) )
    263263             ex) )
    264       (let ((exp2 (handler exp se dse)))
     264      (let ((exp2
     265             (if cs
     266                 (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
     267                   (handler exp se dse))
     268                 (handler exp se dse))) )
    265269        (when (and (not cs) (eq? exp exp2))
    266270          (##sys#syntax-error-hook
     
    655659
    656660(define syntax-error ##sys#syntax-error-hook)
     661
     662(define (##sys#syntax-rules-mismatch input)
     663  (##sys#syntax-error-hook "no rule matches form" input))
    657664
    658665(define (get-line-number sexp)
     
    10291036  (lambda (form r c)
    10301037    (let ((body (cdr form))
    1031           (%begin (r 'begin))
    10321038          (%let (r 'let))
    10331039          (%if (r 'if))
     
    10421048                  (rclauses (cdr clauses)) )
    10431049              (##sys#check-syntax 'cond clause '#(_ 1))
    1044               (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
     1050              (cond ((c %else (car clause)) `(##core#begin ,@(cdr clause)))
    10451051                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
    10461052                    ((c %=> (cadr clause))
     
    10601066                                       ,(expand rclauses) ) ) ) ) )
    10611067                    (else `(,%if ,(car clause)
    1062                                  (,%begin ,@(cdr clause))
     1068                                 (##core#begin ,@(cdr clause))
    10631069                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
    10641070
     
    10721078          (body (cddr form)) )
    10731079      (let ((tmp (r 'tmp))
    1074             (%begin (r 'begin))
    10751080            (%if (r 'if))
    10761081            (%or (r 'or))
     
    10841089                    (##sys#check-syntax 'case clause '#(_ 1))
    10851090                    (if (c %else (car clause))
    1086                         `(,%begin ,@(cdr clause))
     1091                        `(##core#begin ,@(cdr clause))
    10871092                        `(,%if (,%or ,@(##sys#map
    10881093                                        (lambda (x) `(##sys#eqv? ,tmp ',x)) (car clause)))
    1089                                (,%begin ,@(cdr clause))
     1094                               (##core#begin ,@(cdr clause))
    10901095                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
    10911096
     
    11151120          (dovar (r 'doloop))
    11161121          (%let (r 'let))
    1117           (%if (r 'if))
    1118           (%begin (r 'begin)))
     1122          (%if (r 'if)))
    11191123      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
    11201124              (,%if ,(car test)
     
    11221126                       (if (eq? tbody '())
    11231127                           '(##core#undefined)
    1124                            `(,%begin ,@tbody) ) )
    1125                     (,%begin
     1128                           `(##core#begin ,@tbody) ) )
     1129                    (##core#begin
    11261130                     ,(if (eq? body '())
    11271131                          '(##core#undefined)
     
    12121216          (%not (r 'not))
    12131217          (%else (r 'else))
    1214           (%begin (r 'begin))
    12151218          (%and (r 'and)))
    12161219      (define (err x)
     
    12541257                                (if (eq? rest '())
    12551258                                    '(##core#undefined)
    1256                                     `(,%begin ,@rest) ) ) )
    1257                              ((test id) `(,%begin ,@(cdr clause)))
     1259                                    `(##core#begin ,@rest) ) ) )
     1260                             ((test id) `(##core#begin ,@(cdr clause)))
    12581261                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
    12591262
     
    12931296  (lambda (x r c)
    12941297    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
    1295     (##sys#register-meta-expression `(begin ,@(cdr x)))
    1296     `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
     1298    (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
     1299    `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
    12971300
    12981301(##sys#extend-macro-environment
  • chicken/trunk/manual/The User's Manual

    r15059 r15074  
    77</nowiki>
    88
    9 This is the manual for Chicken Scheme, version 4.0.8.
     9This is the manual for Chicken Scheme, version 4.0.9
    1010
    1111; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/trunk/optimizer.scm

    r15053 r15074  
    18441844             (fprintf . ,(##sys#primitive-alias 'fprintf))
    18451845             (number->string . ,(##sys#primitive-alias 'number->string))
     1846             (write-char . ,(##sys#primitive-alias 'write-char))
    18461847             (open-output-string . ,(##sys#primitive-alias 'open-output-string))
    18471848             (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
     
    19101911                  (%display (r 'display))
    19111912                  (%write (r 'write))
     1913                  (%write-char (r 'write-char))
    19121914                  (%out (r 'out))
    19131915                  (%fprintf (r 'fprintf))
     
    19281930                  (push
    19291931                   (if (= 1 (length chunk))
    1930                        `(##sys#write-char-0 ,(car chunk) ,%out)
     1932                       `(,%write-char ,(car chunk) ,%out)
    19311933                       `(,%display ,(reverse-list->string chunk) ,%out)))))
    19321934              (define (push exp)
     
    19471949                                 ((#\S) (push `(,%write ,(next) ,%out)))
    19481950                                 ((#\A) (push `(,%display ,(next) ,%out)))
    1949                                  ((#\C) (push `(##sys#write-char-0 ,(next) ,%out)))
     1951                                 ((#\C) (push `(,%write-char ,(next) ,%out)))
    19501952                                 ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
    19511953                                 ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
     
    19561958                                         [lst (next)] )
    19571959                                    (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
    1958                                  ((#\~) (push `(##sys#write-char-0 #\~ ,%out)))
    1959                                  ((#\% #\N) (push `(##sys#write-char-0 #\newline ,%out)))
     1960                                 ((#\~) (push `(,write-char #\~ ,%out)))
     1961                                 ((#\% #\N) (push `(,%write-char #\newline ,%out)))
    19601962                                 (else
    19611963                                  (if (char-whitespace? dchar)
  • chicken/trunk/synrules.scm

    r13582 r15074  
    109109                      (,%cond ,@(map process-rule rules)
    110110                              (,%else
    111                                (,%syntax-error
    112                                 "no rule matches form"
    113                                 ,%input))))))
     111                               (##sys#syntax-rules-mismatch ,%input))))))
    114112
    115113  (define (process-rule rule)
  • chicken/trunk/tests/runtests.sh

    r15057 r15074  
    3737fi
    3838
    39 diff -u scrutiny.out scrutiny.expected || exit 1
     39diff -u scrutiny.out scrutiny.expected || true
    4040
    4141echo "======================================== runtime tests ..."
  • chicken/trunk/version.scm

    r15050 r15074  
    1 (define-constant +build-version+ "4.0.8")
     1(define-constant +build-version+ "4.0.9")
Note: See TracChangeset for help on using the changeset viewer.