~ chicken-r7rs (master) /r7rs.scm

 1(module r7rs (define-library import import-for-syntax export syntax-rules)
 2  (import (except scheme syntax-rules))
 3  (import (only chicken.base include))
 4  (import (only chicken.module export))
 5  (import (only chicken.platform feature? register-feature!))
 6  (import (only chicken.syntax begin-for-syntax))
 7
 8  ;; For syntax definition helpers.
 9  (import-syntax-for-syntax matchable)
10  (import-for-syntax r7rs-compile-time)
11
12  ;; For #u8(...) syntax.
13  (import srfi-4)
14
15  ;; Reexport (scheme base).
16  (import scheme.base)
17  (include "scheme.base-interface.scm")
18
19(let ((old-hook ##sys#user-read-hook))
20  ;; XXX Read syntax for "#false" and srfi-4's "#f32(...)" and friends
21  ;; don't play nicely together, so we have to copy some of srfi-4.scm's
22  ;; read hook here, to fall back on when we hit a vector of floats.
23  (define read-srfi-4-vector
24    (let ([consers (list 'u8 list->u8vector
25			 's8 list->s8vector
26			 'u16 list->u16vector
27			 's16 list->s16vector
28			 'u32 list->u32vector
29			 's32 list->s32vector
30			 'f32 list->f32vector
31			 'f64 list->f64vector)])
32      (lambda (tag port)
33	(let* ([x (read port)])
34	  (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
35		[(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
36		[else (##sys#read-error port "illegal bytevector syntax" tag)])))))
37  (set! ##sys#user-read-hook
38	(lambda (char port)
39	  (define (fail tok)
40	    (##sys#read-error port "invalid boolean literal syntax" tok))
41          (case char
42            ((#\f #\F #\t #\T)
43	     (let ((sym (##sys#read port ##sys#default-read-info-hook)))
44	       (if (not (symbol? sym))
45		   (fail sym)
46		   (let ((str (symbol->string sym)))
47		     (cond ((or (string-ci=? "t" str) (string-ci=? "true" str)) #t)
48			   ((or (string-ci=? "f" str) (string-ci=? "false" str)) #f)
49			   (else (read-srfi-4-vector sym port)))))))
50            (else (old-hook char port))))))
51
52;;;
53;;; 5.4. Syntax definitions
54;;;
55(include "synrules.scm")
56
57;;;
58;;; 5.6.1. Libraries
59;;;
60
61(define-syntax define-library r7rs-define-library)
62
63;;;
64;;; Appendix B. Standard feature identifiers
65;;;
66
67(register-feature! #:r7rs))