Changeset 30990 in project


Ignore:
Timestamp:
06/08/14 21:15:18 (6 years ago)
Author:
evhan
Message:

r7rs: bug fixes, type fixes, include expansion, vector-fill!, support code reorg

Location:
release/4/r7rs/trunk
Files:
2 added
12 edited

Legend:

Unmodified
Added
Removed
  • release/4/r7rs/trunk/NOTES.org

    r30929 r30990  
    1616* Should bytevectors be implemented over blobs instead of srfi-4 (or something else)?
    1717
    18 * I think library forms (i.e. ".sld" files) should look for includes relative to themselves
    19   - this seems to be the standard amongst other Schemes that support R7RS-style libs
    20   - not sure how to get that info when expanding define-library
    21 
    2218* get-environment-variable: "It is also an error to mutate the resulting string" ...
    2319  - can we just ignore this?
  • release/4/r7rs/trunk/r7rs-compile-time-module.scm

    r30929 r30990  
    1 (module r7rs-compile-time (parse-library-definition
    2                            define-extended-arity-comparator
    3                            process-cond-expand
    4                            fixup-import/export-spec
    5                            parse-library-name
    6                            wrap-er-macro-transformer
    7                            import-transformer
    8                            read-forms
    9                            register-r7rs-module
    10                            locate-library)
    11 
    12 (import scheme chicken)
    13 
    14 (include "r7rs-compile-time.scm")
    15 
    16 )
     1(module r7rs-compile-time (r7rs-cond-expand
     2                           r7rs-define-library
     3                           r7rs-import
     4                           r7rs-import-for-syntax
     5                           r7rs-include
     6                           r7rs-include-ci)
     7  (import scheme chicken)
     8  (include "r7rs-compile-time.scm"))
  • release/4/r7rs/trunk/r7rs-compile-time.scm

    r30929 r30990  
    33
    44(import matchable)
    5 (use srfi-1 files extras data-structures)
    6 
    7 (define (parse-library-name name loc)
    8   (define (fail) (syntax-error loc "invalid library name" name))
    9   (match name
    10     ((? symbol?) name)
    11     ;; We must replicate the core magic that handles SRFI-55's
    12     ;; (require-extension (srfi N)), because we also need to generate
    13     ;; SRFI-N library names when defining SRFIs from an R7RS module.
    14     (('srfi (and num (? fixnum?)))
    15      (string->symbol (string-append "srfi-" (number->string num))))
    16     ((parts ...)
    17      (string->symbol
    18       (string-intersperse
    19        (map (lambda (part)
    20               (cond ((symbol? part) (symbol->string part))
    21                     ((number? part) (number->string part))
    22                     (else (fail))))
    23             parts)
    24        ".")))
    25     (_ (fail))))
     5(use srfi-1 files extras)
     6(use r7rs-library r7rs-support)
    267
    278(define (locate-library name loc)               ; must be stripped
     
    2910  (let* ((name2 (parse-library-name name loc))
    3011         (sname2 (symbol->string name2)))
    31     (or (##sys#provided? name2)
     12    (or (##sys#find-module name2 #f)
     13        (memq name2 ##sys#core-library-modules)
     14        (memq name2 ##sys#core-syntax-modules)
    3215        (file-exists? (string-append sname2 ".import.so"))
    3316        (file-exists? (string-append sname2 ".import.scm"))
     
    6144      (else (fail "invalid \"cond-expand\" form")))))
    6245
    63 (define (fixup-import/export-spec spec loc) ; expects spec to be stripped
    64   (match spec
    65     (((and head (or 'only 'except 'rename 'prefix)) name . more)
    66      (cons* head (fixup-import/export-spec name loc) more))
    67     ((name ...)
    68      (parse-library-name name loc))
    69     ((? symbol? spec) spec)
    70     (_ (syntax-error loc "invalid import/export specifier" spec))))
    71 
    7246;; Dig e.g. foo.bar out of (only (foo bar) ...) ...
    7347(define (import/export-spec-feature-name spec loc)
     
    8054    (else
    8155     (syntax-error loc "invalid import/export specifier" spec))))
    82 
    83 (define (wrap-er-macro-transformer name handler)
    84   (er-macro-transformer
    85    (let ((orig (caddr (assq name (##sys#macro-environment)))))
    86      (lambda (x r c)
    87        (let ((e (##sys#current-environment)))
    88          (handler x r c (lambda (x*) (orig x* '() e))))))))
    8956
    9057(define (import-transformer type)
     
    10269              (strip-syntax (cdr x)))))))
    10370
     71(define (current-source-directory)
     72  (cond (##sys#current-source-filename => pathname-directory)
     73        (else #f)))
     74
     75(define (expand-toplevel-r7rs-library-forms exps)
     76  (parameterize ((##sys#macro-environment (r7rs-library-macro-environment)))
     77    (map (cut expand <> '()) exps)))
     78
    10479(define (read-forms filename ci?)
    105   (parameterize ((case-sensitive (not ci?)))
    106     (##sys#include-forms-from-file filename)))
     80  (let ((path (##sys#resolve-include-filename filename #t)))
     81    (fluid-let ((##sys#include-pathnames
     82                 (cond ((pathname-directory path) =>
     83                        (cut cons <> ##sys#include-pathnames))
     84                       ((current-source-directory) =>
     85                        (cut cons <> ##sys#include-pathnames))
     86                       (else ##sys#include-pathnames))))
     87      (expand-toplevel-r7rs-library-forms
     88       (parameterize ((case-sensitive (not ci?)))
     89         (##sys#include-forms-from-file path))))))
    10790
    10891(define (parse-library-definition form dummy-export)    ; expects stripped syntax
     
    180163
    181164(define (register-r7rs-module name)
    182   (let ((dummy (string->symbol (conc "\x04r7rs" name))))
     165  (let ((dummy (string->symbol (string-append "\x04r7rs" (symbol->string name)))))
    183166    (put! name '##r7rs#module dummy)
    184167    dummy))
     
    197180          (register-export sym mod))))))
    198181
    199 (define-syntax define-extended-arity-comparator
    200   (syntax-rules ()
    201     ((_ name comparator check-type)
    202      (define name
    203        (let ((c comparator))
    204          (lambda (o1 o2 . os)
    205            (check-type o1 'name)
    206            (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
    207              (check-type o2 'name)
    208              (if (null? os)
    209                  (and eq (c o1 o2))
    210                  (lp o2 (car os) (cdr os) (and eq (c o1 o2)))))))))))
     182(define r7rs-define-library
     183  (er-macro-transformer
     184   (lambda (x r c)
     185     (match (strip-syntax x)
     186       ((_ name decls ...)
     187        (let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
     188          (parse-library-definition x dummy)))
     189       (else
     190        (syntax-error 'define-library "invalid library definition" x))))))
     191
     192(define r7rs-cond-expand
     193  (er-macro-transformer
     194   (lambda (x r c)
     195     (cons (r 'begin)
     196           (process-cond-expand (cdr x))))))
     197
     198(define r7rs-include
     199  (er-macro-transformer
     200   (lambda (e r c)
     201     (cons (r 'begin)
     202           (append-map (cut read-forms <> #f) (cdr e))))))
     203
     204(define r7rs-include-ci
     205  (er-macro-transformer
     206   (lambda (e r c)
     207     (cons (r 'begin)
     208           (append-map (cut read-forms <> #t) (cdr e))))))
     209
     210(define r7rs-import
     211  (import-transformer 'import))
     212
     213(define r7rs-import-for-syntax
     214  (import-transformer 'import-for-syntax))
     215
     216(define (r7rs-library-macro-environment)
     217  (filter (lambda (p)
     218            (memv (caddr p)
     219                  (map (cut ##sys#slot <> 1)
     220                       (list r7rs-cond-expand
     221                             r7rs-define-library
     222                             r7rs-include
     223                             r7rs-include-ci))))
     224          (##sys#macro-environment)))
  • release/4/r7rs/trunk/r7rs.scm

    r30325 r30990  
    22
    33  (import (except scheme syntax-rules)) ;XXX except ...
    4   (import (only chicken feature? include)) ;XXX except ...
     4  (import (only chicken feature? include register-feature!))
    55
    66  ;; For syntax definition helpers.
    7   (import-for-syntax r7rs-compile-time matchable)
    8   (begin-for-syntax (require-library r7rs-compile-time))
     7  (import-for-syntax matchable)
     8  (import-for-syntax r7rs-compile-time)
     9  (begin-for-syntax
     10    (require-library r7rs-compile-time))
    911
    1012  ;; For extended number literals.
     
    5355;;;
    5456
    55 (define-syntax import (import-transformer 'import))
    56 (define-syntax import-for-syntax (import-transformer 'import-for-syntax))
     57(define-syntax import r7rs-import)
     58(define-syntax import-for-syntax r7rs-import-for-syntax)
    5759
    5860;;;
     
    6567;;;
    6668
    67 (define-syntax define-library
    68   (er-macro-transformer
    69    (lambda (x r c)
    70      (match (strip-syntax x)
    71        ((_ name decls ...)
    72         (let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
    73           (parse-library-definition x dummy)))
    74        (_ (syntax-error 'define-library "invalid library definition" x)))))))
     69(define-syntax define-library r7rs-define-library)
     70
     71;;;
     72;;; Appendix B. Standard feature identifiers
     73;;;
     74
     75(register-feature! #:r7rs))
  • release/4/r7rs/trunk/r7rs.setup

    r30898 r30990  
    77  '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write"))
    88
    9 (make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
     9(make (("r7rs-support.so" ("r7rs-support.scm")
     10        (compile -s -O3 -d1 r7rs-support.scm -J)
     11        (compile -s -O3 -d0 r7rs-support.import.scm))
     12       ("r7rs-library.so" ("r7rs-library.scm")
     13        (compile -s -O3 -d1 r7rs-library.scm -J)
     14        (compile -s -O3 -d0 r7rs-library.import.scm))
     15       ("r7rs-compile-time.so"
     16        ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm" "r7rs-library.so" "r7rs-support.so")
    1017        (compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
    1118        (compile -s -O3 -d0 r7rs-compile-time.import.scm))
    12        ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm")
     19       ("scheme.base.so"
     20        ("scheme.base.scm" "scheme.base-interface.scm" "r7rs-support.so")
    1321        (compile -s -O3 -d1 scheme.base.scm -J -emit-type-file scheme.base.types)
    1422        (compile -s -O3 -d0 scheme.base.import.scm)))
     
    3442 'r7rs
    3543 `("r7rs.so" "r7rs.import.so"
     44   "r7rs-support.so" "r7rs-support.import.so"
     45   "r7rs-library.so" "r7rs-library.import.so"
    3646   "r7rs-compile-time.so" "r7rs-compile-time.import.so"
    3747   "scheme.base.so" "scheme.base.import.so" "scheme.base.types"
  • release/4/r7rs/trunk/scheme.base-interface.scm

    r30929 r30990  
    3636  define-record-type
    3737  define-syntax
    38   define-values
     38  define-values ; TODO
    3939  denominator numerator
    4040  do
     
    156156  vector-append
    157157  vector-copy vector-copy!
     158  vector-fill!
    158159  vector-for-each
    159160  vector-length
  • release/4/r7rs/trunk/scheme.base.scm

    r30929 r30990  
    11(module scheme.base ()
    22
    3 (import (except chicken with-exception-handler include
    4                         quotient remainder modulo vector-copy!))
     3(import (rename (except chicken modulo quotient remainder
     4                                vector-copy!
     5                                with-exception-handler)
     6                (features feature-keywords)))
     7
    58(import (except scheme syntax-rules cond-expand
    69                       assoc list-set! list-tail member
    710                       char=? char<? char>? char<=? char>=?
    811                       string=? string<? string>? string<=? string>=?
    9                        string-copy string->list vector->list))
     12                       string-copy string->list vector->list vector-fill!))
     13
    1014(import (prefix (only scheme char=? char<? char>? char<=? char>=?
    1115                             string=? string<? string>? string<=? string>=?)
    1216                %))
    13 (import (rename (only chicken include) (include %include)))
     17
    1418(import (rename (only srfi-4 make-u8vector subu8vector u8vector u8vector?
    1519                             u8vector-length u8vector-ref u8vector-set!
     
    2327                (write-u8vector write-bytevector)))
    2428
    25 (%include "scheme.base-interface.scm")
     29(include "scheme.base-interface.scm")
    2630
    2731;; For syntax definition helpers.
    28 (begin-for-syntax (require-library r7rs-compile-time))
     32(import-for-syntax r7rs-support)
    2933(import-for-syntax r7rs-compile-time)
    30 (import r7rs-compile-time)
     34(begin-for-syntax
     35  (require-library r7rs-compile-time))
     36(import r7rs-support)
    3137(import numbers)
    3238
     
    5864;;;
    5965
    60 (define-syntax include
    61   (er-macro-transformer
    62    (lambda (e r c)
    63      (cons (r 'begin)
    64            (append-map (cut read-forms <> #f) (cdr e))))))
    65 
    66 (define-syntax include-ci
    67   (er-macro-transformer
    68    (lambda (e r c)
    69      (cons (r 'begin)
    70            (append-map (cut read-forms <> #t) (cdr e))))))
     66(define-syntax include r7rs-include)
     67(define-syntax include-ci r7rs-include-ci)
    7168
    7269;;;
     
    7471;;;
    7572
    76 (define-syntax cond-expand
    77   (er-macro-transformer
    78    (lambda (x r c)
    79      (cons (r 'begin)
    80            (process-cond-expand (cdr x))))))
    81 
     73(define-syntax cond-expand r7rs-cond-expand)
    8274
    8375;;;
     
    268260
    269261
    270 (: list-copy (forall (a) ((list-of a) -> (list-of a))))
     262(: list-copy (forall (a) (a -> a)))
    271263
    272264;; TODO: Test if this is the quickest way to do this, or whether we
    273265;; should just cons recursively like our SRFI-1 implementation does.
    274266(define (list-copy lst)
    275   (let lp ((res '())
    276            (lst lst))
    277     (if (null? lst)
    278         (##sys#fast-reverse res)
    279         (lp (cons (car lst) res) (cdr lst)))))
     267  (cond ((pair? lst)
     268         (let lp ((res '())
     269                  (lst lst))
     270           (if (pair? lst)
     271               (lp (cons (car lst) res) (cdr lst))
     272               (append (##sys#fast-reverse res) lst))))
     273        (else lst)))
    280274
    281275;;;
     
    365359(: vector-copy (forall (a) ((vector-of a) #!optional fixnum fixnum -> (vector-of a))))
    366360(: vector-copy! (vector fixnum vector #!optional fixnum fixnum -> undefined))
     361(: vector-fill! (vector * #!optional fixnum fixnum -> undefined))
    367362(: vector->list (forall (a) ((vector-of a) #!optional fixnum fixnum -> (list-of a))))
    368363
     
    404399      ((to at from start end) (copy! to at from start end)))))
    405400
     401(define vector-fill!
     402  (let ((fill! (lambda (v f start . end)
     403                 (##sys#check-vector v 'vector-fill!)
     404                 (let* ((len (##sys#size v))
     405                        (end (optional end len)))
     406                   (##sys#check-range start 0 (fx+ end 1) 'vector-fill!)
     407                   (##sys#check-range end start (fx+ len 1) 'vector-fill!)
     408                   (do ((i start (fx+ i 1)))
     409                       ((fx= i end))
     410                     (##sys#setslot v i f))))))
     411    (case-lambda
     412      ((v f) (fill! v f 0))
     413      ((v f start) (fill! v f start))
     414      ((v f start end) (fill! v f start end)))))
     415
    406416(define vector->list
    407417  (let ((v->l (lambda (v start . end)
     
    505515                    (do ((si 0 (fx+ si 1))
    506516                         (vi start (fx+ vi 1)))
    507                         ((fx= si end) s)
     517                        ((fx= vi end) s)
    508518                      (##sys#setbyte s si (bytevector-u8-ref bv vi))))))))
    509519    (case-lambda
     
    522532                    (do ((vi 0 (fx+ vi 1))
    523533                         (si start (fx+ si 1)))
    524                         ((fx= vi end) bv)
     534                        ((fx= si end) bv)
    525535                      (bytevector-u8-set! bv vi (##sys#byte s si))))))))
    526536    (case-lambda
     
    533543;;;
    534544
    535 (: string-for-each ((char -> *) string #!rest string -> void))
    536 (: string-map ((char -> char) string #!rest string -> string))
    537 (: vector-for-each ((* -> *) vector #!rest vector -> void))
    538 (: vector-map ((* -> *) vector #!rest vector -> vector))
     545(: string-for-each ((char #!rest char -> *) string #!rest string -> void))
     546(: string-map ((char #!rest char -> char) string #!rest string -> string))
     547(: vector-for-each ((* #!rest * -> *) vector #!rest vector -> void))
     548(: vector-map ((* #!rest * -> *) vector #!rest vector -> vector))
    539549
    540550(define string-map
     
    652662          ((cadr exception-handlers) obj))))))
    653663
    654 (: error-object? (* --> boolean : (struct condition)))
     664(: error-object? (* -> boolean : (struct condition)))
    655665(: error-object-message ((struct condition) -> string))
    656666(: error-object-irritants ((struct condition) -> list))
     
    697707(: textual-port? (* --> boolean : port?))
    698708(: u8-ready? (#!optional input-port -> boolean))
    699 (: write-string (string #!optional input-port fixnum fixnum -> void))
     709(: write-string (string #!optional output-port fixnum fixnum -> void))
    700710(: write-u8 (fixnum #!optional output-port -> void))
    701711
     
    829839  (string->utf8 (get-output-string p)))
    830840
    831 )
     841;;;
     842;;; 6.14. System interface
     843;;;
     844
     845(: features (--> (list-of symbol)))
     846
     847(define (features)
     848  (map (lambda (s)
     849         (##sys#string->symbol (##sys#symbol->string s)))
     850       (feature-keywords))))
  • release/4/r7rs/trunk/scheme.char.scm

    r30898 r30990  
    88                     digit-value)
    99
     10(import chicken)
     11(import r7rs-support)
    1012(import
    1113  (except scheme
     
    2022(require-library srfi-13)
    2123(import (only srfi-13 string-map string-upcase string-downcase))
    22 
    23 (import chicken)
    24 (require-extension r7rs-compile-time)
    2524
    2625(: char-ci=? (char char #!rest char -> boolean))
  • release/4/r7rs/trunk/scheme.eval.scm

    r30284 r30990  
    33
    44  (import (rename scheme (eval %eval)) chicken)
    5   (import r7rs-compile-time)
     5  (use r7rs-library)
    66
    77;;;
     
    1313  (define (eval expr env) (%eval expr env))
    1414
    15   (: environment (list -> (struct environment)))
     15  (: environment (#!rest list -> (struct environment)))
    1616
    1717  (define (environment . specs)
     
    3030         (let ((mod (##sys#find-module name)))
    3131           (##sys#make-structure 'environment
    32             name
     32            (cons 'import specs)
    3333            (let ((env (##sys#slot mod 13)))
    3434              (append (car env) (cdr env))) ; combine env and syntax bindings
  • release/4/r7rs/trunk/scheme.process-context.scm

    r30325 r30990  
    66
    77  (import scheme
    8           (rename chicken (exit chicken:exit))
     8          (rename chicken (exit chicken-exit))
    99          foreign)
    1010
     
    5757  (case-lambda
    5858    (()
    59      (chicken:exit 0))
     59     (exit 0))
    6060    ((obj)
    61      (##sys#cleanup-before-exit)
    6261     ;; ##sys#dynamic-unwind is hidden, have to unwind manually.
    6362     ; (##sys#dynamic-unwind '() (length ##sys#dynamic-winds))
     
    6867           (after)
    6968           (unwind))))
    70      (##core#inline "C_exit_runtime" (->exit-status obj)))))
     69     ;; The built-in exit runs cleanup handlers for us.
     70     (chicken-exit (->exit-status obj)))))
    7171
    7272(define emergency-exit
  • release/4/r7rs/trunk/scheme.r5rs.scm

    r30283 r30990  
    1616   (except scheme
    1717           null-environment scheme-report-environment eval
    18            and begin begin-for-syntax case cond cond-expand define
    19            define-syntax delay delay-force do else export if lambda let
    20            let* let-syntax letrec letrec* letrec-syntax module or
    21            quasiquote quote reexport require-extension
    22            require-extension-for-syntax require-library set! syntax))
     18           and begin begin-for-syntax case cond cond-expand
     19           define define-syntax delay delay-force do export if
     20           import import-for-syntax lambda let let* let-syntax
     21           letrec letrec* letrec-syntax module or quasiquote quote
     22           reexport require-extension require-extension-for-syntax
     23           require-library set! syntax syntax-rules))
    2324
    2425  (define-constant null-environment-identifiers
  • release/4/r7rs/trunk/synrules.scm

    r29104 r30990  
    129129                                        ellipsis?
    130130                                        (meta-variables pattern 0 ellipsis? '() #f)))))
    131          (%syntax-error "ill-formed syntax rule" rule)))
     131         (##sys#syntax-error "ill-formed syntax rule" rule)))
    132132
    133133   ;; Generate code to test whether input expression matches pattern
     
    210210                  (if (<= (cdr probe) dim)
    211211                      template
    212                       (%syntax-error "template dimension error (too few ellipses?)"
    213                                      template))
     212                      (##sys#syntax-error-hook
     213                       "template dimension error (too few ellipses?)"
     214                       template))
    214215                  `(,%rename (##core#syntax ,template)))))
    215216           ((ellipsis-escaped-pattern? template el?)
    216217            (if (or (not (pair? (cdr template))) (pair? (cddr template)))
    217                 (%syntax-error "Invalid escaped ellipsis template" template)
     218                (##sys#syntax-error-hook "Invalid escaped ellipsis template" template)
    218219                (process-template (cadr template) dim (lambda _ #f) env)))
    219220           ((segment-template? template el?)
     
    223224                    (free-meta-variables (car template) seg-dim el? env '())))
    224225              (if (null? vars)
    225                   (%syntax-error "too many ellipses" template)
     226                  (##sys#syntax-error-hook "too many ellipses" template)
    226227                  (let* ((x (process-template (car template) seg-dim el? env))
    227228                         (gen (if (and (pair? vars)
     
    296297          (cond
    297298           (seen-segment?
    298             (%syntax-error "Only one segment per level is allowed" p))
     299            (##sys#syntax-error-hook "Only one segment per level is allowed" p))
    299300           ((not (list? p))             ; Improper list
    300             (%syntax-error "Cannot combine dotted tail and ellipsis" p))
     301            (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p))
    301302           (else #t))))
    302303
Note: See TracChangeset for help on using the changeset viewer.