Changeset 15101 in project for chicken


Ignore:
Timestamp:
06/29/09 14:05:33 (10 years ago)
Author:
felix winkelmann
Message:

merged trunk changes from 14491:15100 into prerelease branch

Location:
chicken/branches/prerelease
Files:
61 edited
1 copied

Legend:

Unmodified
Added
Removed
  • chicken/branches/prerelease

  • chicken/branches/prerelease/Makefile

    r14954 r15101  
    8080bench:
    8181        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
    82 scrutiny:
    83         $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) scrutiny
    8482endif
  • chicken/branches/prerelease/Makefile.macosx

    r14954 r15101  
    6363C_COMPILER_OPTIONS += -m64
    6464LINKER_OPTIONS += -m64
     65# Avoid bus error in install_name_tool
     66LINKER_LINK_SHARED_DLOADABLE_OPTIONS += -Wl,-headerpad -Wl,128
    6567else
    6668
  • chicken/branches/prerelease/NEWS

    r14954 r15101  
    1 4.0.1
    2 
    3 - Added `er-macro-transformer'; Low-level syntax definitions should use
    4   this procedure to generate transformers from now on
    5 
    614.0.0
    72
  • chicken/branches/prerelease/batch-driver.scm

    r14954 r15101  
    3535  compiler-arguments process-command-line dump-nodes dump-undefined-globals
    3636  default-standard-bindings default-extended-bindings
    37   foldable-bindings dump-defined-globals apply-pre-cps-rewrite-rules!
     37  foldable-bindings dump-defined-globals
    3838  compiler-cleanup-hook disabled-warnings local-definitions inline-output-file
    3939  file-io-only undefine-shadowed-macros profiled-procedures
     
    4646  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    4747  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    48   broken-constant-nodes inline-substitutions-enabled
     48  broken-constant-nodes inline-substitutions-enabled compiler-syntax-statistics
    4949  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
    5050  direct-call-ids foreign-type-table first-analysis emit-closure-info
     
    351351         initforms
    352352         (map (lambda (r) `(##core#require-extension (,r) #t))
    353               (append se (collect-options 'require-extension)))))
     353              (append se (map string->symbol (collect-options 'require-extension))))))
    354354
    355355      ;; add static-extensions as used units:
     
    486486                         '((##core#undefined))) ] )
    487487
     488             (when (and (pair? compiler-syntax-statistics)
     489                        (debugging 'x "applied compiler syntax:"))
     490               (for-each
     491                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
     492                compiler-syntax-statistics))
    488493             (when (debugging '|N| "real name table:")
    489494               (display-real-name-table) )
     
    497502               (compiler-warning
    498503                'style
    499                 "compiling extensions in unsafe mode is bad practice and should be avoided as it may be surprising to an unsuspecting user") )
     504                "compiling extensions in unsafe mode is bad practice and should be avoided") )
    500505
    501506             (set! ##sys#line-number-database line-number-database-2)
     
    519524                                  (canonicalize-begin-body exps) ) ) ) )
    520525                   (db #f))
     526
     527               (print-node "initial node tree" '|T| node0)
    521528
    522529               (when do-scrutinize
     
    548555                 (print-node "lambda lifted" '|L| node0)
    549556                 (set! first-analysis #t) )
    550 
    551                #;(begin
    552                  (begin-time)
    553                  (set! first-analysis #f)
    554                  (set! db (analyze 'rewrite node0))
    555                  (print-db "analysis" '|0| db 0)
    556                  (end-time "pre-analysis (rewrite)")
    557                  (begin-time)
    558                  (apply-pre-cps-rewrite-rules! node0 db)
    559                  (end-time "applying pre-CPS rewrite rules")
    560                  (print-node "applied pre-CPS rewrite rules" '|R| node0)
    561                  (set! first-analysis #t) )
    562 
     557               
    563558               (let ((req (concatenate (vector->list file-requirements))))
    564559                 (when (debugging 'M "; requirements:")
  • chicken/branches/prerelease/benchmarks/cscbench.scm

    r13240 r15101  
    102102  (system* "echo `csc -cflags`")
    103103  (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)\n")
    104   (display "\n                     (runtime)                      (code size)\n")
     104  (display "\n                     (runtime)                                  (code size)\n")
    105105  (display "\n                     base       fast     unsafe        max      base      fast    unsafe       max")
    106106  (display "\n                  ----------------------------------------------------------------------------------\n")
  • chicken/branches/prerelease/c-platform.scm

    r14954 r15101  
    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/branches/prerelease/chicken-install.scm

    r14954 r15101  
    6363      "csi.import.so"
    6464      "irregex.import.so"
    65       "compiler.import.so"))
     65      "types.db"))
    6666
    6767  (define *program-path*
     
    282282     (if (sudo-install) " -e \"(sudo-install #t)\"" "")
    283283     (if *keep* " -e \"(keep-intermediates #t)\"" "")
    284      (if *no-install* " -e \"(setup-install-flag #f)\"" "")
     284     (if *no-install* " -e \"(setup-install-mode #f)\"" "")
    285285     (if *host-extension* " -e \"(host-extension #t)\"" "")
    286286     (if *prefix* (sprintf " -e \"(installation-prefix \\\"~a\\\")\"" *prefix*) "")
  • chicken/branches/prerelease/chicken-syntax.scm

    r14954 r15101  
    11;;;; chicken-syntax.scm - non-standard syntax extensions
    22;
     3; Copyright (c) 2008-2009, The Chicken Team
    34; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    3333  (fixnum) )
    3434
    35 (##sys#provide 'chicken-more-macros 'chicken-syntax)
     35(##sys#provide
     36 'chicken-more-macros                   ; historical, remove later
     37 'chicken-syntax)
    3638
    3739
     
    4951           (slots (cddr x))
    5052           (prefix (symbol->string name))
     53           (%quote (r 'quote))
    5154           (setters (memq #:record-setters ##sys#features))
    5255           (%begin (r 'begin))
     
    5760          (,%define
    5861           ,(string->symbol (string-append "make-" prefix))
    59            (,%lambda ,slots (##sys#make-structure ',name ,@slots)) )
     62           (,%lambda ,slots (##sys#make-structure (,%quote ,name) ,@slots)) )
    6063          (,%define
    6164           ,(string->symbol (string-append prefix "?"))
     
    7275                         ,setr
    7376                         (,%lambda (x val)
    74                                    (##core#check (##sys#check-structure x ',name))
     77                                   (##core#check (##sys#check-structure x (,%quote ,name)))
    7578                                   (##sys#block-set! x ,i val) ) )
    7679                        (,%define
     
    7982                              `(,%getter-with-setter
    8083                                (,%lambda (x)
    81                                           (##core#check (##sys#check-structure x ',name))
     84                                          (##core#check (##sys#check-structure x (,%quote ,name)))
    8285                                          (##sys#block-ref x ,i) )
    8386                                ,setr)
    8487                              `(,%lambda (x)
    85                                          (##core#check (##sys#check-structure x ',name))
     88                                         (##core#check (##sys#check-structure x (,%quote ,name)))
    8689                                         (##sys#block-ref x ,i) ) ) ) )
    8790                     (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
     
    415418
    416419(##sys#extend-macro-environment
    417  'nth-value '()
     420 'nth-value
     421 `((list-ref . ,(##sys#primitive-alias 'list-ref)))
    418422 (##sys#er-transformer
    419423  (lambda (form r c)
    420424    (##sys#check-syntax 'nth-value form '(_ _ _))
    421425    (let ((v (r 'tmp))
    422           (%list-ref (r 'list-ref))
    423426          (%lambda (r 'lambda)))
    424427      `(##sys#call-with-values
    425428        (,%lambda () ,(caddr form))
    426         (,%lambda ,v (,%list-ref ,v ,(cadr form))))))))
     429        (,%lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
    427430
    428431(##sys#extend-macro-environment
     
    478481          (%else (r 'else))
    479482          (%or (r 'or))
    480           (%eqv? (r 'eqv?))
    481483          (%begin (r 'begin)))
    482484      `(,(r 'let) ((,tmp ,exp))
     
    489491                 (if (c %else (car clause))
    490492                     `(,%begin ,@(cdr clause))
    491                      `(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x))
     493                     `(,%if (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x))
    492494                                         (car clause) ) )
    493495                            (,%begin ,@(cdr clause))
     
    572574
    573575(##sys#extend-macro-environment
    574  'let-optionals '()
     576 'let-optionals
     577 `((car . ,(##sys#primitive-alias 'car))
     578   (cdr . ,(##sys#primitive-alias 'cdr)))
    575579 (##sys#er-transformer
    576580  (lambda (form r c)
     
    579583          (var/defs (caddr form))
    580584          (body (cdddr form))
    581           (%null? (r 'null?))
    582585          (%if (r 'if))
    583586          (%let (r 'let))
    584           (%car (r 'car))
    585           (%cdr (r 'cdr))
    586587          (%lambda (r 'lambda)))
    587588
     
    610611        (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
    611612          (if (null? vars)
    612               `(,%if (##core#check (,%null? ,rest))
     613              `(,%if (##core#check (,(r 'null?) ,rest))
    613614                     (,body-proc . ,(reverse non-defaults))
    614615                     (##sys#error (##core#immutable '"too many optional arguments") ,rest))
     
    616617                `(,%if (null? ,rest)
    617618                       (,(car defaulters) . ,(reverse non-defaults))
    618                        (,%let ((,v (,%car ,rest))
    619                                (,rest (,%cdr ,rest)))
     619                       (,%let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
     620                               (,rest (,(r 'cdr) ,rest)))
    620621                              ,(recur (cdr vars)
    621622                                      (cdr defaulters)
     
    667668
    668669(##sys#extend-macro-environment
    669  'optional '()
     670 'optional
     671 `((null? . ,(##sys#primitive-alias 'null?))
     672   (car . ,(##sys#primitive-alias 'car))
     673   (cdr . ,(##sys#primitive-alias 'cdr)) )
    670674 (##sys#er-transformer
    671675  (lambda (form r c)
    672676    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
    673677    (let ((var (r 'tmp))
    674           (%null? (r 'null?))
    675678          (%if (r 'if)))
    676679      `(,(r 'let) ((,var ,(cadr form)))
    677         (,%if (,%null? ,var)
     680        (,%if (,(r 'null?) ,var)
    678681              ,(optional (cddr form) #f)
    679               (,%if (##core#check (,%null? (,(r 'cdr) ,var)))
     682              (,%if (##core#check (,(r 'null?) (,(r 'cdr) ,var)))
    680683                    (,(r 'car) ,var)
    681684                    (##sys#error
     
    700703
    701704(##sys#extend-macro-environment
    702  'let-optionals* '()
     705 'let-optionals*
     706 `((null? . ,(##sys#primitive-alias 'null?)))
    703707 (##sys#er-transformer
    704708  (lambda (form r c)
     
    708712          (body (cdddr form))
    709713          (%let (r 'let))
    710           (%if (r 'if))
    711714          (%null? (r 'null?))
    712715          (%car (r 'car))
    713           (%cdr (r 'cdr)))
     716          (%cdr (r 'cdr))
     717          (%if (r 'if)))
    714718      (let ((rvar (r 'tmp)))
    715719        `(,%let ((,rvar ,args))
     
    737741
    738742(##sys#extend-macro-environment
    739  '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?)))
    740748 (##sys#er-transformer
    741749  (lambda (form r c)
     
    746754            '()
    747755            (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
    748     (require 'srfi-1)                   ; Urgh...
     756    (require 'srfi-1)                   ; ugh...
    749757    (let* ((mincount (apply min (map (lambda (c)
    750758                                       (##sys#decompose-lambda-list
     
    757765           (%lambda (r 'lambda))
    758766           (%let (r 'let))
     767           (%>= (r '>=))
     768           (%eq? (r 'eq?))
     769           (%car (r 'car))
     770           (%cdr (r 'cdr))
    759771           (%if (r 'if)))
    760772      `(,%lambda ,(append minvars rvar)
     
    770782                                             (if (zero? a2)
    771783                                                 #t
    772                                                  `(,(r '>=) ,lvar ,a2) )
    773                                              `(,(r 'eq?) ,lvar ,a2) ) )
     784                                                 `(,%>= ,lvar ,a2) )
     785                                             `(,%eq? ,lvar ,a2) ) )
    774786                                      ,(receive (vars1 vars2)
    775787                                           (split-at! (take vars argc) mincount)
     
    781793                                                            (else `(,%let () ,@(cdr c))) )
    782794                                                      (let ((vrest2 (r (gensym))))
    783                                                         `(,%let ((,(car vars2) (,(r 'car) ,vrest))
    784                                                                  (,vrest2 (,(r 'cdr) ,vrest)) )
     795                                                        `(,%let ((,(car vars2) (,%car ,vrest))
     796                                                                 (,vrest2 (,%cdr ,vrest)) )
    785797                                                                ,(if (pair? (cdr vars2))
    786798                                                                     (build (cdr vars2) vrest2)
     
    818830
    819831(##sys#extend-macro-environment
    820  '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)))
    821835 (##sys#er-transformer
    822836  (lambda (form r c)
     
    837851
    838852(##sys#extend-macro-environment
    839  'condition-case '()
     853 'condition-case
     854 `((else . ,(##sys#primitive-alias 'else))
     855   (memv . ,(##sys#primitive-alias 'memv)))
    840856 (##sys#er-transformer
    841857  (lambda (form r c)
     
    845861          (%and (r 'and))
    846862          (%let (r 'let))
     863          (%quote (r 'quote))
    847864          (%memv (r 'memv))
    848865          (%else (r 'else)))
     
    856873                     `(,%let ([,var ,exvar]) ,@body)
    857874                     `(,%let () ,@body) ) )
    858               `((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
     875              `((,%and ,kvar ,@(map (lambda (k) `(,%memv (,%quote ,k) ,kvar)) kinds))
    859876                ,(if var
    860877                     `(,%let ([,var ,exvar]) ,@body)
    861878                     `(,%let () ,@body) ) ) ) ) )
    862879      `(,(r 'handle-exceptions) ,exvar
    863         (,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition)
     880        (,%let ([,kvar (,%and (##sys#structure? ,exvar (,%quote condition) )
    864881                              (##sys#slot ,exvar 1))])
    865882               (,(r 'cond) ,@(map parse-clause (cddr form))
     
    871888
    872889(##sys#extend-macro-environment
    873  'define-record-type '()
     890 'define-record-type
     891 `((getter-with-setter . (##sys#primitive-alias 'getter-with-setter)))
    874892 (##sys#er-transformer
    875893  (lambda (form r c)
     
    882900          (%lambda (r 'lambda))
    883901          (%define (r 'define))
     902          (%quote (r 'quote))
     903          (%getter-with-setter (r 'getter-with-setter))
    884904          (vars (cdr conser))
    885905          (x (r 'x))
    886906          (y (r 'y))
    887           (%getter-with-setter (r 'getter-with-setter))
    888907          (slotnames (map car slots)))
    889908      `(,%begin
    890909        (,%define ,conser
    891910                  (##sys#make-structure
    892                    ',t
     911                   (,%quote ,t)
    893912                   ,@(map (lambda (sname)
    894913                            (if (memq sname vars)
     
    896915                                '(##core#undefined) ) )
    897916                          slotnames) ) )
    898         (,%define (,pred ,x) (##sys#structure? ,x ',t))
     917        (,%define (,pred ,x) (##sys#structure? ,x (,%quote ,t)))
    899918        ,@(let loop ([slots slots] [i 1])
    900919            (if (null? slots)
     
    904923                       (setr? (pair? (cddr slot)))
    905924                       (getr `(,%lambda (,x)
    906                                         (##core#check (##sys#check-structure ,x ',t))
     925                                        (##core#check (##sys#check-structure ,x (,%quote ,t)))
    907926                                        (##sys#block-ref ,x ,i) ) ) )
    908927                  `(,@(if setr?
    909928                          `((,%define (,(caddr slot) ,x ,y)
    910                                       (##core#check (##sys#check-structure ,x ',t))
     929                                      (##core#check (##sys#check-structure ,x (,%quote ,t)))
    911930                                      (##sys#block-set! ,x ,i ,y)) )
    912931                          '() )
     
    921940
    922941(##sys#extend-macro-environment
    923  'cut '()
     942 'cut
     943 `((apply . ,(##sys#primitive-alias 'apply)))
    924944 (##sys#er-transformer
    925945  (lambda (form r c)
     
    945965
    946966(##sys#extend-macro-environment
    947  'cute '()
     967 'cute
     968 `((apply . ,(##sys#primitive-alias 'apply)))
    948969 (##sys#er-transformer
    949970  (lambda (form r c)
    950971    (let ((%let (r 'let))
    951972          (%lambda (r 'lambda))
     973          (%apply (r 'apply))
    952974          (%<> (r '<>))
    953           (%<...> (r '<...>))
    954           (%apply (r 'apply)))
     975          (%<...> (r '<...>)))
    955976      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
    956977        (if (null? xs)
     
    10471068
    10481069
    1049 ;;; Just for backwards compatibility
     1070;;; use
    10501071
    10511072(##sys#extend-macro-environment
     
    10571078
    10581079
    1059 ;;;
     1080;;; compiler syntax
     1081
     1082(##sys#extend-macro-environment
     1083 'define-compiler-syntax '()
     1084 (##sys#er-transformer
     1085  (syntax-rules ()
     1086    ((_ (name . llist) body ...)
     1087     (define-compiler-syntax name (lambda llist body ...)))
     1088    ((_ name transformer)
     1089     (##core#define-compiler-syntax name transformer)))))
     1090
     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 ...)))))
    10601097
    10611098
     
    10691106
    10701107
    1071 (##sys#macro-subset me0)))
     1108(##sys#macro-subset me0 ##sys#default-macro-environment)))
     1109
     1110;; register features
    10721111
    10731112(eval-when (compile load eval)
  • chicken/branches/prerelease/chicken.import.scm

    r14954 r15101  
    7777   features
    7878   file-exists?
     79   directory-exists?
    7980   fixnum-bits
    8081   fixnum-precision
     
    203204   warning
    204205   eval-handler
     206   er-macro-transformer
    205207   dynamic-load-libraries
    206208   with-exception-handler)
    207  ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable
     209 ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable that does expansion
  • chicken/branches/prerelease/compiler.scm

    r14954 r15101  
    9191;   ##compiler#unused -> BOOL
    9292;   ##compiler#foldable -> BOOL
    93 ;   ##compiler#rewrite -> PROCEDURE (see `apply-rewrite-rules!')
    9493
    9594; - Source language:
     
    102101; (quote <exp>)
    103102; (if <exp> <exp> [<exp>])
     103; ([##core#]syntax <exp>)
    104104; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
    105105; ([##core#]let ({(<variable> <exp>)}) <body>)
     
    109109; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
    110110; ([##core#]set! <variable> <exp>)
     111; ([##core#]begin <exp> ...)
    111112; (##core#named-lambda <name> <llist> <body>)
    112113; (##core#loop-lambda <llist> <body>)
     
    138139; (##core#require-extension (<id> ...) <bool>)
    139140; (##core#app <exp> {<exp>})
    140 ; (##coresyntax <exp>)
     141; ([##core#]syntax <exp>)
    141142; (<exp> {<exp>})
    142143; (define-syntax <symbol> <expr>)
     
    144145; (define-compiled-syntax <symbol> <expr>)
    145146; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
     147; (##core#define-compiler-syntax <symbol> <expr>)
     148; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
    146149; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    147150
     
    547550             (let* ((name0 (lookup (car x) se))
    548551                    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
    549                     (xexpanded (##sys#expand x se)))
     552                    (xexpanded (##sys#expand x se #t)))
    550553               (cond ((not (eq? x xexpanded))
    551554                      (walk xexpanded e se dest))
     
    568571                                (walk (cadddr x) e se #f) ) ) )
    569572
    570                         ((quote syntax)
     573                        ((quote syntax ##core#syntax)
    571574                         (##sys#check-syntax name x '(_ _) #f se)
    572575                         `(quote ,(##sys#strip-syntax (cadr x))))
     
    620623                                                           (##sys#find-extension
    621624                                                            (##sys#canonicalize-extension-path
    622                                                              id 'require-extension) #f)) ) )
     625                                                             id 'require-extension)
     626                                                            #f)) ) )
    623627                                        (compiler-warning
    624628                                         'ext "extension `~A' is currently not installed" id))
    625                                       `(begin ,exp ,(loop (cdr ids))) ) ) ) )
     629                                      `(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
    626630                            e se dest) ) )
    627631
     
    637641                                     (list alias (walk (cadr b) e se (car b))) )
    638642                                   aliases bindings)
    639                              ,(walk (##sys#canonicalize-body (cddr x) se2)
     643                             ,(walk (##sys#canonicalize-body (cddr x) se2 #t)
    640644                                    (append aliases e)
    641645                                    se2 dest) ) ) )
     
    670674                              (let* ((aliases (map gensym vars))
    671675                                     (se2 (append (map cons vars aliases) se))
    672                                      (body0 (##sys#canonicalize-body obody se2))
     676                                     (body0 (##sys#canonicalize-body obody se2 #t))
    673677                                     (body (walk body0 (append aliases e) se2 #f))
    674678                                     (llist2
     
    714718                                     se) ) )
    715719                           (walk
    716                             (##sys#canonicalize-body (cddr x) se2)
     720                            (##sys#canonicalize-body (cddr x) se2 #t)
    717721                            e se2
    718722                            dest) ) )
     
    733737                           ms)
    734738                          (walk
    735                            (##sys#canonicalize-body (cddr x) se2)
     739                           (##sys#canonicalize-body (cddr x) se2 #t)
    736740                           e se2 dest)))
    737741                               
    738                        ((define-syntax)
     742                       ((define-syntax define-commpiled-syntax)
    739743                        (##sys#check-syntax
    740                          'define-syntax x
     744                         (car x) x
    741745                         (if (pair? (cadr x))
    742746                             '(_ (variable . lambda-list) . #(_ 1))
     
    745749                        (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
    746750                               (body (if (pair? (cadr x))
    747                                          `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
     751                                         `(##core#lambda ,(cdadr x) ,@(cddr x))
    748752                                         (caddr x)))
    749753                               (name (lookup var se)))
     
    754758                           (##sys#er-transformer (eval/meta body)))
    755759                          (walk
    756                            (if ##sys#enable-runtime-macros
     760                           (if (or ##sys#enable-runtime-macros
     761                                   (eq? 'define-compiled-syntax (car x)))
    757762                               `(##sys#extend-macro-environment
    758763                                 ',var
     
    762767                           e se dest)) )
    763768
    764                        ((define-compiled-syntax)
    765                         (##sys#check-syntax
    766                          'define-compiled-syntax x
    767                          (if (pair? (cadr x))
    768                              '(_ (variable . lambda-list) . #(_ 1))
    769                              '(_ variable _) )
    770                          #f se)
    771                         (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
    772                                (body (if (pair? (cadr x))
    773                                          `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
    774                                          (caddr x)))
    775                                (name (lookup var se)))
    776                           (##sys#extend-macro-environment
    777                            name
    778                            (##sys#current-environment)
    779                            (##sys#er-transformer (eval/meta body)))
    780                           (##sys#register-syntax-export name (##sys#current-module) body)
    781                           (walk
    782                            `(##sys#extend-macro-environment
    783                              ',var
    784                              (##sys#current-environment)
    785                              (##sys#er-transformer
    786                               ,body)) ;*** possibly wrong se?
     769                       ((##core#define-compiler-syntax)
     770                        (let* ((var (cadr x))
     771                               (body (caddr x))
     772                               (name (##sys#strip-syntax var se #t)))
     773                          (##sys#put!
     774                           name '##compiler#compiler-syntax
     775                           (##sys#cons
     776                            (##sys#er-transformer (eval/meta body))
     777                            (##sys#current-environment)))
     778                          (walk
     779                           (if ##sys#enable-runtime-macros
     780                               `(##sys#put!
     781                                (##core#syntax ,name)
     782                                '##compiler#compiler-syntax
     783                                (##sys#cons
     784                                 (##sys#er-transformer ,body)
     785                                 (##sys#current-environment)))
     786                               '(##core#undefined) )
    787787                           e se dest)))
     788
     789                       ((##core#let-compiler-syntax)
     790                        (let ((bs (map (lambda (b)
     791                                         (##sys#check-syntax 'let-compiler-syntax b '(symbol _))
     792                                         (let ((name (##sys#strip-syntax (car b) se #t)))
     793                                           (list
     794                                            name
     795                                            (cons (##sys#er-transformer (eval/meta (cadr b))) se)
     796                                            (##sys#get name '##compiler#compiler-syntax) ) ) )
     797                                       (cadr x))))
     798                          (dynamic-wind ; this ain't thread safe
     799                              (lambda ()
     800                                (for-each
     801                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
     802                                 bs) )
     803                              (lambda ()
     804                                (walk
     805                                 (##sys#canonicalize-body (cddr x) se #t)
     806                                 e se dest) )
     807                              (lambda ()
     808                                (for-each
     809                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
     810                                 bs) ) ) ) )
    788811
    789812                       ((##core#module)
     
    814837                                              (cond
    815838                                               ((null? body)
    816                                                 (##sys#finalize-module (##sys#current-module))
     839                                                (handle-exceptions ex
     840                                                    (begin
     841                                                      ;; avoid backtrace
     842                                                      (print-error-message ex (current-error-port))
     843                                                      (exit 1))
     844                                                  (##sys#finalize-module (##sys#current-module)))
    817845                                                (cond ((assq name import-libraries) =>
    818846                                                       (lambda (il)
     
    871899
    872900                       ((##core#named-lambda)
    873                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) e se (cadr x)) )
     901                        (walk `(##core#lambda ,@(cddr x)) e se (cadr x)) )
    874902
    875903                       ((##core#loop-lambda)
     
    880908                               [body
    881909                                (walk
    882                                  (##sys#canonicalize-body obody se2)
     910                                 (##sys#canonicalize-body obody se2 #t)
    883911                                 (append aliases e)
    884912                                 se2 #f) ] )
     
    964992                         '(##core#undefined) )
    965993
    966                         ((begin)
    967                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
     994                        ((begin ##core#begin)
     995                         (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
    968996                         (if (pair? (cdr x))
    969997                             (canonicalize-begin-body
     
    10181046                                    (hide-variable ret)
    10191047                                    (walk
    1020                                      `(,(macro-alias 'begin se)
     1048                                     `(##core#begin
    10211049                                        (define ,arg ,(first conv))
    10221050                                        (define
     
    10601088                                         ("C_a_i_bytevector" ,(+ 2 size))
    10611089                                         ',size)) ) )
    1062                                (,(macro-alias 'begin se)
     1090                               (##core#begin
    10631091                                ,@(if init
    10641092                                      `((##core#set! ,alias ,init))
     
    10851113                                           valexp
    10861114                                           (eval
    1087                                             `(,(macro-alias 'let se)
     1115                                            `(##core#let
    10881116                                              ,defconstant-bindings ,valexp)) ) ) ] )
    10891117                           (set! constants-used #t)
     
    11021130                        ((##core#declare)
    11031131                         (walk
    1104                           `(,(macro-alias 'begin se)
     1132                          `(##core#begin
    11051133                             ,@(map (lambda (d)
    11061134                                      (process-declaration d se))
     
    11291157                               ,(walk `(##core#lambda
    11301158                                        ,vars
    1131                                         (,(macro-alias 'let se)
     1159                                        (##core#let
    11321160                                         ,(let loop ([vars vars] [types atypes])
    11331161                                            (if (null? vars)
     
    11431171                                                   (loop (cdr vars) (cdr types)) ) ) ) )
    11441172                                         ,(foreign-type-convert-argument
    1145                                            `(,(macro-alias 'let se)
     1173                                           `(##core#let
    11461174                                             ()
    11471175                                             ,@(cond
     
    11531181                                                    nonnull-c-string))
    11541182                                                 `((##sys#make-c-string
    1155                                                     (,(macro-alias 'let se)
     1183                                                    (##core#let
    11561184                                                     () ,@(cddr lam)))))
    11571185                                                ((member
     
    11731201                                                    unsigned-c-string
    11741202                                                    (const c-string)) )
    1175                                                  `((,(macro-alias 'let se)
    1176                                                     ((r (,(macro-alias 'let se)
    1177                                                          () ,@(cddr lam))))
     1203                                                 `((##core#let
     1204                                                    ((r (##core#let () ,@(cddr lam))))
    11781205                                                    (,(macro-alias 'and se)
    11791206                                                     r
     
    12321259             (let ([llist (cadr lexp)])
    12331260               (if (and (proper-list? llist) (= (llist-length llist) (length args)))
    1234                    (walk `(,(macro-alias 'let se)
     1261                   (walk `(##core#let
    12351262                           ,(map list llist args) ,@(cddr lexp))
    12361263                         e se dest)
    12371264                   (let ((var (gensym 't)))
    12381265                     (walk
    1239                       `(,(macro-alias 'let se)
     1266                      `(##core#let
    12401267                        ((,var ,(car x)))
    12411268                        (,var ,@(cdr x)) )
     
    12531280  ;; Process visited definitions and main expression:
    12541281  (walk
    1255    `(,(macro-alias 'begin '())
    1256       ,@(let ([p (reverse pending-canonicalizations)])
    1257           (set! pending-canonicalizations '())
    1258           p)
    1259       ,(begin
    1260          (set! extended-bindings (append internal-bindings extended-bindings))
    1261          exp) )
     1282   `(##core#begin
     1283     ,@(let ([p (reverse pending-canonicalizations)])
     1284         (set! pending-canonicalizations '())
     1285         p)
     1286     ,(begin
     1287        (set! extended-bindings (append internal-bindings extended-bindings))
     1288        exp) )
    12621289   '() (##sys#current-environment)
    12631290   #f) )
  • chicken/branches/prerelease/csc.scm

    r14954 r15101  
    392392    -R  -require-extension NAME    require extension and import in compiled
    393393                                    code
    394     -E  -extension                 compile as extension (dynamic or static)
    395394    -dll -library                  compile multiple units into a dynamic
    396395                                    library
  • chicken/branches/prerelease/csi.scm

    r13859 r15101  
    648648             (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
    649649             (let ([code (integer->char x)])
    650                (when (fx< code #x10000) (fprintf out ", character ~S" code)) )
     650               (when (fx< x #x10000) (fprintf out ", character ~S" code)) )
    651651             (##sys#write-char-0 #\newline ##sys#standard-output) ]
    652652            [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
     
    845845        '()
    846846        (let ((x (car args)))
    847           (cond ((member x '("-s" "-ss" "-script" "--")) args)
     847          (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)
    848848                ((and (fx> (##sys#size x) 2)
    849849                       (char=? #\- (##core#inline "C_subchar" x 0))
  • chicken/branches/prerelease/defaults.make

    r14954 r15101  
    282282CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
    283283ifdef DEBUGBUILD
    284 CHICKEN_OPTIONS += -feature debugbuild
     284CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
    285285endif
    286286CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
    287287CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    288288CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
    289 CHICKEN_SCRUTINY_OPTIONS = -types $(SRCDIR)types.db -analyze-only -scrutinize -ignore-repository
    290289CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
    291290CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
  • chicken/branches/prerelease/distribution/manifest

    r14954 r15101  
    218218tests/test-finalizers-2.scm
    219219tests/module-tests-compiled.scm
     220tests/scrutiny-tests.scm
     221tests/scrutiny.expected
    220222tests/syntax-tests.scm
    221223tests/syntax-tests-2.scm
     
    235237tests/lolevel-tests.scm
    236238tests/feeley-dynwind.scm
     239tests/compiler-syntax-tests.scm
    237240tweaks.scm
    238241utils.scm
  • chicken/branches/prerelease/eval.scm

    r14954 r15101  
    327327              [(symbol? (##sys#slot x 0))
    328328               (emit-syntax-trace-info tf x cntr)
    329                (let ((x2 (##sys#expand x se)))
     329               (let ((x2 (##sys#expand x se #f)))
    330330                 (d `(EVAL/EXPANDED: ,x2))
    331331                 (if (not (eq? x2 x))
     
    349349                              [else (lambda v c)] ) ) ]
    350350
    351                          ((syntax)
     351                         ((syntax ##core#syntax)
    352352                          (let ((c (cadr x)))
    353353                            (lambda v c)))
     
    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
     
    426426                                 (se2 (append (map cons vars aliases) se))
    427427                                 [body (##sys#compile-to-closure
    428                                         (##sys#canonicalize-body (cddr x) se2)
     428                                        (##sys#canonicalize-body (cddr x) se2 #f)
    429429                                        e2
    430430                                        se2
     
    502502                                      (body
    503503                                       (##sys#compile-to-closure
    504                                         (##sys#canonicalize-body body se2)
     504                                        (##sys#canonicalize-body body se2 #f)
    505505                                        e2
    506506                                        se2
     
    591591                                      se) ) )
    592592                            (compile
    593                              (##sys#canonicalize-body (cddr x) se2)
     593                             (##sys#canonicalize-body (cddr x) se2 #f)
    594594                             e #f tf cntr se2)))
    595595                               
     
    609609                             ms)
    610610                            (compile
    611                              (##sys#canonicalize-body (cddr x) se2)
     611                             (##sys#canonicalize-body (cddr x) se2 #f)
    612612                             e #f tf cntr se2)))
    613613                               
     
    632632                             (##sys#er-transformer (eval/meta body)))
    633633                            (compile '(##core#undefined) e #f tf cntr se) ) )
     634
     635                         ((##core#define-compiler-syntax)
     636                          (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))
    634642
    635643                         ((##core#module)
     
    10871095
    10881096(define ##sys#find-extension
    1089   (let ([file-exists? file-exists?]
    1090         [string-append string-append] )
     1097  (let ((file-exists? file-exists?)
     1098        (string-append string-append) )
    10911099    (lambda (p inc?)
    10921100      (let ((rp (##sys#repository-path)))
    10931101        (define (check path)
    1094           (let ([p0 (string-append path "/" p)])
     1102          (let ((p0 (string-append path "/" p)))
    10951103            (and (or (and rp
    10961104                          (not ##sys#dload-disabled)
     
    10991107                     (file-exists? (##sys#string-append p0 source-file-extension)) )
    11001108                 p0) ) )
    1101           (let loop ([paths (##sys#append
    1102                              (if rp (list rp) '("."))
    1103                              (if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
     1109          (let loop ((paths (##sys#append
     1110                             (if rp (list rp) '())
     1111                             (if inc? ##sys#include-pathnames '())
     1112                             '("."))) )
    11041113            (and (pair? paths)
    1105                  (let ([pa (##sys#slot paths 0)])
     1114                 (let ((pa (##sys#slot paths 0)))
    11061115                   (or (check pa)
    11071116                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
     
    11921201           (lambda () (list id)))))
    11931202      (define (impform x id builtin?)
    1194         `(begin
     1203        `(##core#begin
    11951204           ,x
    11961205           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
    1197                  `((import ,id))
     1206                 `((import ,id))        ;XXX make hygienic
    11981207                 '())))
    11991208      (define (doit id)
     
    12081217                 (if comp?
    12091218                     `(##core#declare (uses ,id))
    1210                      `(load-library ',id) )
     1219                     `(##sys#load-library ',id #f) )
    12111220                 id #t)
    12121221                #t) )
     
    12151224                      (s (assq 'syntax info)))
    12161225                 (values
    1217                   `(begin
     1226                  `(##core#begin
    12181227                     ,@(if s `((##core#require-for-syntax ',id)) '())
    12191228                     ,(impform
    12201229                       (if comp?
    12211230                           `(##core#declare (uses ,id))
    1222                            `(load-library ',id) )
     1231                           `(##sys#load-library ',id #f) )
    12231232                       id #f))
    12241233                  #t) ) )
     
    12311240                          (values
    12321241                           (impform
    1233                             `(begin
     1242                            `(##core#begin
    12341243                               ,@(if s `((##core#require-for-syntax ',id)) '())
    12351244                               ,@(if (and (not rr) s)
     
    12581267                                    (f #f) )
    12591268                           (if (null? specs)
    1260                                (values `(begin ,@(reverse exps)) f)
     1269                               (values `(##core#begin ,@(reverse exps)) f)
    12611270                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
    12621271                                 (loop (cdr specs)
  • chicken/branches/prerelease/expand.scm

    r14954 r15101  
    3131  (hide match-expression
    3232        macro-alias module-indirect-exports
    33         d dd dm map-se merge-se
     33        d dd dm dc map-se merge-se
    3434        lookup check-for-redef) )
    3535
     
    4646(define dd d)
    4747(define dm d)
     48(define dc d)
    4849
    4950(cond-expand
    5051 ((not debugbuild)
    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))))))
     52  (declare
     53    (no-bound-checks)
     54    (no-procedure-checks)))
    5755 (else))
     56
     57(begin
     58  (define-syntax dd (syntax-rules () ((_ . _) (void))))
     59  (define-syntax dm (syntax-rules () ((_ . _) (void))))
     60  (define-syntax dc (syntax-rules () ((_ . _) (void)))) )
    5861
    5962
     
    228231;; The basic macro-expander
    229232
    230 (define (##sys#expand-0 exp dse)
    231   (define (call-handler name handler exp se)
     233(define (##sys#expand-0 exp dse cs?)
     234  (define (call-handler name handler exp se cs)
    232235    (dd "invoking macro: " name)
    233236    (dd `(STATIC-SE: ,@(map-se se)))
     
    259262                          (copy r) ) ) ) ) )
    260263             ex) )
    261       (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))) )
     269        (when (and (not cs) (eq? exp exp2))
     270          (##sys#syntax-error-hook
     271           (string-append
     272            "syntax transformer for `" (symbol->string name)
     273            "' returns original form, which would result in endless expansion")
     274           exp))
    262275        (dd `(,name --> ,exp2))
    263276        exp2)))
     
    277290           (values
    278291            ;; force ref. opaqueness by passing dynamic se  [what is this comment meaning? I forgot]
    279             (call-handler head (cadr mdef) exp (car mdef))
     292            (call-handler head (cadr mdef) exp (car mdef) #f)
    280293            #t))
    281294          (else (values exp #f)) ) )
    282   (if (pair? exp)
     295  (let loop ((exp exp))
     296    (if (pair? exp)
    283297      (let ((head (car exp))
    284298            (body (cdr exp)) )
     
    290304                     (##sys#check-syntax 'let body '#(_ 2) #f dse)
    291305                     (let ([bindings (car body)])
    292                        (cond [(symbol? bindings)
     306                       (cond [(symbol? bindings) ; expand named let
    293307                              (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
    294308                              (let ([bs (cadr body)])
     
    301315                                 #t) ) ]
    302316                             [else (values exp #f)] ) ) ]
    303                     [(and (memq head2 '(set! ##core#set!))
     317                    [(and (memq head2 '(set! ##core#set!)) ; "setter" syntax
    304318                          (pair? body)
    305319                          (pair? (car body)) )
     
    311325                                (cdr body) )
    312326                        #t) ) ]
     327                    ((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
     328                     (lambda (cs)
     329                       (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
     330                         (cond ((eq? result exp) (expand head exp head2))
     331                               (else
     332                                (when ##sys#compiler-syntax-hook
     333                                  (##sys#compiler-syntax-hook head result))
     334                                (loop result))))))
    313335                    [else (expand head exp head2)] ) )
    314336            (values exp #f) ) )
    315       (values exp #f) ) )
    316 
     337      (values exp #f) ) ) )
     338
     339(define ##sys#compiler-syntax-hook #f)
    317340(define ##sys#enable-runtime-macros #f)
    318341
     
    328351    (cond ((##sys#current-module) =>
    329352           (lambda (mod)
    330              (dm "(ALIAS) global alias " sym " -> " (module-name mod))
     353             (dm "(ALIAS) global alias " sym " in " (module-name mod))
    331354             (unless assign (##sys#register-undefined sym mod))
    332355             (##sys#module-rename sym (module-name mod))))
     
    352375;;; User-level macroexpansion
    353376
    354 (define (##sys#expand exp #!optional (se (##sys#current-environment)))
     377(define (##sys#expand exp #!optional (se (##sys#current-environment)) cs?)
    355378  (let loop ((exp exp))
    356     (let-values (((exp2 m) (##sys#expand-0 exp se)))
     379    (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
    357380      (if m
    358381          (loop exp2)
     
    482505  (let ([reverse reverse]
    483506        [map map] )
    484     (lambda (body #!optional (se (##sys#current-environment)))
     507    (lambda (body #!optional (se (##sys#current-environment)) cs?)
    485508      (define (fini vars vals mvars mvals body)
    486509        (if (and (null? vars) (null? mvars))
     
    488511              (if (not (pair? body2))
    489512                  (cons
    490                    (macro-alias 'begin se)
     513                   '##core#begin
    491514                   body) ; no more defines, otherwise we would have called `expand'
    492515                  (let ([x (car body2)])
     
    497520                                        (eq? (or (lookup d se) d) 'define-values)))) )
    498521                        (cons
    499                          (macro-alias 'begin se)
     522                         '##core#begin
    500523                         (##sys#append (reverse exps) (list (expand body2))))
    501524                        (loop (cdr body2) (cons x exps)) ) ) ) )
     
    569592                                               (##sys#expand-curried-define head (cddr x) se))) ]
    570593                                 [else
    571                                   (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
     594                                  (##sys#check-syntax
     595                                   'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
    572596                                  (loop rest
    573597                                        (cons (car head) vars)
     
    586610                       (fini vars vals mvars mvals body))
    587611                      [else
    588                        (let ([x2 (##sys#expand-0 x se)])
     612                       (let ([x2 (##sys#expand-0 x se cs?)])
    589613                         (if (eq? x x2)
    590614                             (fini vars vals mvars mvals body)
     
    636660
    637661(define syntax-error ##sys#syntax-error-hook)
     662
     663(define (##sys#syntax-rules-mismatch input)
     664  (##sys#syntax-error-hook "no rule matches form" input))
    638665
    639666(define (get-line-number sexp)
     
    10101037  (lambda (form r c)
    10111038    (let ((body (cdr form))
    1012           (%begin (r 'begin))
    10131039          (%let (r 'let))
    10141040          (%if (r 'if))
     
    10231049                  (rclauses (cdr clauses)) )
    10241050              (##sys#check-syntax 'cond clause '#(_ 1))
    1025               (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
     1051              (cond ((c %else (car clause)) `(##core#begin ,@(cdr clause)))
    10261052                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
    10271053                    ((c %=> (cadr clause))
     
    10411067                                       ,(expand rclauses) ) ) ) ) )
    10421068                    (else `(,%if ,(car clause)
    1043                                  (,%begin ,@(cdr clause))
     1069                                 (##core#begin ,@(cdr clause))
    10441070                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
    10451071
     
    10531079          (body (cddr form)) )
    10541080      (let ((tmp (r 'tmp))
    1055             (%begin (r 'begin))
    10561081            (%if (r 'if))
    10571082            (%or (r 'or))
    1058             (%eqv? '##sys#eqv?)
    10591083            (%else (r 'else)))
    10601084        `(let ((,tmp ,exp))
     
    10661090                    (##sys#check-syntax 'case clause '#(_ 1))
    10671091                    (if (c %else (car clause))
    1068                         `(,%begin ,@(cdr clause))
     1092                        `(##core#begin ,@(cdr clause))
    10691093                        `(,%if (,%or ,@(##sys#map
    1070                                         (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
    1071                                (,%begin ,@(cdr clause))
     1094                                        (lambda (x) `(##sys#eqv? ,tmp ',x)) (car clause)))
     1095                               (##core#begin ,@(cdr clause))
    10721096                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
    10731097
     
    10971121          (dovar (r 'doloop))
    10981122          (%let (r 'let))
    1099           (%if (r 'if))
    1100           (%begin (r 'begin)))
     1123          (%if (r 'if)))
    11011124      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
    11021125              (,%if ,(car test)
     
    11041127                       (if (eq? tbody '())
    11051128                           '(##core#undefined)
    1106                            `(,%begin ,@tbody) ) )
    1107                     (,%begin
     1129                           `(##core#begin ,@tbody) ) )
     1130                    (##core#begin
    11081131                     ,(if (eq? body '())
    11091132                          '(##core#undefined)
     
    11941217          (%not (r 'not))
    11951218          (%else (r 'else))
    1196           (%begin (r 'begin))
    11971219          (%and (r 'and)))
    11981220      (define (err x)
     
    12361258                                (if (eq? rest '())
    12371259                                    '(##core#undefined)
    1238                                     `(,%begin ,@rest) ) ) )
    1239                              ((test id) `(,%begin ,@(cdr clause)))
     1260                                    `(##core#begin ,@rest) ) ) )
     1261                             ((test id) `(##core#begin ,@(cdr clause)))
    12401262                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
    12411263
     
    12751297  (lambda (x r c)
    12761298    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
    1277     (##sys#register-meta-expression `(begin ,@(cdr x)))
    1278     `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
     1299    (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
     1300    `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
    12791301
    12801302(##sys#extend-macro-environment
     
    13111333;;; the base macro environment ("scheme", essentially)
    13121334
    1313 (define ##sys#default-macro-environment (##sys#macro-environment))
     1335(define (##sys#macro-subset me0 #!optional parent-env)
     1336  (let ((se (let loop ((me (##sys#macro-environment)))
     1337              (if (or (null? me) (eq? me me0))
     1338                  '()
     1339                  (cons (car me) (loop (cdr me)))))))
     1340    (##sys#fixup-macro-environment se parent-env)))
     1341
     1342(define (##sys#fixup-macro-environment se #!optional parent-env)
     1343  (let ((se2 (if parent-env (##sys#append se parent-env) se)))
     1344    (for-each                           ; fixup se
     1345     (lambda (sdef)
     1346       (when (pair? (cdr sdef))
     1347         (set-car!
     1348          (cdr sdef)
     1349          (if (null? (cadr sdef))
     1350              se2
     1351              (##sys#append (cadr sdef) se2)))))
     1352     se)
     1353    se))
     1354
     1355(define ##sys#default-macro-environment
     1356  (##sys#fixup-macro-environment (##sys#macro-environment)))
    13141357
    13151358
     
    15751618    mod))
    15761619
     1620(define (##sys#primitive-alias sym)
     1621  (let ((palias
     1622         (##sys#string->symbol
     1623          (##sys#string-append "#%" (##sys#slot sym 1)))))
     1624    (##sys#put! palias '##core#primitive sym)
     1625    palias))
     1626
    15771627(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
    15781628  (let* ((me (##sys#macro-environment))
     
    15811631               (map (lambda (ve)
    15821632                      (if (symbol? ve)
    1583                           (let ((palias
    1584                                  (##sys#string->symbol
    1585                                   (##sys#string-append "#%" (##sys#slot ve 1)))))
    1586                             (##sys#put! palias '##core#primitive ve)
    1587                             (cons ve palias))
     1633                          (cons ve (##sys#primitive-alias ve))
    15881634                          ve))
    15891635                    vexports)
     
    17041750
    17051751(define ##sys#module-table '())
    1706 
    1707 (define (##sys#macro-subset me0)
    1708   (let loop ((me (##sys#macro-environment)))
    1709     (if (or (null? me) (eq? me me0))
    1710         '()
    1711         (cons (car me) (loop (cdr me))))))
  • chicken/branches/prerelease/library.scm

    r14954 r15101  
    19671967    (lambda (name)
    19681968      (and (##sys#file-info (##sys#platform-fixup-pathname name)) name) )
     1969    #:exists?) )
     1970
     1971(define (directory-exists? name)
     1972  (##sys#check-string name 'directory-exists?)
     1973  (##sys#pathname-resolution
     1974    name
     1975    (lambda (name)
     1976      (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name))))
     1977        (eq? 1 (vector-ref info 4))
     1978        name))
    19691979    #:exists?) )
    19701980
     
    43364346(define ##sys#null? null?)
    43374347(define ##sys#map-n map)
     4348(define ##sys#list-ref list-ref)
    43384349
    43394350
  • chicken/branches/prerelease/manual/Acknowledgements

    r14954 r15101  
    1515Egesund, Steve Elkins, Daniel B. Faken, Will Farr, Graham Fawcett,
    1616Marc Feeley, Fizzie, Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones,
    17 Martin Gasbichler, Joey Gibson, Stephen C. Gilardi, Joshua Griffith,
    18 Johannes Groedem, Damian Gryski, Mario Domenech Goulart, Andreas
    19 Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino, Ahdi Hargo,
    20 Matthias Heiler, Karl M. Hegbloom, William P. Heinemann, Bill Hoffman,
    21 Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz Isenmann, Paulo
    22 Jabardo, Wietse Jacobs, David Janssens, Christian Jaeger, Matt Jones,
    23 Dale Jordan, Valentin Kamyshenko, Daishi Kato, Peter Keller, Brad
    24 Kind, Ron Kneusel, Matthias Koeppe, Krysztof Kowa&#322;czyk, Andre
    25 Kuehne, Todd R. Kueny Sr, Goran Krampe, David Krentzlin, Ben Kurtz,
    26 Micky Latowicki, John Lenz, Kirill Lisovsky, Juergen Lorenz, Kon
    27 Lovett, Lam Luu, Leonardo Valeri Manera, Dennis Marti, Charles Martin,
    28 Bob McIsaac, Alain Mellan, Eric Merrit, Perry Metzger, Scott
    29 G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric E. Moore,
    30 Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby, o.t., Gene
    31 Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita, Robin Lee
    32 Powell, Pupeno, Davide Puricelli, presto, Doug Quale, Eric Raible,
    33 Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman, David
    34 Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
     17Martin Gasbichler, Abdulaziz Ghuloum, Joey Gibson, Stephen C. Gilardi,
     18Mario Domenech Goulart, Joshua Griffith, Johannes Groedem, Damian
     19Gryski, Andreas Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino,
     20Ahdi Hargo, Matthias Heiler, Karl M. Hegbloom, William P. Heinemann,
     21Bill Hoffman, Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz
     22Isenmann, Paulo Jabardo, Wietse Jacobs, David Janssens, Christian
     23Jaeger, Matt Jones, Dale Jordan, Valentin Kamyshenko, Daishi Kato,
     24Peter Keller, Brad Kind, Ron Kneusel, Matthias Koeppe, Krysztof
     25Kowa&#322;czyk, Andre Kuehne, Todd R. Kueny Sr, Goran Krampe, David
     26Krentzlin, Ben Kurtz, Micky Latowicki, John Lenz, Kirill Lisovsky,
     27Juergen Lorenz, Kon Lovett, Lam Luu, Leonardo Valeri Manera, Dennis
     28Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit, Perry
     29Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric
     30E. Moore, Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby,
     31o.t., Gene Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita,
     32Robin Lee Powell, Pupeno, Davide Puricelli, presto, Doug Quale, Eric
     33Raible, Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman,
     34David Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
    3535Samograd, Reed Sheridan, Ronald Schroeder, Spencer Schumann, Ivan
    3636Shcheklein, Alex Shinn, Ivan Shmakov, Shmul, Tony Sidaway, Jeffrey
     
    6666; Olin Shivers : implementation of {{let-optionals[*]}} and reference implementations of SRFI-1, SRFI-13 and SRFI-14.
    6767; Andrew Wilcox : queues.
    68 ; [[http://chicken.wiki.br/Alex Shinn|Alex Shinn]] : {{scheme-complete.el}} emacs tab-completion
     68; [[http://chicken.wiki.br/users/Alex-Shinn|Alex Shinn]] : {{scheme-complete.el}} emacs tab-completion
    6969
    7070The documentation and examples for explicit renaming macros was taken from
  • chicken/branches/prerelease/manual/Callbacks

    r14954 r15101  
    2121do not capture the lexical environment.
    2222
    23 Non-local exits leaving the scope of the invocation of a callback from
    24 Scheme into C will not remove the C call-frame from the stack (and
    25 will result in a memory leak).  '''Note:''' The same applies to
     23Non-local exits leaving the scope of the invocation of a callback from Scheme into C
     24will not remove the C call-frame from the stack (and will result in a memory
     25leak).  '''Note:''' The same applies to
    2626SRFI-18 threading, which is implemented with {{call/cc}};
    2727additionally, if you enter one callback, switch threads and then exit
  • chicken/branches/prerelease/manual/Data representation

    r13859 r15101  
    33== Data representation
    44
    5 ''Note: In all cases below, bits are numbered starting
    6 at 1 and beginning with the lowest-order bit.''
     5''Note: In all cases below, bits are numbered starting at 1 and beginning with the lowest-order bit.''
    76
    87There exist two different kinds of data objects in the CHICKEN system:
  • chicken/branches/prerelease/manual/Deviations from the standard

    r13859 r15101  
    2929      (set! y tmp2)
    3030      (cons x y) ) )
    31 
    32 [4.3] {{syntax-rules}} macros are not provided but available
    33 separately.
    3431
    3532[6.1] {{equal?}} compares all structured data recursively, while R5RS
  • chicken/branches/prerelease/manual/Extensions

    r13859 r15101  
    270270
    271271
    272 ==== setup-install-flag
    273 
    274  [parameter] (setup-install-flag [BOOL])
     272==== setup-install-mode
     273
     274 [parameter] (setup-install-mode [BOOL])
    275275
    276276Reflects the setting of the {{-no-install}} option, i.e. is {{#f}}, if {{-no-install}} was
  • chicken/branches/prerelease/manual/Modules and macros

    r14954 r15101  
    1818Defines a macro named {{IDENTIFIER}} that will transform an expression
    1919with {{IDENTIFIER}} in operator position according to {{TRANSFORMER}}.
    20 The transformer expression must be an instance of
    21 {{er-macro-transformer}}, called with a procedure of three arguments,
    22 or a {{syntax-rules}} form. If {{syntax-rules}} is used, the usual
    23 R5RS semantics apply. If {{TRANSFORMER}} is an instance of
    24 {{er-macro-transformer}}, then it will be called on expansion with the
    25 complete s-expression of the macro invocation, a rename procedure that
    26 hygienically renames identifiers and a comparison procedure that
    27 compares (possibly renamed) identifiers.
     20The transformer expression must be a procedure with three arguments or
     21a {{syntax-rules}} form. If {{syntax-rules}} is used, the usual R5RS
     22semantics apply. If {{TRANSFORMER}} is a procedure, then it will
     23be called on expansion with the complete s-expression of the macro
     24invocation, a rename procedure that hygienically renames identifiers
     25and a comparison procedure that compares (possibly renamed) identifiers.
    2826
    2927{{define-syntax}} may be used to define local macros that are visible
     
    4745argument to the {{syntax-rules}} form.
    4846
    49 The alternative syntax
    50 
    51   (define-syntax (foo . LAMBDALIST) BODY ...)
    52 
    53 is also allowed and is equivalent to
    54 
    55   (define-syntax foo
    56     (er-macro-transformer
    57       (lambda LAMBDALIST BODY ...)))
    58 
    59 ==== er-macro-transformer
    60 
    61   [procedure] (er-macro-transformer PROCEDURE)
    62 
    63 Takes a low-level transformer procedure and returns an explicit renaming
    64 syntax transformer. The canonical method of defining a low-level macro is
    65 
    66   (define-syntax foo
    67     (er-macro-transformer
    68       (lambda (exp rename compare)
    69         ...)))
     47The effect of destructively modifying the s-expression passed to a
     48transformer procedure is undefined.
     49
    7050
    7151==== define-compiled-syntax
     
    9676
    9777The low-level macro facility that CHICKEN provides is called "explicit
    98 renaming" and allows writing hygienic or non-hygienic macros
    99 procedurally.  When given a macro-transformer returned by
    100 {{er-macro-transformer}} instead of a {{syntax-rules}} form,
    101 {{define-syntax}} evaluates the procedure given to it in a distinct
    102 expansion environment (initially having access to the exported
    103 identifiers of the {{scheme}} module). The procedure takes an
    104 expression and two other arguments and returns a transformed
    105 expression.
    106 
    107 For example, the transformation procedure for a {{call}} macro such
    108 that {{(call proc arg ...)}} expands into {{(proc arg ...)}} can be
    109 written as
     78renaming" and allows writing hygienic or non-hygienic macros procedurally.
     79When given a lambda-expression instead of a {{syntax-rules}} form,
     80{{define-syntax}} evaluates the procedure in a distinct expansion
     81environment (initially having access to the exported identifiers
     82of the {{scheme}} module). The procedure takes an expression and two
     83other arguments and returns a transformed expression.
     84
     85For example, the transformation
     86procedure for a {{call}} macro such that
     87{{(call proc arg ...)}} expands
     88into {{(proc arg ...)}} can be written as
    11089
    11190  (lambda (exp rename compare)
    11291    (cdr exp))
    11392
    114 Expressions are represented as lists in the traditional manner, except
    115 that identifiers are represented as special uninterned symbols.
    116 
    117 The second argument to a transformation procedure is a renaming
    118 procedure that takes the representation of an identifier as its
    119 argument and returns the representation of a fresh identifier that
    120 occurs nowhere else in the program.  For example, the transformation
    121 procedure for a simplified version of the {{let}} macro might be
    122 written as
     93Expressions are represented as lists in the traditional manner,
     94except that identifiers are represented as special uninterned symbols.
     95
     96The second argument to a transformation procedure is a renaming procedure that
     97takes the representation of an identifier as its argument and returns the
     98representation of a fresh identifier that occurs nowhere else in the
     99program.  For example, the transformation procedure for a simplified
     100version of the {{let}} macro might be written as
    123101
    124102  (lambda (exp rename compare)
     
    129107        ,@inits)))
    130108
    131 This would not be hygienic, however.  A hygienic {{let}} macro must
    132 rename the identifier {{lambda}} to protect it from being captured by
    133 a local binding.  The renaming effectively creates an fresh alias for
    134 {{lambda}}, one that cannot be captured by any subsequent binding:
     109This would not be hygienic, however.  A
     110hygienic {{let}} macro must rename the identifier {{lambda}} to protect it
     111from being captured by a local binding.  The renaming effectively
     112creates a fresh alias for {{lambda}}, one that cannot be captured by
     113any subsequent binding:
    135114
    136115  (lambda (exp rename compare)
     
    161140in the syntactic environment that will be used to expand the
    162141transformed macro application.  For example, the transformation
    163 procedure for a simplified version of the {{cond}} macro can be
    164 written as
     142procedure for a simplified version of the {{cond}} macro can be written
     143as
    165144
    166145  (lambda (exp rename compare)
     
    184163thing in the syntactic environment of the expression being transformed
    185164as {{else}} denotes in the syntactic environment in which the {{cond}}
    186 macro was defined.  If {{else}} were not renamed before being passed
    187 to the comparison predicate, then it would match a local variable that
     165macro was defined.  If {{else}} were not renamed before being passed to
     166the comparison predicate, then it would match a local variable that
    188167happened to be named {{else}}, and the macro would not be hygienic.
    189168
    190 Some macros are non-hygienic by design.  For example, the following
    191 defines a {{loop}} macro that implicitly binds {{exit}} to an escape
    192 procedure.  The binding of {{exit}} is intended to capture free
     169Some macros are non-hygienic by design.  For example, the
     170following defines a {{loop}} macro that implicitly binds {{exit}} to an
     171escape procedure.  The binding of {{exit}} is intended to capture free
    193172references to {{exit}} in the body of the loop, so {{exit}} is not
    194173renamed.
    195174
    196175  (define-syntax loop
    197     (er-macro-transformer
    198       (lambda (x r c)
    199         (let ((body (cdr x)))
    200           `(,(r 'call-with-current-continuation)
    201             (,(r 'lambda) (exit)
    202              (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
     176     (lambda (x r c)
     177       (let ((body (cdr x)))
     178         `(,(r 'call-with-current-continuation)
     179           (,(r 'lambda) (exit)
     180            (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
    203181
    204182Suppose a {{while}} macro is implemented using {{loop}}, with the intent
     
    207185
    208186  (define-syntax while
    209     (er-macro-transformer
    210       (syntax-rules ()
    211         ((while test body ...)
    212          (loop (if (not test) (exit #f))
    213                body ...)))))
     187    (syntax-rules ()
     188      ((while test body ...)
     189       (loop (if (not test) (exit #f))
     190             body ...))))
    214191
    215192because the reference to {{exit}} that is inserted by the {{while}} macro
     
    219196
    220197  (define-syntax while
    221     (er-macro-transformer
    222       (lambda (x r c)
    223         (let ((test (cadr x))
    224               (body (cddr x)))
    225           `(,(r 'loop)
    226             (,(r 'if) (,(r 'not) ,test) (exit #f))
    227             ,@body)))))
     198     (lambda (x r c)
     199       (let ((test (cadr x))
     200             (body (cddr x)))
     201         `(,(r 'loop)
     202           (,(r 'if) (,(r 'not) ,test) (exit #f))
     203           ,@body))))
    228204
    229205
  • chicken/branches/prerelease/manual/The User's Manual

    r14986 r15101  
    11[[tags:manual]]
    22
    3 [[image:http://www.call-with-current-continuation.org/chicken4.png]]
     3== The CHICKEN User's Manual
    44
    5 == The CHICKEN User's Manual
     5<nowiki>
     6<img style="float:right; border-left:1px solid #ccc;border-bottom:1px solid #ccc;margin-left:1em;" src="http://www.call-with-current-continuation.org/chicken4.png" alt="Stylized picture of a chicken"/>
     7</nowiki>
    68
    79This is the user's manual for the Chicken Scheme compiler, version 4.1.0rc1
     
    2325; [[Data representation]] : How Scheme data is internally represented.
    2426
    25 ; [[Bugs and limitations]] : Yes, there are some.
     27; [[Bugs and limitations]] : Things that do not work yet.
    2628
    27 ; [[FAQ]] : A list of Frequently Asked Questions about CHICKEN (and their answers!).
     29; [[FAQ]] : A list of Frequently Asked Questions about CHICKEN (and their answers).
    2830
    2931; [[Acknowledgements]] : A list of some of the people that have contributed to make CHICKEN what it is.
  • chicken/branches/prerelease/manual/Unit expand

    r13859 r15101  
    3434{{error}}.
    3535
     36
     37==== er-macro-transformer
     38
     39  [procedure] (er-macro-transformer TRANSFORMER)
     40
     41This procedure does nothing and is available for writing low-level
     42macros in a more portable fashion, without hard-coding the signature
     43of a transformer procedure.
     44
     45
    3646---
    3747Previous: [[Unit library]]
  • chicken/branches/prerelease/manual/Unit files

    r13859 r15101  
    8282stripped.
    8383
     84==== normalize-pathname
     85
     86<procedure>(normalize-pathname PATHNAME [PLATFORM])</procedure>
     87
     88Performs a simple "normalization" on the {{PATHNAME}}, suitably for
     89{{PLATFORM}}, which defaults to the value of {{(build-platform)}}.
     90Currently, this just converts forward slashes to backslashes on Windows.
     91
    8492==== directory-null?
    8593
  • chicken/branches/prerelease/manual/Unit library

    r13859 r15101  
    219219
    220220
     221==== directory-exists?
     222
     223<procedure>(directory-exists? STRING)</procedure>
     224
     225Returns {{STRING}} if a directory with the given pathname exists, or
     226{{#f}} otherwise.
     227
     228
    221229==== file-exists?
    222230
    223231<procedure>(file-exists? STRING)</procedure>
    224232
    225 Returns {{STRING}} if a file with the given pathname exists, or
     233Returns {{STRING}} if a file or directory with the given pathname exists, or
    226234{{#f}} otherwise.
    227235
  • chicken/branches/prerelease/manual/Unit posix

    r13859 r15101  
    3636===== open/rdwr
    3737===== open/read
     38Synonym for {{open/rdonly}}.
     39
    3840===== open/write
     41Synonym for {{open/wronly}}.
     42
    3943===== open/creat
    4044===== open/append
     
    279283
    280284Opens the file specified with the string {{FILENAME}} and open-flags
    281 {{FLAGS}} using the C function {{open()}}. On success a
    282 file-descriptor for the opened file is returned.  {{FLAGS}}
    283 should be a bitmask containing one or more of the {{open/...}}
     285{{FLAGS}} using the C function {{open(2)}}. On success a
     286file-descriptor for the opened file is returned.
     287
     288{{FLAGS}} is a bitmask of {{open/...}}
    284289values '''or'''ed together using {{bitwise-ior}} (or simply added
    285 together).  The optional {{MODE}} should be a bitmask composed of one
     290together).  You must provide exactly one of the access flags {{open/rdonly}}, {{open/wronly}}, or {{open/rdwr}}.  Additionally, you may provide zero or more creation flags ({{open/creat}}, {{open/excl}}, {{open/trunc}}, and {{open/noctty}}) and status flags (the remaining {{open/...}} values).  For example, to open a possibly new output file for appending:
     291
     292 (file-open "/tmp/hen.txt" (+ open/wronly open/append open/creat))
     293
     294The optional {{MODE}} should be a bitmask composed of one
    286295or more permission values like {{perm/irusr}} and is only relevant
    287296when a new file is created. The default mode is
     
    397406{{file-modification-time}}, device id, device type (for special file
    398407inode, blocksize and blocks allocated.  On Windows systems the last 4
    399 values are undefined.  If the optional argument {{LINK}} is given and
    400 not {{#f}}, then the file-statistics vector will be resolved for
    401 symbolic links (otherwise symbolic links are not resolved).
     408values are undefined.
     409
     410By default, symbolic links are followed and
     411the status of the referenced file is returned;
     412however, if the optional argument {{LINK}} is given and
     413not {{#f}}, the status of the link itself is returned.
     414
    402415Note that for very large files, the {{file-size}} value may be an
    403416inexact integer.
     
    452465
    453466
    454 ==== stat-regular?
    455 ==== stat-directory?
    456 ==== stat-char-device?
    457 ==== stat-block-device?
    458 ==== stat-fifo?
    459 ==== stat-symlink?
    460 ==== stat-socket?
    461 
    462 <procedure>(stat-regular? FILENAME)</procedure>
    463 <procedure>(stat-directory? FILENAME)</procedure>
    464 <procedure>(stat-char-device? FILENAME)</procedure>
    465 <procedure>(stat-block-device? FILENAME)</procedure>
    466 <procedure>(stat-fifo? FILENAME)</procedure>
    467 <procedure>(stat-symlink? FILENAME)</procedure>
    468 <procedure>(stat-socket? FILENAME)</procedure>
     467==== character-device?
     468==== block-device?
     469==== fifo?
     470==== socket?
     471
     472<procedure>(character-device? FILENAME)</procedure>
     473<procedure>(block-device? FILENAME)</procedure>
     474<procedure>(fifo? FILENAME)</procedure>
     475<procedure>(socket? FILENAME)</procedure>
    469476
    470477These procedures return {{#t}} if the {{FILENAME}} given is of the
     
    11361143current terminal window or {{0}}, {{0}} if the terminal
    11371144size can not be obtained. On Windows, this procedure
    1138 always returns {{0}, {{0}}.
     1145always returns {{0}}, {{0}}.
    11391146
    11401147
  • chicken/branches/prerelease/manual/Unit regex

    r13859 r15101  
    99written completely in Scheme.
    1010
    11 This library unit exposes two APIs: the one listed below and the
    12 original irregex API. To use the latter, import from the {{irregex}} module.
     11This library unit exposes two APIs: the standard Chicken API described below, and the
     12original irregex API.  You may use either API or both:
     13
     14 (require-library regex)   ; required for either API, or both
     15 (import regex)            ; import the Chicken regex API
     16 (import irregex)          ; import the original irregex API
    1317
    1418Regular expressions may be either POSIX-style strings (with most PCRE
    1519extensions) or an SCSH-style SRE. There is no {{(rx ...)}} syntax -
    1620just use normal Scheme lists, with quasiquote if you like.
    17 
    18 
    1921
    2022=== grep
  • chicken/branches/prerelease/manual/Unit utils

    r13859 r15101  
    6262port that is the current value of {{(current-input-port)}}.
    6363
     64
     65=== Shell argument quoting
     66
     67==== qs
     68
     69 [procedure] (qs STRING [PLATFORM])
     70
     71Escapes {{STRING}} suitably for passing to a shell command on {{PLATFORM}}.
     72{{PLATFORM}} defaults to the value of {{(build-platform)}} and indicates in
     73which style the argument should be quoted. On Windows systems, the string
     74is simply enclosed in double-quote ({{"}}) characters, on UNIXish systems,
     75characters that would have a special meaning to the shell are escaped
     76using backslash ({{\}}).
     77
     78
    6479---
    6580Previous: [[Unit posix]]
  • chicken/branches/prerelease/manual/Using the compiler

    r14954 r15101  
    5555     D          when printing nodes, use node-tree output
    5656     N          show the real-name mapping table
    57      U          show expressions after the secondary user pass
    5857     0          show database before lambda-lifting pass
     58     T          show expressions after converting to node tree
    5959     L          show expressions after lambda-lifting
    6060     M          show syntax-/runtime-requirements
  • chicken/branches/prerelease/manual/Using the interpreter

    r13859 r15101  
    242242More details are available in [[http://www.call-with-current-continuation.org/eggs/readline.html|the egg's documentation]].
    243243
    244 === Accessing documentation
    245 
    246 You can access the manual directly from {{csi}} using the [[http://www.call-with-current-continuation.org/eggs/man.html|man]] extension by Mario Domenech Goulart.
    247 
    248 To enable it install the egg and put this in your {{~/.csirc}} file:
    249 
    250  (use man)
    251  (man:load)
    252 
    253 Then, in {{csi}}, you can search for definitions using {{man:search}} as in:
    254 
    255  (man:search "case")
    256 
    257 Note that the search uses regular expressions.
    258 To view the documentation for one entry from the manual, use {{man:help}} as in:
    259 
    260  (man:help "case-lambda")
    261 
    262 Note: Currently the documentation provided by the {{man}} extension corresponds to Chicken's 2.429, one of the last releases whose documentation was in the texinfo format (the format the {{man}} extension parses).
    263244
    264245---
  • chicken/branches/prerelease/manual/faq

    r14954 r15101  
    11[[toc:]]
    2 [[tags:faq]]
     2[[tags:faq manual]]
    33
    44== FAQ
     
    495495==== Why is my program which uses regular expressions so slow?
    496496
    497 The regular expression engine has recently be replaced by [[alex shinn]]'s excellent
     497The regular expression engine has recently be replaced by [[/users/alex shinn|alex shinn]]'s excellent
    498498{{irregex}} library, which is fully implemented in Scheme. Precompiling regular
    499499expressions to internal form is somewhat slower than with the old PCRE-based
  • chicken/branches/prerelease/optimizer.scm

    r14954 r15101  
    3131  compiler-arguments process-command-line perform-lambda-lifting!
    3232  default-standard-bindings default-extended-bindings
    33   foldable-bindings llist-length
     33  foldable-bindings llist-length r-c-s compile-format-string
    3434  installation-home decompose-lambda-list external-to-pointer
    3535  copy-node! variable-visible? mark-variable intrinsic?
     
    5959  topological-sort print-version print-usage initialize-analysis-database
    6060  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    61   units-used-by-default words-per-flonum rewrite inline-locally
     61  units-used-by-default words-per-flonum rewrite inline-locally compiler-syntax-statistics
    6262  parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6363  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    64   make-random-name final-foreign-type inline-max-size simplified-ops apply-pre-cps-rewrite-rules!
     64  make-random-name final-foreign-type inline-max-size simplified-ops
    6565  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    6666  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result)
     
    18051805
    18061806
    1807 ;;; Apply rewrite-rules to procedure calls
    1808 
    1809 (define (apply-pre-cps-rewrite-rules! node db)
    1810   (define (walk n)
    1811     (let ((class (node-class n))
    1812           (params (node-parameters n))
    1813           (subs (node-subexpressions n)))
    1814       (case class
    1815         ((##core#call)
    1816          (let* ((opnode (walk (first subs)))
    1817                 (proc (and (eq? '##core#variable (node-class opnode))
    1818                            (first (node-parameters opnode))) )
    1819                 (handler (and proc
    1820                               (intrinsic? proc)
    1821                               (##sys#get proc '##compiler#rewrite) ) ) )
    1822            (for-each walk (cdr subs))
    1823            (cond (handler
    1824                   (let ((info (and (pair? (cdr params))
    1825                                    (source-info->line (second params)))))
    1826                     (debugging 'o "applying rule" proc info)
    1827                     (copy-node! (handler proc (cdr subs) db walk) n)))
    1828                  (else n))))
    1829         (else
    1830          (for-each walk subs)))))
    1831   (walk node))
     1807;;; Compiler macros (that operate in the expansion phase)
     1808
     1809(define compiler-syntax-statistics '())
     1810
     1811(set! ##sys#compiler-syntax-hook
     1812  (lambda (name result)
     1813    (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
     1814      (set! compiler-syntax-statistics
     1815        (alist-update! name (add1 a) compiler-syntax-statistics)))))
     1816
     1817(define (r-c-s names transformer #!optional (se '()))
     1818  (let ((t (cons (##sys#er-transformer transformer) se)))
     1819    (for-each
     1820     (lambda (name)
     1821       (##sys#put! name '##compiler#compiler-syntax t) )
     1822     (if (symbol? names) (list names) names) ) ) )
     1823
     1824(r-c-s
     1825 '(for-each ##sys#for-each #%for-each)
     1826 (lambda (x r c)
     1827   (let ((%let (r 'let))
     1828         (%if (r 'if))
     1829         (%loop (r 'loop))
     1830         (%lst (r 'lst))
     1831         (%begin (r 'begin))
     1832         (%pair? (r 'pair?)))
     1833     (if (= 3 (length x))
     1834         `(,%let ,%loop ((,%lst ,(caddr x)))
     1835                 (,%if (,%pair? ,%lst)
     1836                       (,%begin
     1837                        (,(cadr x) (##sys#slot ,%lst 0))
     1838                        (##core#app ,%loop (##sys#slot ,%lst 1))) ) )
     1839         x)))
     1840 `((pair? . ,(##sys#primitive-alias 'pair?))))
     1841
     1842(let ((env `((display . ,(##sys#primitive-alias 'display)) ;XXX clean this up
     1843             (write . ,(##sys#primitive-alias 'write))
     1844             (fprintf . ,(##sys#primitive-alias 'fprintf))
     1845             (number->string . ,(##sys#primitive-alias 'number->string))
     1846             (write-char . ,(##sys#primitive-alias 'write-char))
     1847             (open-output-string . ,(##sys#primitive-alias 'open-output-string))
     1848             (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
     1849  (r-c-s
     1850   '(sprintf #%sprintf format #%format)
     1851   (lambda (x r c)
     1852     (let* ((out (gensym 'out))
     1853            (code (compile-format-string
     1854                   'sprintf out
     1855                   x
     1856                   (cdr x)
     1857                   r c)))
     1858       (if code
     1859           `(,(r 'let) ((,out (,(r 'open-output-string))))
     1860             ,code
     1861             (,(r 'get-output-string) ,out))
     1862           x)))
     1863   env)
     1864  (r-c-s
     1865   '(fprintf #%fprintf)
     1866   (lambda (x r c)
     1867     (if (>= (length x) 3)
     1868         (let ((code (compile-format-string
     1869                      'fprintf (cadr x)
     1870                      x (cddr x)
     1871                      r c)))
     1872           (if code
     1873               code
     1874               x))
     1875         x))
     1876   env)
     1877  (r-c-s
     1878   '(printf #%printf)
     1879   (lambda (x r c)
     1880     (let ((code (compile-format-string
     1881                  'printf '##sys#standard-output
     1882                  x (cdr x)
     1883                  r c)))
     1884       (if code
     1885           code
     1886           x)))
     1887   env))
     1888
     1889(define (compile-format-string func out x args r c)
     1890  (call/cc
     1891   (lambda (return)
     1892     (and (>= (length args) 1)
     1893          (or (string? (car args))
     1894              (and (list? (car args))
     1895                   (c (r 'quote) (caar args))
     1896                   (string? (cadar args))))
     1897          (let ((fstr (if (string? (car args)) (car args) (cadar args)))
     1898                (args (cdr args)))
     1899            (define (fail ret? msg . args)
     1900              (let ((ln (get-line x)))
     1901                (compiler-warning
     1902                 'syntax
     1903                 "(~a) in format string ~s~a, ~?"
     1904                 func fstr
     1905                 (if ln (sprintf " in line ~a" ln) "")
     1906                 msg args) )
     1907              (when ret? (return #f)))
     1908            (let ((code '())
     1909                  (index 0)
     1910                  (len (string-length fstr))
     1911                  (%display (r 'display))
     1912                  (%write (r 'write))
     1913                  (%write-char (r 'write-char))
     1914                  (%out (r 'out))
     1915                  (%fprintf (r 'fprintf))
     1916                  (%let (r 'let))
     1917                  (%number->string (r 'number->string)))
     1918              (define (fetch)
     1919                (let ((c (string-ref fstr index)))
     1920                  (set! index (fx+ index 1))
     1921                  c) )
     1922              (define (next)
     1923                (if (null? args)
     1924                    (fail #t "too few arguments to formatted output procedure")
     1925                    (let ((x (car args)))
     1926                      (set! args (cdr args))
     1927                      x) ) )
     1928              (define (endchunk chunk)
     1929                (when (pair? chunk)
     1930                  (push
     1931                   (if (= 1 (length chunk))
     1932                       `(,%write-char ,(car chunk) ,%out)
     1933                       `(,%display ,(reverse-list->string chunk) ,%out)))))
     1934              (define (push exp)
     1935                (set! code (cons exp code)))
     1936              (let loop ((chunk '()))
     1937                (cond ((>= index len)
     1938                       (unless (null? args)
     1939                         (fail #f "too many arguments to formatted output procedure"))
     1940                       (endchunk chunk)
     1941                       `(,%let ((,%out ,out))
     1942                               ,@(reverse code)))
     1943                      (else
     1944                       (let ((c (fetch)))
     1945                         (if (eq? c #\~)
     1946                             (let ((dchar (fetch)))
     1947                               (endchunk chunk)
     1948                               (case (char-upcase dchar)
     1949                                 ((#\S) (push `(,%write ,(next) ,%out)))
     1950                                 ((#\A) (push `(,%display ,(next) ,%out)))
     1951                                 ((#\C) (push `(,%write-char ,(next) ,%out)))
     1952                                 ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
     1953                                 ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
     1954                                 ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
     1955                                 ((#\!) (push `(##sys#flush-output ,%out)))
     1956                                 ((#\?)
     1957                                  (let* ([fstr (next)]
     1958                                         [lst (next)] )
     1959                                    (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
     1960                                 ((#\~) (push `(,write-char #\~ ,%out)))
     1961                                 ((#\% #\N) (push `(,%write-char #\newline ,%out)))
     1962                                 (else
     1963                                  (if (char-whitespace? dchar)
     1964                                      (let skip ((c (fetch)))
     1965                                        (if (char-whitespace? c)
     1966                                            (skip (fetch))
     1967                                            (set! index (sub1 index))))
     1968                                      (fail #t "illegal format-string character `~c'" dchar) ) ) )
     1969                               (loop '()) )
     1970                             (loop (cons c chunk)))))))))))))
  • chicken/branches/prerelease/posix.import.scm

    r14954 r15101  
    240240   signals-list
    241241   sleep
    242    stat-block-device?
    243    stat-char-device?
    244    stat-directory?
    245    stat-fifo?
    246    stat-regular?
    247    stat-socket?
    248    stat-symlink?
     242   stat-block-device?                   ; DEPRECATED
     243   block-device?
     244   character-device?
     245   stat-char-device?                    ; DEPRECATED
     246   stat-directory?                      ; DEPRECATED
     247   stat-fifo?                           ; DEPRECATED
     248   fifo?
     249   stat-regular?                        ; DEPRECATED
     250   stat-socket?                         ; DEPRECATED
     251   socket?
     252   stat-symlink?                        ; DEPRECATED
    249253   string->time
    250254   symbolic-link?
  • chicken/branches/prerelease/posixunix.scm

    r14954 r15101  
    790790  (foreign-value "C_islink" bool) )
    791791
    792 (define (stat-regular? fname)
     792(define (stat-regular? fname)           ; DEPRECATED
    793793    (##sys#check-string fname 'stat-regular?)
    794794    (##sys#stat fname #f 'stat-regular?)
    795795    (foreign-value "C_isreg" bool))
    796796
    797 (define (stat-directory? fname)
     797(define (stat-directory? fname)         ; DEPRECATED
    798798    (##sys#check-string fname 'stat-directory?)
    799799    (##sys#stat fname #f 'stat-directory?)
    800800    (foreign-value "C_isdir" bool))
    801801
    802 (define (stat-char-device? fname)
    803     (##sys#check-string fname 'stat-char-device?)
    804     (##sys#stat fname #f 'stat-char-device?)
     802(define (character-device? fname)
     803    (##sys#check-string fname 'character-device?)
     804    (##sys#stat fname #f 'character-device?)
    805805    (foreign-value "C_ischr" bool))
    806806
    807 (define (stat-block-device? fname)
    808     (##sys#check-string fname 'stat-block-device?)
    809     (##sys#stat fname #f 'stat-block-device?)
     807(define stat-char-device? character-device?) ; DEPRECATED
     808
     809(define (block-device? fname)
     810    (##sys#check-string fname 'block-device?)
     811    (##sys#stat fname #f 'block-device?)
    810812    (foreign-value "C_isblk" bool))
    811813
    812 (define (stat-fifo? fname)
     814(define stat-block-device? block-device?) ; DEPRECATED
     815
     816(define (fifo? fname)
    813817    (##sys#check-string fname 'stat-fifo?)
    814818    (##sys#stat fname #f 'stat-fifo?)
    815819    (foreign-value "C_isfifo" bool))
    816820
    817 (define (stat-symlink? fname)
    818     (##sys#check-string fname 'stat-symlink?)
    819     (##sys#stat fname #t 'stat-symlink?)
    820     (foreign-value "C_islink" bool))
    821 
    822 (define (stat-socket? fname)
    823     (##sys#check-string fname 'stat-socket?)
    824     (##sys#stat fname #f 'stat-socket?)
    825     (foreign-value "C_issock" bool))
     821(define stat-fifo? fifo?)               ; DEPRECATED
     822(define stat-symlink? symbolic-link?)   ; DEPRECATED
     823
     824(define (socket? fname)
     825  (##sys#check-string fname 'socket?)
     826  (##sys#stat fname #f 'socket?)
     827  (foreign-value "C_issock" bool))
     828
     829(define stat-socket? socket?)           ; DEPRECATED
    826830
    827831(define set-file-position!
  • chicken/branches/prerelease/posixwin.scm

    r14954 r15101  
    11121112                 (##sys#check-string fname name)
    11131113                 #f))))
    1114     (set! stat-regular? regular-file?)
    1115     (set! stat-directory? (stat-type 'stat-directory?))
    1116     (set! stat-char-device? (stat-type 'stat-char-device?))
    1117     (set! stat-block-device? (stat-type 'stat-block-device?))
    1118     (set! stat-fifo? (stat-type 'stat-fifo?))
    1119     (set! stat-symlink? (stat-type 'stat-symlink?))
    1120     (set! stat-socket? (stat-type 'stat-socket?)))
     1114    (set! stat-regular? regular-file?)  ; DEPRECATED
     1115    (set! stat-directory? (stat-type 'stat-directory?)) ; DEPRECATED
     1116    (set! stat-device? (stat-type 'stat-char-device?))  ; DEPRECATED
     1117    (set! character-device? (stat-type 'character-device?))
     1118    (set! block-device? (stat-type 'block-device?))
     1119    (set! stat-block-device? (stat-type 'stat-block-device?)) ; DEPRECATED
     1120    (set! stat-fifo? (stat-type 'stat-fifo?))                 ; DEPRECATED
     1121    (set! fifo? (stat-type 'fifo?))
     1122    (set! stat-symlink? (stat-type 'stat-symlink?)) ; DEPRECATED
     1123    (set! socket? (stat-type 'socket?))
     1124    (set! stat-socket? (stat-type 'stat-socket?))) ; DEPRECATED
    11211125
    11221126(define set-file-position!
  • chicken/branches/prerelease/private-namespace.scm

    r14954 r15101  
    2626
    2727
    28 (cond-expand
    29  (hygienic-macros
    30   (define-syntax private
    31     ;;XXX use er-macro-transformer
    32     (lambda (form r c)
    33       (let ((namespace (cadr form))
    34             (vars (cddr form)))
    35         (##sys#check-symbol namespace 'private)
    36         (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
    37                (prefix (string-append
    38                         (string (integer->char (string-length str)))
    39                         (symbol->string namespace))))
    40           (for-each
    41            (lambda (var)
    42              (put!
    43               var 'c:namespace
    44               (##sys#string->qualified-symbol prefix (symbol->string var))))
    45            vars)
    46           '(##core#undefined) ) ) ) ) )
    47  (else
    48   (define-macro (private . args)
    49     (let ((namespace (car args))
    50           (vars (cdr args)))
     28(define-syntax private
     29  (lambda (form r c)
     30    (let ((namespace (cadr form))
     31          (vars (cddr form)))
    5132      (##sys#check-symbol namespace 'private)
    52       (let* ((str (symbol->string namespace))
     33      (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
    5334             (prefix (string-append
    5435                      (string (integer->char (string-length str)))
     
    6041            (##sys#string->qualified-symbol prefix (symbol->string var))))
    6142         vars)
    62         '(void) ) ) ) ) )
     43        '(##core#undefined) ) ) ) )
    6344
    6445(set! ##sys#alias-global-hook
  • chicken/branches/prerelease/regex.scm

    r14954 r15101  
    184184    (lambda (rx subst string . flag)
    185185      (##sys#check-string subst 'string-substitute)
     186      (##sys#check-string string 'string-substitute)
    186187      (let* ([which (if (pair? flag) (car flag) 1)]
    187188             [substlen (##sys#size subst)]
  • chicken/branches/prerelease/rules.make

    r14954 r15101  
    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),)
     
    12001202
    12011203dist: distfiles
    1202         $(CSI) -s $(SRCDIR)scripts/makedist.scm --platform=$(PLATFORM) CHICKEN=$(CHICKEN)
     1204        CSI=$(CSI) $(CSI) -s $(SRCDIR)scripts/makedist.scm --platform=$(PLATFORM) CHICKEN=$(CHICKEN)
    12031205
    12041206html:
     
    12171219endif
    12181220
    1219 clean: scrutiny-clean
     1221clean:
    12201222        -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken$(EXE) csi$(EXE) csc$(EXE) \
    12211223          chicken-profile$(EXE) csi-static$(EXE) \
     
    13041306        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
    13051307        $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
    1306 
    1307 
    1308 # scrutiny
    1309 
    1310 .PHONY: scrutiny scrutiny-clean
    1311 
    1312 scrutiny: $(SCRUTINIZED_LIBRARIES:=.scrutiny1) $(COMPILER_OBJECTS_1:=.scrutiny2)
    1313 
    1314 %.scrutiny1: $(SRCDIR)%.scm
    1315         $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_LIBRARY_OPTIONS) 2>&1 | tee $@
    1316 
    1317 %.scrutiny2: $(SRCDIR)%.scm
    1318         $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_COMPILER_OPTIONS) 2>&1 | tee $@
    1319 
    1320 scrutiny-clean:
    1321         $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) *.scrutiny1 *.scrutiny2
  • chicken/branches/prerelease/scheduler.scm

    r13240 r15101  
    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/branches/prerelease/scheme.import.scm

    r14954 r15101  
    5555       char-ready? imag-part real-part magnitude numerator denominator
    5656       scheme-report-environment null-environment interaction-environment
    57        er-macro-transformer)
     57       else)
    5858 ##sys#default-macro-environment)
  • chicken/branches/prerelease/scripts/makedist.scm

    r13859 r15101  
    5050    (run (rm -fr ,distname)) ) )
    5151
     52(define (make-html)
     53  (unless (file-exists? "html")
     54    (create-directory "html"))
     55  (run (,(or (get-environment-variable "CSI")
     56             (let ((this (car (argv))))
     57               (if (string=? "csi" (pathname-file this))
     58                   this
     59                   "csi")) )
     60        -s scripts/wiki2html.scm
     61        --outdir=html
     62        ,@(map (o qs (cut make-pathname "manual" <>))
     63               (directory "manual")))))
     64
    5265(define *makeargs*
    5366  (simple-args
     
    5871
    5972(run (,*make* -f ,(conc "Makefile." *platform*) distfiles ,@*makeargs*))
     73
     74(make-html)
     75(run (cp misc/manual.css html))
     76
    6077(release *release*)
  • chicken/branches/prerelease/scripts/test-dist.sh

    r13859 r15101  
    7474
    7575# Install a few eggs
     76$prefix/bin/chicken-install -test prometheus
    7677$prefix/bin/chicken-install opengl
    7778
  • chicken/branches/prerelease/scripts/tools.scm

    r13859 r15101  
    2424
    2525(define *tty-width*
    26   (or (and *tty*
     26  (or (and *tty*
     27           (not *windows-shell*)
    2728           (with-input-from-pipe "stty size 2>/dev/null"
    2829             (lambda () (read) (read))))
     
    8687                               (list (car line))
    8788                               (car line))])
    88                (if (ormap match? names)
     89               (if (any match? names)
    8990                   line
    9091                   (loop (cdr lines))))]))))
     
    9697  (and (or (list? spec) (form-error "specification is not a list" spec))
    9798       (or (pair? spec) (form-error "specification is an empty list" spec))
    98        (andmap
     99       (every
    99100        (lambda (line)
    100101          (and (or (and (list? line) (<= 2 (length line) 3))
     
    102103               (or (or (string? (car line))
    103104                       (and (list? (car line))
    104                             (andmap string? (car line))))
     105                            (every string? (car line))))
    105106                   (form-error "line does not start with a string or list of strings" line))
    106107               (let ([name (car line)])
    107108                 (or (list? (cadr line))
    108109                     (line-error "second part of line is not a list" (cadr line) name)
    109                      (andmap (lambda (dep)
     110                     (every (lambda (dep)
    110111                               (or (string? dep)
    111112                                   (form-error "dependency item is not a string" dep)))
     
    119120  (or (string? argv)
    120121      (and (vector? argv)
    121            (andmap string? (vector->list argv)))
     122           (every string? (vector->list argv)))
    122123      (error "argument is not a string or string vector" argv)))
    123124
     
    141142                      (let ([reason
    142143                             (or (not date)
    143                                  (ormap (lambda (dep)
     144                                 (any (lambda (dep)
    144145                                          (unless (file-exists? dep)
    145146                                            (quit "dependancy ~a was not made~%" dep))
  • chicken/branches/prerelease/scripts/wiki2html.scm

    r13859 r15101  
    11;;;; wiki2html.scm - quick-and-dirty svnwiki->HTML conversion
    2 ;
    3 ; usage: wiki2html <INPUTFILE >OUTPUTFILE
    42
    53
     
    1614(define +italic+ '(: (= 2 #\') (submatch (* (~ #\'))) (= 2 #\')))
    1715(define +html-tag+ '(: #\< (submatch (* (~ #\>))) #\>))
     16(define +enscript-tag+ '(: "<enscript" (* (~ #\>)) #\>))
    1817
    1918(define +link+
     
    2827
    2928(define +http-url+ '(: (* space) "http://" (* any)))
     29(define +end-enscript-tag+ '(: "</enscript>"))
    3030
    3131
     
    5050       ,+u-list+
    5151       ,+o-list+
     52       ,+enscript-tag+
    5253       ,+hr+))
    5354
     
    111112                       (pop-all out)
    112113                       (fprintf out "~a~%" (inline ln)))))
     114               ((string-match (rx +enscript-tag+) ln) =>
     115                (lambda (m)
     116                  (pop-all out)
     117                  (fprintf out "<pre>~a~%" (substring ln (string-length (car m))))
     118                  (copy-until-match (rx +end-enscript-tag+) in out) ;XXX doesn't parse rest of line
     119                  (display "</pre>" out)))
    113120               ((string-match (rx +header+) ln) =>
    114121                (lambda (m)
    115122                  (pop-all out)
    116123                  (let ((n (sub1 (string-length (second m))))
    117                         (name (clean (third m))))
     124                        (name (inline (third m))))
    118125                    (fprintf out "<a name='~a' /><h~a>~a</h~a>~%"
    119126                             name n name n))))
     
    223230        (('procedure strs ...)
    224231         `(pre "\n [procedure] " ,@strs))
     232        (('nowiki content ...)
     233         `(div ,content))
    225234        (((? symbol? tag) ('@ attr ...) . body)
    226235         `(,tag (@ ,@attr) ,@(map walk body)))
     
    245254(define (clean str)
    246255  (string-translate* str '(("<" . "&lt;") ("&" . "&amp;") ("'" . "&apos;") ("\"" . "&quot;"))))
     256
     257
     258;;; Read until rx matches
     259
     260(define (copy-until-match rx in out)
     261  (let loop ()
     262    (let ((ln (read-line in)))
     263      (cond ((string-match rx ln) =>
     264             (lambda (m)
     265               (substring ln (string-length (car m))) ) )
     266            (else
     267             (display (clean ln) out)
     268             (newline out)
     269             (loop))))))
    247270
    248271
  • chicken/branches/prerelease/scrutinizer.scm

    r14954 r15101  
    238238                                     (cond ((and (pair? t) (eq? 'or (car t)))
    239239                                            (cdr t))
    240                                            ((eq? 'noreturn t) '())
     240                                           ;((eq? t 'noreturn) '())
    241241                                           ((eq? t 'undefined) (return 'undefined))
    242242                                           (else (list t)))))
     
    280280                 (else '(#!rest))))
    281281          ((eq? '#!rest (car ts1))
    282            (cond ((eq? '#!rest (car ts2))
     282           (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))
    283283                  `(#!rest
    284284                    ,(simplify
     
    287287                 (else '(#!rest))))             ;XXX giving up
    288288          ((eq? '#!optional (car ts1))
    289            (cond ((eq? '#!optional (car ts2))
     289           (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
    290290                  `(#!optional
    291291                    ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
     
    546546                      (else (cons (car rt) (loop (cdr rt)))))))))
    547547          (else (bomb "not a procedure type: ~a" t))))
     548  (define (noreturn-type? t)
     549    (or (eq? 'noreturn t)
     550        (and (pair? t)
     551             (eq? 'or (car t))
     552             (any noreturn-type? (cdr t)))))
    548553  (define (walk n e loc dest)           ; returns result specifier
    549554    (let ((subs (node-subexpressions n))
     
    562567                       (let ((r1 (walk (second subs) e loc dest))
    563568                             (r2 (walk (third subs) e loc dest)))
    564                          (cond ((and (not (eq? r1 '*)) (not (eq? '* r2)))
    565                                 (when (not (= (length r1) (length r2)))
     569                         (cond ((and (not (eq? r1 '*))
     570                                     (not (eq? '* r2)) )
     571                                (when (and (not (any noreturn-type? r1))
     572                                           (not (any noreturn-type? r2))
     573                                           (not (= (length r1) (length r2))))
    566574                                  (report
    567575                                   loc
     
    608616                       (b (assq var e)) )
    609617                  (when (and type (not b)
     618                             (not (eq? type 'deprecated))
    610619                             (not (match type rt)))
    611620                    (report
  • chicken/branches/prerelease/setup-api.scm

    r14954 r15101  
    4040     host-extension
    4141     install-extension install-program install-script
    42      setup-verbose-flag
    43      setup-install-flag installation-prefix chicken-prefix
     42     setup-verbose-mode setup-install-mode
     43     setup-verbose-flag setup-install-flag                      ; DEPRECATED
     44     installation-prefix chicken-prefix
    4445     find-library find-header
    4546     program-path remove-file*
     
    117118
    118119(define setup-root-directory      (make-parameter *base-directory*))
    119 (define setup-verbose-flag        (make-parameter #f))
    120 (define setup-install-flag        (make-parameter #t))
     120(define setup-verbose-mode        (make-parameter #f))
     121(define setup-install-mode        (make-parameter #t))
     122(define setup-verbose-flag setup-verbose-mode) ; DEPRECATED
     123(define setup-install-flag setup-install-mode) ; DEPRECATED
    121124(define program-path              (make-parameter *chicken-bin-path*))
    122125(define keep-intermediates (make-parameter #f))
     
    186189              (create-directory dir))) ) ) )
    187190    (define (verb dir)
    188       (when (setup-verbose-flag) (printf "  creating directory `~a'~%~!" dir)) )
     191      (when (setup-verbose-mode) (printf "  creating directory `~a'~%~!" dir)) )
    189192    (if *windows-shell*
    190193        (lambda (dir)
     
    213216 
    214217(define (patch which rx subst)
    215   (when (setup-verbose-flag) (printf "patching ~A ...~%" which))
     218  (when (setup-verbose-mode) (printf "patching ~A ...~%" which))
    216219  (if (list? which)
    217220      (with-output-to-file (cadr which)
     
    334337                     (date (and (file-exists? s2)
    335338                                (file-modification-time s2))))
    336                 (when (setup-verbose-flag)
     339                (when (setup-verbose-mode)
    337340                  (printf "make: ~achecking ~a~%" indent s2))
    338341                (if line
     
    354357                            (unless (null? l)
    355358                              (set! made (cons s made))
    356                               (when (setup-verbose-flag)
     359                              (when (setup-verbose-mode)
    357360                                (printf "make: ~amaking ~a~a~%"
    358361                                        indent
     
    381384     ((null? argv) (make-file (caar spec) ""))
    382385     (else (for-each (lambda (f) (make-file f "")) argv)))
    383     (when (setup-verbose-flag)
     386    (when (setup-verbose-mode)
    384387      (for-each (lambda (item)
    385388                  (printf "make: made ~a~%" item))
     
    397400
    398401(define-syntax make
    399   ;;XXX use er-macro-transformer
    400402  (lambda (form r c)
    401403    (##sys#check-syntax 'make form '(_ _ . #(_ 0 1)))
     
    439441  (let ((info `((files ,@files)
    440442                ,@info)) )
    441     (when (setup-verbose-flag) (printf "writing info ~A -> ~S ...~%" id info))
     443    (when (setup-verbose-mode) (printf "writing info ~A -> ~S ...~%" id info))
    442444    (let* ((sid (->string id))
    443445           (setup-file (make-setup-info-pathname sid (repo-path #t))))
     
    500502
    501503(define (install-extension id files #!optional (info '()))
    502   (when (setup-install-flag)
     504  (when (setup-install-mode)
    503505    (let* ((files (check-filelist (if (list? files) files (list files))))
    504506           (rpath (repo-path))
     
    548550     f
    549551     (if *windows-shell* "exe" #f) ) )
    550   (when (setup-install-flag)
     552  (when (setup-install-mode)
    551553    (let* ((files (check-filelist (if (list? files) files (list files))))
    552554           (ppath ((lambda (pre)
     
    573575
    574576(define (install-script id files #!optional (info '()))
    575   (when (setup-install-flag)
     577  (when (setup-install-mode)
    576578    (let* ((files (check-filelist (if (list? files) files (list files))))
    577579           (ppath ((lambda (pre)
     
    616618
    617619(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "")
    618                      (verb (setup-verbose-flag)) (compile-only #f))
     620                     (verb (setup-verbose-mode)) (compile-only #f))
    619621  (let* ((fname (create-temporary-file "c"))
    620622         (oname (pathname-replace-extension fname "o"))
  • chicken/branches/prerelease/srfi-13.scm

    r14954 r15101  
    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     ;;XXX use er-macro-transformer
    209     (lambda (form r c)
    210       (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
    211       (let ((s-e-r (cadr form))
    212             (proc (caddr form))
    213             (s-exp (cadddr form))
    214             (args-exp (car (cddddr form)))
    215             (body (cdr (cddddr form)))
    216             (%receive (r 'receive))
    217             (%string-parse-start+end (r 'string-parse-start+end))
    218             (%string-parse-final-start+end (r 'string-parse-final-start+end)))
    219         (if (pair? (cddr s-e-r))
    220             `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
    221                         (,%string-parse-start+end ,proc ,s-exp ,args-exp)
    222                         ,@body)
    223             `(,%receive ,s-e-r
    224                         (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
    225                         ,@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) ) )))
    226202
    227203
  • chicken/branches/prerelease/srfi-18.scm

    r13240 r15101  
    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/branches/prerelease/srfi-69.scm

    r14954 r15101  
    144144
    145145(define-syntax $flonum-hash
    146   ;;XXX use er-macro-transformer
    147146  (lambda (form r c)
    148147    (let ( (flo (cadr form))
  • chicken/branches/prerelease/synrules.scm

    r13859 r15101  
    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/branches/prerelease/tests/runtests.sh

    r14954 r15101  
    2727echo "======================================== scrutiny tests ..."
    2828$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
    29 diff -u scrutiny.out scrutiny.expected || exit 1
     29
     30if test -n "$MSYSTEM"; then
     31    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
     37fi
     38
     39diff -u scrutiny.out scrutiny.expected || true
    3040
    3141echo "======================================== runtime tests ..."
     
    5363#$compile_s -s foo.import.scm
    5464#$interpret -bnq -e '(require-library meta-syntax-test)' -e '(import foo)' -e '(bar 1 2)'
     65
     66echo "======================================== compiler syntax tests ..."
     67$compile compiler-syntax-tests.scm
     68./a.out
    5569
    5670echo "======================================== import library tests ..."
  • chicken/branches/prerelease/tests/scrutiny-tests.scm

    r14954 r15101  
    3131
    3232((values 1 2))
     33
     34; this should *not* signal a warning:
     35
     36(define (test-values x)
     37  (define (fail) (error "failed"))
     38  (if x
     39      (values 42 43)
     40      (fail)))
  • chicken/branches/prerelease/tests/scrutiny.expected

    r14954 r15101  
    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 x3 '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 x5 (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 `bar6' (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 `x7' (line 26) a value of type `(procedure () *)', but were given a value of type `fixnum'
    3131
    3232Warning: at toplevel:
  • chicken/branches/prerelease/tests/srfi-18-tests.scm

    r14954 r15101  
    44(define-for-syntax count 0)
    55(define-syntax trail
    6   (er-macro-transformer
    76  (lambda (form r c)                    ; doesn't bother much with renaming
    87    (let ((loc (cadr form))
     
    1312        (let ((xxx ,expr))
    1413          (print "  (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
    15           xxx) ) )))))
     14          xxx) ) ))))
    1615(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
    1716
  • chicken/branches/prerelease/tests/syntax-tests.scm

    r14954 r15101  
    212212
    213213(define-syntax loop
    214   (er-macro-transformer
    215    (lambda (x r c)
    216      (let ((body (cdr x)))
    217        `(,(r 'call/cc)
    218          (,(r 'lambda) (exit)
    219           (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
     214  (lambda (x r c)
     215    (let ((body (cdr x)))
     216      `(,(r 'call/cc)
     217        (,(r 'lambda) (exit)
     218         (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
    220219
    221220(let ((n 10))
     
    235234
    236235(define-syntax while
    237   (er-macro-transformer
    238    (lambda (x r c)
    239      `(,(r 'loop)
    240        (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
    241        ,@(cddr x)))))
     236  (lambda (x r c)
     237    `(,(r 'loop)
     238      (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
     239      ,@(cddr x))))
    242240
    243241(let ((n 10))
     
    341339(assert (= 123 setter))
    342340
     341
     342;;; prefixed import from `chicken' module with indirect reference to imported syntax
     343;;; (reported by Jack Trades)
     344
     345(module prefixed-self-reference1 (a b c)
     346  (import scheme (prefix chicken c:))
     347  (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 "caught"))))
     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)))
     366
     367
     368;;; canonicalization of body captures 'begin (reported by Abdulaziz Ghuloum)
     369
     370(let ((begin (lambda (x y) (bomb)))) 1 2)
  • chicken/branches/prerelease/types.db

    r14954 r15101  
    246246(chicken-home (procedure chicken-home () string))
    247247(chicken-version (procedure chicken-version (#!optional *) string))
    248 (command-line-arguments (procedure command-line-arguments () list))
     248(command-line-arguments (procedure command-line-arguments (#!optional list) list))
    249249(condition-predicate (procedure condition-predicate (symbol) (procedure ((struct condition)) boolean)))
    250250(condition-property-accessor (procedure condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
     
    274274(features (procedure features () list))
    275275(file-exists? (procedure file-exists? (string) *))
     276(directory-exists? (procedure directory-exists? (string) *))
    276277(fixnum-bits fixnum)
    277278(fixnum-precision fixnum)
     
    360361(print* (procedure print* (#!rest) undefined))
    361362(procedure-information (procedure procedure-information (procedure) *))
    362 (program-name (procedure program-name () string))
     363(program-name (procedure program-name (#!optional string) string))
    363364(promise? (procedure promise? (*) boolean))
    364365(put! (procedure put! (symbol symbol *) undefined))
     
    368369(repl (procedure repl () undefined))
    369370(repl-prompt (procedure repl-prompt (#!optional procedure) procedure))
    370 (repository-path (procedure repository-path (#!optional *) string))
     371(repository-path (procedure repository-path (#!optional *) *))
    371372(require (procedure require (#!rest *) undefined))
    372373(reset (procedure reset () undefined))
     
    477478(randomize (procedure randomize (#!optional number) undefined))
    478479(read-byte (procedure read-byte (#!optional port) fixnum))
    479 (read-file (procedure read-file (#!optional port (procedure (port) *) fixnum) list))
     480(read-file (procedure read-file (#!optional (or port string) (procedure (port) *) fixnum) list))
    480481(read-line (procedure read-line (#!optional port fixnum) *))
    481 (read-lines (procedure read-lines (#!optional port fixnum) list))
     482(read-lines (procedure read-lines (#!optional (or port string) fixnum) list))
    482483(read-string (procedure read-string (#!optional * port) string))
    483484(read-string! (procedure read-string! (fixnum string #!optional port fixnum) fixnum))
     
    615616(call-with-output-string (procedure call-with-output-string ((procedure (port) . *)) string))
    616617(make-input-port (procedure make-input-port ((procedure () char) (procedure () *) (procedure () . *) #!optional * * *) port))
    617 (make-output-port (procedure make-output-port ((procedure (string) . *) (procedure () . *) (procedure () . *)) port))
     618(make-output-port (procedure make-output-port ((procedure (string) . *) (procedure () . *) #!optional (procedure () . *)) port))
    618619(port-for-each (procedure port-for-each ((procedure (*) *) (procedure () . *)) undefined))
    619620(port-map (procedure port-map ((procedure (*) *) (procedure () . *)) list))
     
    636637(change-directory (procedure change-directory (string) undefined))
    637638(change-file-mode (procedure change-file-mode (string fixnum) undefined))
    638 (change-file-owner (procedure change-file-owner (string fixnum) undefined))
     639(change-file-owner (procedure change-file-owner (string fixnum fixnum) undefined))
    639640(close-input-pipe (procedure close-input-pipe (port) fixnum))
    640641(close-output-pipe (procedure close-output-pipe (port) fixnum))
     
    644645(create-session (procedure create-session () fixnum))
    645646(create-symbolic-link (procedure create-symbolic-link (string string) undefined))
    646 (current-directory (procedure current-directory () string))
     647(current-directory (procedure current-directory (#!optional string) string))
    647648(current-effective-group-id (procedure current-effective-group-id () fixnum))
    648649(current-effective-user-id (procedure current-effective-user-id () fixnum))
     
    842843(signals-list list)
    843844(sleep (procedure sleep (fixnum) fixnum))
    844 (stat-block-device? (procedure stat-block-device? (string) boolean))
    845 (stat-char-device? (procedure stat-char-device? (string) boolean))
    846 (stat-directory? (procedure stat-directory? (string) boolean))
    847 (stat-fifo? (procedure stat-fifo? (string) boolean))
    848 (stat-regular? (procedure stat-regular? (string) boolean))
    849 (stat-socket? (procedure stat-socket? (string) boolean))
    850 (stat-symlink? (procedure stat-symlink? (string) boolean))
     845(block-device? (procedure block-device? (string) boolean))
     846(stat-block-device? deprecated)
     847(character-device? (procedure character-device? (string) boolean))
     848(stat-char-device? deprecated)
     849(stat-fifo? deprecated)
     850(stat-directory? deprecated)
     851(fifo? (procedure fifo? (string) boolean))
     852(stat-regular? deprecated)
     853(stat-socket? deprecated)
     854(socket? (procedure socket? (string) boolean))
     855(stat-symlink? deprecated)
    851856(string->time (procedure string->time (string #!optional string) vector))
    852857(symbolic-link? (procedure symbolic-link? (string) boolean))
     
    926931(length+ (procedure length+ (list) *))
    927932(list-copy (procedure list-copy (list) list))
    928 (list-index (procedure list-index ((procedure (* #!rest) *) list #!rest list) fixnum))
     933(list-index (procedure list-index ((procedure (* #!rest) *) list #!rest list) *))
    929934(list-tabulate (procedure list-tabulate (fixnum (procedure (fixnum) *)) list))
    930935(list= (procedure list= (#!rest list) boolean))
     
    940945(lset-xor (procedure lset-xor ((procedure (* *) *) list #!rest list) list))
    941946(lset-xor! (procedure lset-xor! ((procedure (* *) *) list #!rest list) list))
    942 (lset<= (procedure lset<= ((procedure (* *) *) list #!rest list) list))
    943 (lset= (procedure lset= ((procedure (* *) *) list #!rest list) list))
     947(lset<= (procedure lset<= ((procedure (* *) *) list #!rest list) boolean))
     948(lset= (procedure lset= ((procedure (* *) *) list #!rest list) boolean))
    944949(make-list (procedure make-list (fixnum #!optional *) list))
    945950(map! (procedure map! ((procedure (*) *) list #!rest list) list))
     
    10401045(string-skip (procedure string-skip (string * #!optional fixnum fixnum) fixnum))
    10411046(string-skip-right (procedure string-skip-right (string * #!optional fixnum fixnum) fixnum))
    1042 (string-suffix-ci? (procedure string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
     1047(string-suffix-ci? (procedure string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
    10431048(string-suffix-length (procedure string-suffix-length (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
    10441049(string-suffix-length-ci (procedure string-suffix-length-ci (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
    1045 (string-suffix? (procedure string-suffix? (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
     1050(string-suffix? (procedure string-suffix? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
    10461051(string-tabulate (procedure string-tabulate ((procedure (fixnum) char) fixnum) string))
    10471052(string-take (procedure string-take (string fixnum) string))
     
    11021107(char-set-size (procedure char-set-size ((struct char-set)) fixnum))
    11031108(char-set-unfold (procedure char-set-unfold (procedure procedure procedure * #!optional (struct char-set)) (struct char-set)))
    1104 (char-set-unfold! (procedure char-set-unfold! () (procedure procedure procedure * (struct char-set)) (struct char-set)))
     1109(char-set-unfold! (procedure char-set-unfold! (procedure procedure procedure * (struct char-set)) (struct char-set)))
    11051110(char-set-union (procedure char-set-union (#!rest (struct char-set)) (struct char-set)))
    11061111(char-set-union! (procedure char-set-union! (#!rest (struct char-set)) (struct char-set)))
     
    11201125(char-set:printing (struct char-set))
    11211126(char-set:punctuation (struct char-set))
    1122 (char-set:s (procedure (struct char-set) *))
    11231127(char-set:symbol (struct char-set))
    11241128(char-set:title-case (struct char-set))
  • chicken/branches/prerelease/unsafe-declarations.scm

    r13240 r15101  
    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.