(declare (usual-integrations))
\f
-;;;; SRFI features
+;;;; Definitions
-(define $cond-expand
- (spar-transformer->runtime
- (delay (scons-rule (cond-expand-pattern) generate-cond-expand))))
-
-(define (cond-expand-pattern)
- (define clause-pattern
- (let ((clause-pattern* (lambda args (apply clause-pattern args))))
- (spar-or
- (spar-push-subform-if identifier? spar-arg:form)
- (spar-subform
- (spar-call-with-values list
- (spar-or
- (spar-and (spar-push-subform-if spar-arg:id=? 'or)
- (spar* clause-pattern*)
- (spar-match-null))
- (spar-and (spar-push-subform-if spar-arg:id=? 'and)
- (spar* clause-pattern*)
- (spar-match-null))
- (spar-and (spar-push-subform-if spar-arg:id=? 'not)
- clause-pattern*
- (spar-match-null))))))))
- `((value id=?)
- (+ (subform (cons (spar ,clause-pattern)
- (* any))))))
-
-(define (generate-cond-expand id=? clauses)
-
- (define (process-clauses clauses)
- (cond ((not (pair? clauses))
- (generate '()))
- ((id=? 'else (caar clauses))
- (if (pair? (cdr clauses))
- (syntax-error "ELSE clause must be last:" clauses))
- (generate (cdar clauses)))
- (else
- (process-clause (car clauses)
- (lambda () (process-clauses (cdr clauses)))))))
-
- (define (process-clause clause failure)
- (eval-req (car clause)
- (lambda () (generate (cdr clause)))
- failure))
-
- (define (eval-req req success failure)
- (cond ((identifier? req) (if (supported-feature? req) (success) (failure)))
- ((id=? 'or (car req)) (eval-or (cdr req) success failure))
- ((id=? 'and (car req)) (eval-and (cdr req) success failure))
- ((id=? 'not (car req)) (eval-req (cadr req) failure success))
- (else (error "Unknown requirement:" req))))
-
- (define (supported-feature? req)
- (let ((p
- (find (lambda (p)
- (id=? (car p) req))
- supported-features)))
- (and p
- ((cdr p)))))
-
- (define (eval-or reqs success failure)
- (if (pair? reqs)
- (eval-req (car reqs)
- success
- (lambda () (eval-or (cdr reqs) success failure)))
- (failure)))
-
- (define (eval-and reqs success failure)
- (if (pair? reqs)
- (eval-req (car reqs)
- (lambda () (eval-and (cdr reqs) success failure))
- failure)
- (success)))
-
- (define (generate forms)
- (apply scons-begin forms))
-
- (process-clauses clauses))
-\f
-(define (define-feature name procedure)
- (set! supported-features (cons (cons name procedure) supported-features))
- name)
-
-(define supported-features '())
-
-(define (always) #t)
-
-(define-feature 'mit always)
-(define-feature 'mit/gnu always)
-
-;; r7rs features
-(define-feature 'exact-closed always)
-(define-feature 'exact-complex always)
-(define-feature 'ieee-float always)
-(define-feature 'full-unicode always)
-(define-feature 'ratio always)
-
-(define-feature 'swank always) ;Provides SWANK module for SLIME
-(define-feature 'srfi-0 always) ;COND-EXPAND
-(define-feature 'srfi-1 always) ;List Library
-(define-feature 'srfi-2 always) ;AND-LET*
-(define-feature 'srfi-6 always) ;Basic String Ports
-(define-feature 'srfi-8 always) ;RECEIVE
-(define-feature 'srfi-9 always) ;DEFINE-RECORD-TYPE
-(define-feature 'srfi-23 always) ;ERROR
-(define-feature 'srfi-27 always) ;Sources of Random Bits
-(define-feature 'srfi-30 always) ;Nested Multi-Line Comments (#| ... |#)
-(define-feature 'srfi-39 always) ;Parameter objects
-(define-feature 'srfi-62 always) ;S-expression comments
-(define-feature 'srfi-69 always) ;Basic Hash Tables
-(define-feature 'srfi-131 always) ;ERR5RS Record Syntax (reduced)
-
-(define ((os? value))
- (eq? value microcode-id/operating-system))
-
-(define-feature 'windows (os? 'nt))
-(define-feature 'unix (os? 'unix))
-(define-feature 'posix (os? 'unix))
-
-(define ((os-variant? value))
- (string=? value microcode-id/operating-system-variant))
-
-(define-feature 'darwin (os-variant? "OS X"))
-(define-feature 'gnu-linux (os-variant? "GNU/Linux"))
-
-(define-feature 'big-endian (lambda () (host-big-endian?)))
-(define-feature 'little-endian (lambda () (not (host-big-endian?))))
-
-(define ((machine? value))
- (string=? value microcode-id/machine-type))
-
-(define-feature 'i386 (machine? "IA-32"))
-(define-feature 'x86-64 (machine? "x86-64"))
-
-(define (get-supported-features)
- (filter-map (lambda (p)
- (and ((cdr p))
- (car p)))
- supported-features))
-\f
-(define $receive
- (spar-transformer->runtime
- (delay
- (scons-rule `(,r4rs-lambda-list? any (+ any))
- (lambda (bvl expr body-forms)
- (scons-call (scons-close 'call-with-values)
- (scons-lambda '() expr)
- (apply scons-lambda bvl body-forms)))))))
-
-(define $define-record-type
- (spar-transformer->runtime
- (delay
- (scons-rule
- `((or (and id (value #f))
- (subform id any))
- (or (and id (value #f))
- (and ,not (value #f))
- (subform id (* symbol)))
- (or id ,not)
- (* (subform (list symbol id (or id (value #f))))))
- (lambda (type-name parent maker-name maker-args pred-name field-specs)
- (apply scons-begin
- (scons-define type-name
- (scons-call (scons-close 'new-make-record-type)
- (scons-quote type-name)
- (scons-quote (map car field-specs))
- (or parent (default-object))))
- (if maker-name
- (scons-define maker-name
- (scons-call (scons-close 'record-constructor)
- type-name
- (if maker-args
- (scons-quote maker-args)
- (default-object))))
- (default-object))
- (if pred-name
- (scons-define pred-name
- (scons-call (scons-close 'record-predicate) type-name))
- (default-object))
- (append-map (lambda (field-spec)
- (let ((name (car field-spec))
- (accessor (cadr field-spec))
- (modifier (caddr field-spec)))
- (list (scons-define accessor
- (scons-call
- (scons-close 'record-accessor)
- type-name
- (scons-quote name)))
- (if modifier
- (scons-define modifier
- (scons-call
- (scons-close 'record-modifier)
- type-name
- (scons-quote name)))
- (default-object)))))
- field-specs)))))))
-\f
(define $define
(spar-transformer->runtime
(delay
(define (optional-value-pattern)
`(or any (value-of ,unassigned-expression)))
+
+(define (unassigned-expression)
+ `(,keyword:unassigned))
+
+(define (unspecific-expression)
+ `(,keyword:unspecific))
\f
+;;;; Let-like forms
+
(define $let
(spar-transformer->runtime
(delay
(apply scons-begin (map scons-set! ids vals))
(scons-call (apply scons-lambda '() body-forms)))))))))
\f
-(define $case
+(define $parameterize
(spar-transformer->runtime
(delay
(scons-rule
- (let ((action-pattern
- '(if (ignore-if id=? =>)
- (list (value =>)
- any)
- (cons (value begin)
- (+ any)))))
- `(any
- (* (subform (cons (subform (* any))
- ,action-pattern)))
- (or (subform (ignore-if id=? else)
- ,action-pattern)
- (value #f))))
- (lambda (expr clauses else-clause)
- (let ((temp (new-identifier 'key)))
-
- (define (process-clause clause rest)
- (if (pair? (car clause))
- (scons-if (process-predicate (car clause))
- (process-action (cadr clause) (cddr clause))
- rest)
- rest))
+ `((subform (* (subform (list id any))))
+ (+ any))
+ (lambda (bindings body-forms)
+ (let ((ids (map car bindings))
+ (vals (map cadr bindings)))
+ (scons-call (scons-close 'parameterize*)
+ (apply scons-call
+ (scons-close 'list)
+ (map (lambda (id val)
+ (scons-call (scons-close 'cons) id val))
+ ids
+ vals))
+ (apply scons-lambda '() body-forms))))))))
- (define (process-predicate items)
- (apply scons-or
- (map (lambda (item)
- (scons-call (scons-close
- (if (or (symbol? item)
- (boolean? item)
- ;; implementation dependent:
- (char? item)
- (fix:fixnum? item))
- 'eq?
- 'eqv?))
- (scons-quote item)
- temp))
- items)))
+;;; SRFI 2: and-let*
- (define (process-action type exprs)
- (cond ((eq? type 'begin) (apply scons-begin exprs))
- ((eq? type '=>) (scons-call (car exprs) temp))
- (else (error "Unrecognized action type:" type))))
+;;; The SRFI document is a little unclear about the semantics, imposes
+;;; the weird restriction that variables may be duplicated (citing
+;;; LET*'s similar restriction, which doesn't actually exist), and the
+;;; reference implementation is highly non-standard and hard to
+;;; follow. This passes all of the tests except for the one that
+;;; detects duplicate bound variables, though.
- (scons-let (list (list temp expr))
- (fold-right process-clause
- (if else-clause
- (process-action (car else-clause)
- (cdr else-clause))
- (unspecific-expression))
- clauses))))))))
+(define $and-let*
+ (spar-transformer->runtime
+ (delay
+ (scons-rule
+ `((subform (* (list (or id (subform any) (subform id any)))))
+ (* any))
+ (lambda (clauses body-exprs)
+ (let recur1 ((conjunct #t) (clauses clauses))
+ (cond ((pair? clauses)
+ (scons-and conjunct
+ (let ((clause (car clauses)))
+ (let ((rest (recur1 (car clause) (cdr clauses))))
+ (if (pair? (cdr clause))
+ (scons-let (list clause) rest)
+ rest)))))
+ ((pair? body-exprs)
+ (scons-and conjunct (apply scons-begin body-exprs)))
+ (else
+ conjunct))))))))
+
+;;; SRFI 8: receive
+
+(define $receive
+ (spar-transformer->runtime
+ (delay
+ (scons-rule `(,r4rs-lambda-list? any (+ any))
+ (lambda (bvl expr body-forms)
+ (scons-call (scons-close 'call-with-values)
+ (scons-lambda '() expr)
+ (apply scons-lambda bvl body-forms)))))))
\f
+;;;; Conditionals
+
(define $cond
(spar-transformer->runtime
(delay
(car binding)))
bindings)))))))))))
\f
+(define $case
+ (spar-transformer->runtime
+ (delay
+ (scons-rule
+ (let ((action-pattern
+ '(if (ignore-if id=? =>)
+ (list (value =>)
+ any)
+ (cons (value begin)
+ (+ any)))))
+ `(any
+ (* (subform (cons (subform (* any))
+ ,action-pattern)))
+ (or (subform (ignore-if id=? else)
+ ,action-pattern)
+ (value #f))))
+ (lambda (expr clauses else-clause)
+ (let ((temp (new-identifier 'key)))
+
+ (define (process-clause clause rest)
+ (if (pair? (car clause))
+ (scons-if (process-predicate (car clause))
+ (process-action (cadr clause) (cddr clause))
+ rest)
+ rest))
+
+ (define (process-predicate items)
+ (apply scons-or
+ (map (lambda (item)
+ (scons-call (scons-close
+ (if (or (symbol? item)
+ (boolean? item)
+ ;; implementation dependent:
+ (char? item)
+ (fix:fixnum? item))
+ 'eq?
+ 'eqv?))
+ (scons-quote item)
+ temp))
+ items)))
+
+ (define (process-action type exprs)
+ (cond ((eq? type 'begin) (apply scons-begin exprs))
+ ((eq? type '=>) (scons-call (car exprs) temp))
+ (else (error "Unrecognized action type:" type))))
+
+ (scons-let (list (list temp expr))
+ (fold-right process-clause
+ (if else-clause
+ (process-action (car else-clause)
+ (cdr else-clause))
+ (unspecific-expression))
+ clauses))))))))
+\f
+(define-syntax $and
+ (syntax-rules ()
+ ((and) #t)
+ ((and expr0) expr0)
+ ((and expr0 expr1+ ...) (if expr0 (and expr1+ ...) #f))))
+
+(define-syntax $when
+ (syntax-rules ()
+ ((when condition form ...)
+ (if condition
+ (begin form ...)))))
+
+(define-syntax $unless
+ (syntax-rules ()
+ ((unless condition form ...)
+ (if (not condition)
+ (begin form ...)))))
+\f
+;;;; Quasiquote
+
(define-syntax $quasiquote
(er-macro-transformer
(lambda (form rename compare)
(syntax-check '(_ expression) form)
(descend (cadr form) 0 finalize))))
\f
-;;;; SRFI 2: AND-LET*
+;;;; SRFI 0 and R7RS: cond-expand
-;;; The SRFI document is a little unclear about the semantics, imposes
-;;; the weird restriction that variables may be duplicated (citing
-;;; LET*'s similar restriction, which doesn't actually exist), and the
-;;; reference implementation is highly non-standard and hard to
-;;; follow. This passes all of the tests except for the one that
-;;; detects duplicate bound variables, though.
-
-(define $and-let*
+(define $cond-expand
(spar-transformer->runtime
- (delay
- (scons-rule
- `((subform (* (list (or id (subform any) (subform id any)))))
- (* any))
- (lambda (clauses body-exprs)
- (let recur1 ((conjunct #t) (clauses clauses))
- (cond ((pair? clauses)
- (scons-and conjunct
- (let ((clause (car clauses)))
- (let ((rest (recur1 (car clause) (cdr clauses))))
- (if (pair? (cdr clause))
- (scons-let (list clause) rest)
- rest)))))
- ((pair? body-exprs)
- (scons-and conjunct (apply scons-begin body-exprs)))
- (else
- conjunct))))))))
+ (delay (scons-rule (cond-expand-pattern) generate-cond-expand))))
-(define $access
+(define (cond-expand-pattern)
+ (define clause-pattern
+ (let ((clause-pattern* (lambda args (apply clause-pattern args))))
+ (spar-or
+ (spar-push-subform-if identifier? spar-arg:form)
+ (spar-subform
+ (spar-call-with-values list
+ (spar-or
+ (spar-and (spar-push-subform-if spar-arg:id=? 'or)
+ (spar* clause-pattern*)
+ (spar-match-null))
+ (spar-and (spar-push-subform-if spar-arg:id=? 'and)
+ (spar* clause-pattern*)
+ (spar-match-null))
+ (spar-and (spar-push-subform-if spar-arg:id=? 'not)
+ clause-pattern*
+ (spar-match-null))))))))
+ `((value id=?)
+ (+ (subform (cons (spar ,clause-pattern)
+ (* any))))))
+
+(define (generate-cond-expand id=? clauses)
+
+ (define (process-clauses clauses)
+ (cond ((not (pair? clauses))
+ (generate '()))
+ ((id=? 'else (caar clauses))
+ (if (pair? (cdr clauses))
+ (syntax-error "ELSE clause must be last:" clauses))
+ (generate (cdar clauses)))
+ (else
+ (process-clause (car clauses)
+ (lambda () (process-clauses (cdr clauses)))))))
+
+ (define (process-clause clause failure)
+ (eval-req (car clause)
+ (lambda () (generate (cdr clause)))
+ failure))
+
+ (define (eval-req req success failure)
+ (cond ((identifier? req) (if (supported-feature? req) (success) (failure)))
+ ((id=? 'or (car req)) (eval-or (cdr req) success failure))
+ ((id=? 'and (car req)) (eval-and (cdr req) success failure))
+ ((id=? 'not (car req)) (eval-req (cadr req) failure success))
+ (else (error "Unknown requirement:" req))))
+
+ (define (supported-feature? req)
+ (let ((p
+ (find (lambda (p)
+ (id=? (car p) req))
+ supported-features)))
+ (and p
+ ((cdr p)))))
+
+ (define (eval-or reqs success failure)
+ (if (pair? reqs)
+ (eval-req (car reqs)
+ success
+ (lambda () (eval-or (cdr reqs) success failure)))
+ (failure)))
+
+ (define (eval-and reqs success failure)
+ (if (pair? reqs)
+ (eval-req (car reqs)
+ (lambda () (eval-and (cdr reqs) success failure))
+ failure)
+ (success)))
+
+ (define (generate forms)
+ (apply scons-begin forms))
+
+ (process-clauses clauses))
+\f
+(define (define-feature name procedure)
+ (set! supported-features (cons (cons name procedure) supported-features))
+ name)
+
+(define supported-features '())
+
+(define (always) #t)
+
+(define-feature 'mit always)
+(define-feature 'mit/gnu always)
+
+;; r7rs features
+(define-feature 'exact-closed always)
+(define-feature 'exact-complex always)
+(define-feature 'ieee-float always)
+(define-feature 'full-unicode always)
+(define-feature 'ratio always)
+
+(define-feature 'swank always) ;Provides SWANK module for SLIME
+(define-feature 'srfi-0 always) ;COND-EXPAND
+(define-feature 'srfi-1 always) ;List Library
+(define-feature 'srfi-2 always) ;AND-LET*
+(define-feature 'srfi-6 always) ;Basic String Ports
+(define-feature 'srfi-8 always) ;RECEIVE
+(define-feature 'srfi-9 always) ;DEFINE-RECORD-TYPE
+(define-feature 'srfi-23 always) ;ERROR
+(define-feature 'srfi-27 always) ;Sources of Random Bits
+(define-feature 'srfi-30 always) ;Nested Multi-Line Comments (#| ... |#)
+(define-feature 'srfi-39 always) ;Parameter objects
+(define-feature 'srfi-62 always) ;S-expression comments
+(define-feature 'srfi-69 always) ;Basic Hash Tables
+(define-feature 'srfi-131 always) ;ERR5RS Record Syntax (reduced)
+
+(define ((os? value))
+ (eq? value microcode-id/operating-system))
+
+(define-feature 'windows (os? 'nt))
+(define-feature 'unix (os? 'unix))
+(define-feature 'posix (os? 'unix))
+
+(define ((os-variant? value))
+ (string=? value microcode-id/operating-system-variant))
+
+(define-feature 'darwin (os-variant? "OS X"))
+(define-feature 'gnu-linux (os-variant? "GNU/Linux"))
+
+(define-feature 'big-endian (lambda () (host-big-endian?)))
+(define-feature 'little-endian (lambda () (not (host-big-endian?))))
+
+(define ((machine? value))
+ (string=? value microcode-id/machine-type))
+
+(define-feature 'i386 (machine? "IA-32"))
+(define-feature 'x86-64 (machine? "x86-64"))
+
+(define (get-supported-features)
+ (filter-map (lambda (p)
+ (and ((cdr p))
+ (car p)))
+ supported-features))
+\f
+;;;; SRFI 9, SRFI 131, R7RS: define-record-type
+
+(define $define-record-type
(spar-transformer->runtime
(delay
(scons-rule
- `((+ symbol)
- any)
- (lambda (names expr)
- (fold-right (lambda (name expr)
- (scons-call keyword:access name expr))
- expr
- names))))))
+ `((or (and id (value #f))
+ (subform id any))
+ (or (and id (value #f))
+ (and ,not (value #f))
+ (subform id (* symbol)))
+ (or id ,not)
+ (* (subform (list symbol id (or id (value #f))))))
+ (lambda (type-name parent maker-name maker-args pred-name field-specs)
+ (apply scons-begin
+ (scons-define type-name
+ (scons-call (scons-close 'new-make-record-type)
+ (scons-quote type-name)
+ (scons-quote (map car field-specs))
+ (or parent (default-object))))
+ (if maker-name
+ (scons-define maker-name
+ (scons-call (scons-close 'record-constructor)
+ type-name
+ (if maker-args
+ (scons-quote maker-args)
+ (default-object))))
+ (default-object))
+ (if pred-name
+ (scons-define pred-name
+ (scons-call (scons-close 'record-predicate) type-name))
+ (default-object))
+ (append-map (lambda (field-spec)
+ (let ((name (car field-spec))
+ (accessor (cadr field-spec))
+ (modifier (caddr field-spec)))
+ (list (scons-define accessor
+ (scons-call
+ (scons-close 'record-accessor)
+ type-name
+ (scons-quote name)))
+ (if modifier
+ (scons-define modifier
+ (scons-call
+ (scons-close 'record-modifier)
+ type-name
+ (scons-quote name)))
+ (default-object)))))
+ field-specs)))))))
+\f
+;;;; MIT/GNU Scheme custom syntax
(define $cons-stream
(spar-transformer->runtime
self
exprs)))
self)))))))
+
+(define $access
+ (spar-transformer->runtime
+ (delay
+ (scons-rule
+ `((+ symbol)
+ any)
+ (lambda (names expr)
+ (fold-right (lambda (name expr)
+ (scons-call keyword:access name expr))
+ expr
+ names))))))
+
+(define-syntax $local-declare
+ (syntax-rules ()
+ ((local-declare ((directive datum ...) ...) form0 form1+ ...)
+ (let ()
+ (declare (directive datum ...) ...)
+ form0 form1+ ...))))
+
+(define-syntax $begin0
+ (syntax-rules ()
+ ((begin0 form0 form1+ ...)
+ (let ((result form0))
+ form1+ ...
+ result))))
+
+(define-syntax $assert
+ (syntax-rules ()
+ ((assert condition . extra)
+ (if (not condition)
+ (error "Assertion failed:" 'condition . extra)))))
\f
(define $define-integrable
(spar-transformer->runtime
swap!
(apply scons-lambda '() body-forms)
swap!)))))))))
-
-(define $parameterize
- (spar-transformer->runtime
- (delay
- (scons-rule
- `((subform (* (subform (list id any))))
- (+ any))
- (lambda (bindings body-forms)
- (let ((ids (map car bindings))
- (vals (map cadr bindings)))
- (scons-call (scons-close 'parameterize*)
- (apply scons-call
- (scons-close 'list)
- (map (lambda (id val)
- (scons-call (scons-close 'cons) id val))
- ids
- vals))
- (apply scons-lambda '() body-forms))))))))
-\f
-(define-syntax $local-declare
- (syntax-rules ()
- ((local-declare ((directive datum ...) ...) form0 form1+ ...)
- (let ()
- (declare (directive datum ...) ...)
- form0 form1+ ...))))
-
-(define (unspecific-expression)
- `(,keyword:unspecific))
-
-(define (unassigned-expression)
- `(,keyword:unassigned))
-
-(define-syntax $begin0
- (syntax-rules ()
- ((begin0 form0 form1+ ...)
- (let ((result form0))
- form1+ ...
- result))))
-
-(define-syntax $assert
- (syntax-rules ()
- ((assert condition . extra)
- (if (not condition)
- (error "Assertion failed:" 'condition . extra)))))
-
-(define-syntax $and
- (syntax-rules ()
- ((and) #t)
- ((and expr0) expr0)
- ((and expr0 expr1+ ...) (if expr0 (and expr1+ ...) #f))))
-
-(define-syntax $when
- (syntax-rules ()
- ((when condition form ...)
- (if condition
- (begin form ...)))))
-
-(define-syntax $unless
- (syntax-rules ()
- ((unless condition form ...)
- (if (not condition)
- (begin form ...)))))
\f
(define-syntax $define-bundle-interface
(sc-macro-transformer
projects / mit-scheme.git / commitdiff