All the SRFIs from S48 0.57.
This commit is contained in:
mainzelm
parent
66a5384a98
commit
ea31d95dbc
|
|
@ -0,0 +1,74 @@
|
|||
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
; Nondeterminism, Prolog, or whatever you want to call it. This is
|
||||
; depth-first search implemented using call/cc.
|
||||
|
||||
; The fluid variable $FAIL is bound to a thunk to be called in case of failure.
|
||||
|
||||
(define $fail
|
||||
(make-fluid (make-cell
|
||||
(lambda ()
|
||||
(error "call to FAIL outside WITH-NONDETERMINISM")))))
|
||||
|
||||
(define (with-nondeterminism thunk)
|
||||
(let-fluid $fail
|
||||
(make-cell (lambda ()
|
||||
(error "nondeterminism ran out of choices")))
|
||||
thunk))
|
||||
|
||||
; Call the current failure function.
|
||||
|
||||
(define (fail)
|
||||
((fluid-cell-ref $fail)))
|
||||
|
||||
; For the alternation operator, Icon's a | b or McCarthy's (amb a b),
|
||||
; we write (either a b).
|
||||
|
||||
(define-syntax either
|
||||
(syntax-rules ()
|
||||
((either) (fail))
|
||||
((either x) x)
|
||||
((either x y ...)
|
||||
(%either (lambda () x) (lambda () (either y ...))))))
|
||||
|
||||
; 1. Save the current failure procedure and continuation.
|
||||
; 2. Install a new failure procedure that restores the old failure procedure
|
||||
; and continuation and then calls THUNK2.
|
||||
; 3. Call THUNK1.
|
||||
|
||||
(define (%either thunk1 thunk2)
|
||||
(let ((save (fluid-cell-ref $fail)))
|
||||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(fluid-cell-set! $fail
|
||||
(lambda ()
|
||||
(fluid-cell-set! $fail save)
|
||||
(k thunk2)))
|
||||
thunk1)))))
|
||||
|
||||
; (one-value x) is Prolog's CUT operator. X is allowed to return only once.
|
||||
|
||||
(define-syntax one-value
|
||||
(syntax-rules ()
|
||||
((one-value x) (%one-value (lambda () x)))))
|
||||
|
||||
(define (%one-value thunk)
|
||||
(let ((save (fluid-cell-ref $fail)))
|
||||
(call-with-values thunk
|
||||
(lambda args
|
||||
(fluid-cell-set! $fail save)
|
||||
(apply values args)))))
|
||||
|
||||
; (all-values a) returns a list of all the possible values of the
|
||||
; expression a. Prolog calls this "bagof"; I forget what Icon calls it.
|
||||
|
||||
(define-syntax all-values
|
||||
(syntax-rules ()
|
||||
((all-values x) (%all-values (lambda () x)))))
|
||||
|
||||
(define (%all-values thunk)
|
||||
(let ((results '()))
|
||||
(either (let ((new-result (thunk)))
|
||||
(set! results (cons new-result results))
|
||||
(fail))
|
||||
(reverse results))))
|
||||
|
|
@ -412,3 +412,121 @@
|
|||
(cons-stream :syntax) head tail the-empty-stream empty-stream?
|
||||
explode implode get put))
|
||||
|
||||
; Olin's encyclopedic SRFIs.
|
||||
|
||||
(define-interface srfi-1-interface
|
||||
(export xcons make-list list-tabulate cons* list-copy
|
||||
proper-list? circular-list? dotted-list? not-pair? null-list? list=
|
||||
circular-list length+
|
||||
iota
|
||||
first second third fourth fifth sixth seventh eighth ninth tenth
|
||||
car+cdr
|
||||
take drop
|
||||
take-right drop-right
|
||||
take! drop-right!
|
||||
split-at split-at!
|
||||
last last-pair
|
||||
zip unzip1 unzip2 unzip3 unzip4 unzip5
|
||||
count
|
||||
append! append-reverse append-reverse! concatenate concatenate!
|
||||
unfold fold pair-fold reduce
|
||||
unfold-right fold-right pair-fold-right reduce-right
|
||||
append-map append-map! map! pair-for-each filter-map map-in-order
|
||||
filter partition remove
|
||||
filter! partition! remove!
|
||||
find find-tail any every list-index
|
||||
take-while drop-while take-while!
|
||||
span break span! break!
|
||||
delete delete!
|
||||
alist-cons alist-copy
|
||||
delete-duplicates delete-duplicates!
|
||||
alist-delete alist-delete!
|
||||
reverse!
|
||||
lset<= lset= lset-adjoin
|
||||
lset-union lset-intersection lset-difference lset-xor
|
||||
lset-diff+intersection
|
||||
lset-union! lset-intersection! lset-difference! lset-xor!
|
||||
lset-diff+intersection!))
|
||||
|
||||
(define-interface srfi-13-interface
|
||||
(export string-map string-map!
|
||||
string-fold string-unfold
|
||||
string-fold-right string-unfold-right
|
||||
string-tabulate string-for-each string-for-each-index
|
||||
string-every string-any
|
||||
string-hash string-hash-ci
|
||||
string-compare string-compare-ci
|
||||
string= string< string> string<= string>= string<>
|
||||
string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>
|
||||
string-downcase string-upcase string-titlecase
|
||||
string-downcase! string-upcase! string-titlecase!
|
||||
string-take string-take-right
|
||||
string-drop string-drop-right
|
||||
string-pad string-pad-right
|
||||
string-trim string-trim-right string-trim-both
|
||||
string-filter string-delete
|
||||
string-index string-index-right
|
||||
string-skip string-skip-right
|
||||
string-count
|
||||
string-prefix-length string-prefix-length-ci
|
||||
string-suffix-length string-suffix-length-ci
|
||||
string-prefix? string-prefix-ci?
|
||||
string-suffix? string-suffix-ci?
|
||||
string-contains string-contains-ci
|
||||
string-copy! substring/shared
|
||||
string-reverse string-reverse! reverse-list->string
|
||||
string-concatenate
|
||||
string-concatenate/shared
|
||||
string-concatenate-reverse
|
||||
string-append/shared
|
||||
xsubstring string-xcopy!
|
||||
string-null?
|
||||
string-join
|
||||
string-tokenize
|
||||
string-replace
|
||||
|
||||
string->list string-copy string-fill!
|
||||
string? make-string string-length string-ref string-set!
|
||||
string string-append list->string))
|
||||
|
||||
(define-interface srfi-14-interface
|
||||
(export char-set? char-set=
|
||||
char-set<= char-set-hash char-set-cursor char-set-ref
|
||||
char-set-cursor-next end-of-char-set? char-set-fold char-set-unfold
|
||||
char-set-unfold! char-set-for-each char-set-map char-set-copy
|
||||
char-set
|
||||
|
||||
list->char-set string->char-set
|
||||
list->char-set! string->char-set!
|
||||
|
||||
char-set-filter ucs-range->char-set
|
||||
|
||||
; the SRFI defines ->CHAR-SET, but that isn't a legal identifier
|
||||
x->char-set
|
||||
|
||||
char-set-filter! ucs-range->char-set!
|
||||
|
||||
char-set->list char-set->string
|
||||
|
||||
char-set-size char-set-count char-set-contains?
|
||||
char-set-every char-set-any
|
||||
|
||||
char-set-adjoin char-set-delete
|
||||
char-set-adjoin! char-set-delete!
|
||||
|
||||
|
||||
char-set-complement char-set-union char-set-intersection
|
||||
char-set-complement! char-set-union! char-set-intersection!
|
||||
|
||||
char-set-difference char-set-xor char-set-diff+intersection
|
||||
char-set-difference! char-set-xor! char-set-diff+intersection!
|
||||
|
||||
char-set:lower-case char-set:upper-case char-set:title-case
|
||||
char-set:letter char-set:digit char-set:letter+digit
|
||||
char-set:graphic char-set:printing char-set:whitespace
|
||||
char-set:iso-control char-set:punctuation char-set:symbol
|
||||
char-set:hex-digit char-set:blank char-set:ascii
|
||||
char-set:empty char-set:full
|
||||
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -662,6 +662,155 @@
|
|||
features) ; make-immutable
|
||||
(files (big finite-type)))
|
||||
|
||||
; nondeterminism via call/cc
|
||||
|
||||
(define-structure nondeterminism (export with-nondeterminism
|
||||
((either one-value all-values) :syntax)
|
||||
fail)
|
||||
(open scheme-level-2
|
||||
fluids cells
|
||||
(subset signals (error)))
|
||||
(files (big either)))
|
||||
|
||||
;----------------
|
||||
; SRFI packages
|
||||
|
||||
; SRFI-0 - Doesn't work with the module system.
|
||||
|
||||
; Olin's list library.
|
||||
|
||||
(define-structure srfi-1 srfi-1-interface
|
||||
(open scheme-level-2
|
||||
receiving
|
||||
(subset signals (error)))
|
||||
(files (srfi srfi-1)))
|
||||
|
||||
(define-structure srfi-2 (export (and-let* :syntax))
|
||||
(open scheme-level-2
|
||||
signals) ; error
|
||||
(files (srfi srfi-2)))
|
||||
|
||||
; SRFI-3 - withdrawn
|
||||
; SRFI-4 - needs hacks to the reader
|
||||
|
||||
(define-structure srfi-5 (export (let :syntax))
|
||||
(open (modify scheme-level-2 (hide let)))
|
||||
(files (srfi srfi-5)))
|
||||
|
||||
(define-structure srfi-6 (export open-input-string
|
||||
open-output-string
|
||||
get-output-string)
|
||||
(open (modify extended-ports
|
||||
(rename (make-string-input-port open-input-string)
|
||||
(make-string-output-port open-output-string)
|
||||
(string-output-port-output get-output-string)))))
|
||||
|
||||
; Configuration language
|
||||
|
||||
(define-structure srfi-7 (export) ; defines a command
|
||||
(open scheme
|
||||
|
||||
; for parsing programs
|
||||
receiving
|
||||
nondeterminism
|
||||
(subset signals (error))
|
||||
|
||||
(subset package-commands-internal (config-package))
|
||||
ensures-loaded
|
||||
(subset packages (note-structure-name!))
|
||||
|
||||
; for defining the command
|
||||
(subset command-processor (define-user-command-syntax
|
||||
user-command-environment))
|
||||
(subset environments (environment-define!)))
|
||||
|
||||
(begin
|
||||
(define available-srfis
|
||||
'(srfi-1 srfi-2 srfi-5 srfi-6 srfi-7 srfi-8 srfi-9
|
||||
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17 srfi-23))
|
||||
|
||||
; Some SRFI's redefine Scheme variables.
|
||||
(define shadowed
|
||||
'((srfi-1 map for-each member assoc)
|
||||
(srfi-5 let)
|
||||
(srfi-13 string->list string-copy string-fill!)
|
||||
(srfi-17 set!)))
|
||||
)
|
||||
|
||||
(files (srfi srfi-7)))
|
||||
|
||||
; Taken directly from the SRFI document (or from `receiving', take your pick).
|
||||
|
||||
(define-structure srfi-8 (export (receive :syntax))
|
||||
(open scheme-level-2)
|
||||
(begin
|
||||
(define-syntax receive
|
||||
(syntax-rules ()
|
||||
((receive formals expression body ...)
|
||||
(call-with-values (lambda () expression)
|
||||
(lambda formals body ...)))))))
|
||||
|
||||
; SRFI-9 is a slight modification of DEFINE-RECORD-TYPE.
|
||||
|
||||
(define-structure srfi-9 (export (define-record-type :syntax))
|
||||
(open scheme-level-2
|
||||
(with-prefix define-record-types sys:))
|
||||
(begin
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
((define-record-type type-name . stuff)
|
||||
(sys:define-record-type type-name type-name . stuff))))))
|
||||
|
||||
; SRFI-10 - no stand-alone interface.
|
||||
|
||||
(define-structure srfi-11 (export (let-values :syntax)
|
||||
(let*-values :syntax))
|
||||
(open scheme-level-2)
|
||||
(files (srfi srfi-11)))
|
||||
|
||||
; SRFI-12 - withdrawn
|
||||
|
||||
; Two more encyclopedias from Olin.
|
||||
|
||||
(define-structure srfi-13 srfi-13-interface
|
||||
(open scheme-level-2
|
||||
bitwise
|
||||
srfi-8 srfi-14
|
||||
(subset signals (error)))
|
||||
(files (srfi srfi-13)))
|
||||
|
||||
(define-structure srfi-14 srfi-14-interface
|
||||
(open scheme-level-2
|
||||
bitwise
|
||||
srfi-9
|
||||
(modify ascii (rename (char->ascii %char->latin1)
|
||||
(ascii->char %latin1->char)))
|
||||
(subset features (make-immutable!))
|
||||
(subset signals (error)))
|
||||
(files (srfi srfi-14)))
|
||||
|
||||
; SRFI-15 - withdrawn
|
||||
|
||||
(define-structure srfi-16 (export (case-lambda :syntax))
|
||||
(open scheme-level-2
|
||||
(subset signals (error)))
|
||||
(files (srfi srfi-16)))
|
||||
|
||||
(define-structure srfi-17 (export (set! :syntax) setter)
|
||||
(open (modify scheme-level-2 (rename (set! scheme-set!)))
|
||||
(subset signals (error))
|
||||
(subset util (unspecific)))
|
||||
(files (srfi srfi-17)))
|
||||
|
||||
; SRFI-18 - no implementation given
|
||||
; SRFI-19 - implementation is specific to MzScheme
|
||||
; SRFI-20 - withdrawn
|
||||
; SRFI-21 - no implementation given
|
||||
; SRFI-22 - not final yet
|
||||
|
||||
(define-structure srfi-23 (export error)
|
||||
(open (subset signals (error))))
|
||||
|
||||
; ... end of package definitions.
|
||||
|
||||
; Temporary compatibility stuff
|
||||
|
|
@ -687,6 +836,7 @@
|
|||
bignums ratnums recnums floatnums
|
||||
build
|
||||
callback
|
||||
cells
|
||||
command-levels
|
||||
command-processor
|
||||
debugging
|
||||
|
|
@ -742,6 +892,11 @@
|
|||
;; Compatibility
|
||||
record table
|
||||
build-internals ;added by JMG
|
||||
|
||||
; SRFI packages
|
||||
srfi-1 srfi-2 srfi-5 srfi-6 srfi-7 srfi-8 srfi-9
|
||||
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17
|
||||
srfi-23
|
||||
)
|
||||
:structure)
|
||||
((define-signature define-package) :syntax)))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,38 @@
|
|||
|
||||
; Taken directly from the SRFI document.
|
||||
|
||||
(define-syntax let-values
|
||||
(syntax-rules ()
|
||||
((let-values (?binding ...) ?body0 ?body1 ...)
|
||||
(let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
|
||||
|
||||
((let-values "bind" () ?tmps ?body)
|
||||
(let ?tmps ?body))
|
||||
|
||||
((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
|
||||
(let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
|
||||
|
||||
((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
|
||||
(call-with-values
|
||||
(lambda () ?e0)
|
||||
(lambda ?args
|
||||
(let-values "bind" ?bindings ?tmps ?body))))
|
||||
|
||||
((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
|
||||
(let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
|
||||
|
||||
((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
|
||||
(call-with-values
|
||||
(lambda () ?e0)
|
||||
(lambda (?arg ... . x)
|
||||
(let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
|
||||
|
||||
(define-syntax let*-values
|
||||
(syntax-rules ()
|
||||
((let*-values () ?body0 ?body1 ...)
|
||||
(begin ?body0 ?body1 ...))
|
||||
|
||||
((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
|
||||
(let-values (?binding0)
|
||||
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,901 @@
|
|||
;;; SRFI-14 character-sets library -*- Scheme -*-
|
||||
;;;
|
||||
;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom.
|
||||
;;; - Massively rehacked & extended by Olin Shivers 6/98.
|
||||
;;; - Massively redesigned and rehacked 5/2000 during SRFI process.
|
||||
;;; At this point, the code bears the following relationship to the
|
||||
;;; MIT Scheme code: "This is my grandfather's axe. My father replaced
|
||||
;;; the head, and I have replaced the handle." Nonetheless, we preserve
|
||||
;;; the MIT Scheme copyright:
|
||||
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
|
||||
;;; The MIT Scheme license is a "free software" license. See the end of
|
||||
;;; this file for the tedious details.
|
||||
|
||||
;;; Exports:
|
||||
;;; char-set? char-set= char-set<=
|
||||
;;; char-set-hash
|
||||
;;; char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
|
||||
;;; char-set-fold char-set-unfold char-set-unfold!
|
||||
;;; char-set-for-each char-set-map
|
||||
;;; char-set-copy char-set
|
||||
;;;
|
||||
;;; list->char-set string->char-set
|
||||
;;; list->char-set! string->char-set!
|
||||
;;;
|
||||
;;; filterchar-set ucs-range->char-set ->char-set
|
||||
;;; filterchar-set! ucs-range->char-set!
|
||||
;;;
|
||||
;;; char-set->list char-set->string
|
||||
;;;
|
||||
;;; char-set-size char-set-count char-set-contains?
|
||||
;;; char-set-every char-set-any
|
||||
;;;
|
||||
;;; char-set-adjoin char-set-delete
|
||||
;;; char-set-adjoin! char-set-delete!
|
||||
;;;
|
||||
|
||||
;;; char-set-complement char-set-union char-set-intersection
|
||||
;;; char-set-complement! char-set-union! char-set-intersection!
|
||||
;;;
|
||||
;;; char-set-difference char-set-xor char-set-diff+intersection
|
||||
;;; char-set-difference! char-set-xor! char-set-diff+intersection!
|
||||
;;;
|
||||
;;; char-set:lower-case char-set:upper-case char-set:title-case
|
||||
;;; char-set:letter char-set:digit char-set:letter+digit
|
||||
;;; char-set:graphic char-set:printing char-set:whitespace
|
||||
;;; char-set:iso-control char-set:punctuation char-set:symbol
|
||||
;;; char-set:hex-digit char-set:blank char-set:ascii
|
||||
;;; char-set:empty char-set:full
|
||||
|
||||
;;; Imports
|
||||
;;; This code has the following non-R5RS dependencies:
|
||||
;;; - ERROR
|
||||
;;; - %LATIN1->CHAR %CHAR->LATIN1
|
||||
;;; - LET-OPTIONALS* and :OPTIONAL macros for parsing, checking & defaulting
|
||||
;;; optional arguments from rest lists.
|
||||
;;; - BITWISE-AND for CHAR-SET-HASH
|
||||
;;; - The SRFI-19 DEFINE-RECORD-TYPE record macro
|
||||
;;; - A simple CHECK-ARG procedure:
|
||||
;;; (lambda (pred val caller) (if (not (pred val)) (error val caller)))
|
||||
|
||||
;;; This is simple code, not great code. Char sets are represented as 256-char
|
||||
;;; strings. If char I is ASCII/Latin-1 0, then it isn't in the set; if char I
|
||||
;;; is ASCII/Latin-1 1, then it is in the set.
|
||||
;;; - Should be rewritten to use bit strings or byte vecs.
|
||||
;;; - Is Latin-1 specific. Would certainly have to be rewritten for Unicode.
|
||||
|
||||
;;; See the end of the file for porting and performance-tuning notes.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
; Start S48 additions
|
||||
|
||||
(define (check-arg pred val caller)
|
||||
(if (not (pred val))
|
||||
(error val caller))
|
||||
val)
|
||||
|
||||
(define-syntax :optional
|
||||
(syntax-rules ()
|
||||
((:optional rest default-exp)
|
||||
(let ((maybe-arg rest))
|
||||
(if (pair? maybe-arg)
|
||||
(if (null? (cdr maybe-arg)) (car maybe-arg)
|
||||
(error "too many optional arguments" maybe-arg))
|
||||
default-exp)))
|
||||
|
||||
((:optional rest default-exp arg-test)
|
||||
(let ((maybe-arg rest))
|
||||
(if (pair? maybe-arg)
|
||||
(if (null? (cdr maybe-arg))
|
||||
(let ((val (car maybe-arg)))
|
||||
(if (arg-test val) val
|
||||
(error "Optional argument failed test"
|
||||
'arg-test val)))
|
||||
(error "too many optional arguments" maybe-arg))
|
||||
default-exp)))))
|
||||
|
||||
(define-syntax let-optionals*
|
||||
(syntax-rules ()
|
||||
((let-optionals* arg (opt-clause ...) body ...)
|
||||
(let ((rest arg))
|
||||
(%let-optionals* rest (opt-clause ...) body ...)))))
|
||||
|
||||
(define-syntax %let-optionals*
|
||||
(syntax-rules ()
|
||||
((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
|
||||
(call-with-values (lambda () (xparser arg))
|
||||
(lambda (rest var ...)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg ((var default) opt-clause ...) body ...)
|
||||
(call-with-values (lambda () (if (null? arg) (values default '())
|
||||
(values (car arg) (cdr arg))))
|
||||
(lambda (var rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg ((var default test) opt-clause ...) body ...)
|
||||
(call-with-values (lambda ()
|
||||
(if (null? arg) (values default '())
|
||||
(let ((var (car arg)))
|
||||
(if test (values var (cdr arg))
|
||||
(error "arg failed LET-OPT test" var)))))
|
||||
(lambda (var rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
|
||||
(call-with-values (lambda ()
|
||||
(if (null? arg) (values default #f '())
|
||||
(let ((var (car arg)))
|
||||
(if test (values var #t (cdr arg))
|
||||
(error "arg failed LET-OPT test" var)))))
|
||||
(lambda (var supplied? rest)
|
||||
(%let-optionals* rest (opt-clause ...) body ...))))
|
||||
|
||||
((%let-optionals* arg (rest) body ...)
|
||||
(let ((rest arg)) body ...))
|
||||
|
||||
((%let-optionals* arg () body ...)
|
||||
(if (null? arg) (begin body ...)
|
||||
(error "Too many arguments in let-opt" arg)))))
|
||||
|
||||
; End S48 additions
|
||||
|
||||
(define-record-type :char-set
|
||||
(make-char-set s)
|
||||
char-set?
|
||||
(s char-set:s))
|
||||
|
||||
(define (%string-copy s) (substring s 0 (string-length s)))
|
||||
|
||||
;;; Parse, type-check & default a final optional BASE-CS parameter from
|
||||
;;; a rest argument. Return a *fresh copy* of the underlying string.
|
||||
;;; The default is the empty set. The PROC argument is to help us
|
||||
;;; generate informative error exceptions.
|
||||
|
||||
(define (%default-base maybe-base proc)
|
||||
(if (pair? maybe-base)
|
||||
(let ((bcs (car maybe-base))
|
||||
(tail (cdr maybe-base)))
|
||||
(if (null? tail)
|
||||
(if (char-set? bcs) (%string-copy (char-set:s bcs))
|
||||
(error "BASE-CS parameter not a char-set" proc bcs))
|
||||
(error "Expected final base char set -- too many parameters"
|
||||
proc maybe-base)))
|
||||
(make-string 256 (%latin1->char 0))))
|
||||
|
||||
;;; If CS is really a char-set, do CHAR-SET:S, otw report an error msg on
|
||||
;;; behalf of our caller, PROC. This procedure exists basically to provide
|
||||
;;; explicit error-checking & reporting.
|
||||
|
||||
(define (%char-set:s/check cs proc)
|
||||
(let lp ((cs cs))
|
||||
(if (char-set? cs) (char-set:s cs)
|
||||
(lp (error "Not a char-set" cs proc)))))
|
||||
|
||||
|
||||
|
||||
;;; These internal functions hide a lot of the dependency on the
|
||||
;;; underlying string representation of char sets. They should be
|
||||
;;; inlined if possible.
|
||||
|
||||
(define (si=0? s i) (zero? (%char->latin1 (string-ref s i))))
|
||||
(define (si=1? s i) (not (si=0? s i)))
|
||||
(define c0 (%latin1->char 0))
|
||||
(define c1 (%latin1->char 1))
|
||||
(define (si s i) (%char->latin1 (string-ref s i)))
|
||||
(define (%set0! s i) (string-set! s i c0))
|
||||
(define (%set1! s i) (string-set! s i c1))
|
||||
|
||||
;;; These do various "s[i] := s[i] op val" operations -- see
|
||||
;;; %CHAR-SET-ALGEBRA. They are used to implement the various
|
||||
;;; set-algebra procedures.
|
||||
(define (setv! s i v) (string-set! s i (%latin1->char v))) ; SET to a Value.
|
||||
(define (%not! s i v) (setv! s i (- 1 v)))
|
||||
(define (%and! s i v) (if (zero? v) (%set0! s i)))
|
||||
(define (%or! s i v) (if (not (zero? v)) (%set1! s i)))
|
||||
(define (%minus! s i v) (if (not (zero? v)) (%set0! s i)))
|
||||
(define (%xor! s i v) (if (not (zero? v)) (setv! s i (- 1 (si s i)))))
|
||||
|
||||
|
||||
(define (char-set-copy cs)
|
||||
(make-char-set (%string-copy (%char-set:s/check cs char-set-copy))))
|
||||
|
||||
(define (char-set= . rest)
|
||||
(or (null? rest)
|
||||
(let* ((cs1 (car rest))
|
||||
(rest (cdr rest))
|
||||
(s1 (%char-set:s/check cs1 char-set=)))
|
||||
(let lp ((rest rest))
|
||||
(or (not (pair? rest))
|
||||
(and (string=? s1 (%char-set:s/check (car rest) char-set=))
|
||||
(lp (cdr rest))))))))
|
||||
|
||||
(define (char-set<= . rest)
|
||||
(or (null? rest)
|
||||
(let ((cs1 (car rest))
|
||||
(rest (cdr rest)))
|
||||
(let lp ((s1 (%char-set:s/check cs1 char-set<=)) (rest rest))
|
||||
(or (not (pair? rest))
|
||||
(let ((s2 (%char-set:s/check (car rest) char-set<=))
|
||||
(rest (cdr rest)))
|
||||
(if (eq? s1 s2) (lp s2 rest) ; Fast path
|
||||
(let lp2 ((i 255)) ; Real test
|
||||
(if (< i 0) (lp s2 rest)
|
||||
(and (<= (si s1 i) (si s2 i))
|
||||
(lp2 (- i 1))))))))))))
|
||||
|
||||
;;; Hash
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
|
||||
;;; to keep the intermediate values small. (We do the calculation with just
|
||||
;;; enough bits to represent BOUND, masking off high bits at each step in
|
||||
;;; calculation. If this screws up any important properties of the hash
|
||||
;;; function I'd like to hear about it. -Olin)
|
||||
;;;
|
||||
;;; If you keep BOUND small enough, the intermediate calculations will
|
||||
;;; always be fixnums. How small is dependent on the underlying Scheme system;
|
||||
;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
|
||||
;;; Schemes that give you at least 29 signed bits for fixnums. The core
|
||||
;;; calculation that you don't want to overflow is, worst case,
|
||||
;;; (+ 65535 (* 37 (- bound 1)))
|
||||
;;; where 65535 is the max character code. Choose the default BOUND to be the
|
||||
;;; biggest power of two that won't cause this expression to fixnum overflow,
|
||||
;;; and everything will be copacetic.
|
||||
|
||||
(define (char-set-hash cs . maybe-bound)
|
||||
(let* ((bound (:optional maybe-bound 4194304 (lambda (n) (and (integer? n)
|
||||
(exact? n)
|
||||
(<= 0 n)))))
|
||||
(bound (if (zero? bound) 4194304 bound)) ; 0 means default.
|
||||
(s (%char-set:s/check cs char-set-hash))
|
||||
;; Compute a 111...1 mask that will cover BOUND-1:
|
||||
(mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
|
||||
(if (>= i bound) (- i 1) (lp (+ i i))))))
|
||||
|
||||
(let lp ((i 255) (ans 0))
|
||||
(if (< i 0) (modulo ans bound)
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(bitwise-and mask (+ (* 37 ans) i))))))))
|
||||
|
||||
|
||||
(define (char-set-contains? cs char)
|
||||
(si=1? (%char-set:s/check cs char-set-contains?)
|
||||
(%char->latin1 (check-arg char? char char-set-contains?))))
|
||||
|
||||
(define (char-set-size cs)
|
||||
(let ((s (%char-set:s/check cs char-set-size)))
|
||||
(let lp ((i 255) (size 0))
|
||||
(if (< i 0) size
|
||||
(lp (- i 1) (+ size (si s i)))))))
|
||||
|
||||
(define (char-set-count pred cset)
|
||||
(check-arg procedure? pred char-set-count)
|
||||
(let ((s (%char-set:s/check cset char-set-count)))
|
||||
(let lp ((i 255) (count 0))
|
||||
(if (< i 0) count
|
||||
(lp (- i 1)
|
||||
(if (and (si=1? s i) (pred (%latin1->char i)))
|
||||
(+ count 1)
|
||||
count))))))
|
||||
|
||||
|
||||
;;; -- Adjoin & delete
|
||||
|
||||
(define (%set-char-set set proc cs chars)
|
||||
(let ((s (%string-copy (%char-set:s/check cs proc))))
|
||||
(for-each (lambda (c) (set s (%char->latin1 c)))
|
||||
chars)
|
||||
(make-char-set s)))
|
||||
|
||||
(define (%set-char-set! set proc cs chars)
|
||||
(let ((s (%char-set:s/check cs proc)))
|
||||
(for-each (lambda (c) (set s (%char->latin1 c)))
|
||||
chars))
|
||||
cs)
|
||||
|
||||
(define (char-set-adjoin cs . chars)
|
||||
(%set-char-set %set1! char-set-adjoin cs chars))
|
||||
(define (char-set-adjoin! cs . chars)
|
||||
(%set-char-set! %set1! char-set-adjoin! cs chars))
|
||||
(define (char-set-delete cs . chars)
|
||||
(%set-char-set %set0! char-set-delete cs chars))
|
||||
(define (char-set-delete! cs . chars)
|
||||
(%set-char-set! %set0! char-set-delete! cs chars))
|
||||
|
||||
|
||||
;;; Cursors
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Simple implementation. A cursors is an integer index into the
|
||||
;;; mark vector, and -1 for the end-of-char-set cursor.
|
||||
;;;
|
||||
;;; If we represented char sets as a bit set, we could do the following
|
||||
;;; trick to pick the lowest bit out of the set:
|
||||
;;; (count-bits (xor (- cset 1) cset))
|
||||
;;; (But first mask out the bits already scanned by the cursor first.)
|
||||
|
||||
(define (char-set-cursor cset)
|
||||
(%char-set-cursor-next cset 256 char-set-cursor))
|
||||
|
||||
(define (end-of-char-set? cursor) (< cursor 0))
|
||||
|
||||
(define (char-set-ref cset cursor) (%latin1->char cursor))
|
||||
|
||||
(define (char-set-cursor-next cset cursor)
|
||||
(check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i 255))) cursor
|
||||
char-set-cursor-next)
|
||||
(%char-set-cursor-next cset cursor char-set-cursor-next))
|
||||
|
||||
(define (%char-set-cursor-next cset cursor proc) ; Internal
|
||||
(let ((s (%char-set:s/check cset proc)))
|
||||
(let lp ((cur cursor))
|
||||
(let ((cur (- cur 1)))
|
||||
(if (or (< cur 0) (si=1? s cur)) cur
|
||||
(lp cur))))))
|
||||
|
||||
|
||||
;;; -- for-each map fold unfold every any
|
||||
|
||||
(define (char-set-for-each proc cs)
|
||||
(check-arg procedure? proc char-set-for-each)
|
||||
(let ((s (%char-set:s/check cs char-set-for-each)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (si=1? s i) (proc (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
(define (char-set-map proc cs)
|
||||
(check-arg procedure? proc char-set-map)
|
||||
(let ((s (%char-set:s/check cs char-set-map))
|
||||
(ans (make-string 256 c0)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (si=1? s i)
|
||||
(%set1! ans (%char->latin1 (proc (%latin1->char i)))))
|
||||
(lp (- i 1)))))
|
||||
(make-char-set ans)))
|
||||
|
||||
(define (char-set-fold kons knil cs)
|
||||
(check-arg procedure? kons char-set-fold)
|
||||
(let ((s (%char-set:s/check cs char-set-fold)))
|
||||
(let lp ((i 255) (ans knil))
|
||||
(if (< i 0) ans
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(kons (%latin1->char i) ans)))))))
|
||||
|
||||
(define (char-set-every pred cs)
|
||||
(check-arg procedure? pred char-set-every)
|
||||
(let ((s (%char-set:s/check cs char-set-every)))
|
||||
(let lp ((i 255))
|
||||
(or (< i 0)
|
||||
(and (or (si=0? s i) (pred (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
(define (char-set-any pred cs)
|
||||
(check-arg procedure? pred char-set-any)
|
||||
(let ((s (%char-set:s/check cs char-set-any)))
|
||||
(let lp ((i 255))
|
||||
(and (>= i 0)
|
||||
(or (and (si=1? s i) (pred (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
|
||||
(define (%char-set-unfold! proc p f g s seed)
|
||||
(check-arg procedure? p proc)
|
||||
(check-arg procedure? f proc)
|
||||
(check-arg procedure? g proc)
|
||||
(let lp ((seed seed))
|
||||
(cond ((not (p seed)) ; P says we are done.
|
||||
(%set1! s (%char->latin1 (f seed))) ; Add (F SEED) to set.
|
||||
(lp (g seed)))))) ; Loop on (G SEED).
|
||||
|
||||
(define (char-set-unfold p f g seed . maybe-base)
|
||||
(let ((bs (%default-base maybe-base char-set-unfold)))
|
||||
(%char-set-unfold! char-set-unfold p f g bs seed)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (char-set-unfold! p f g seed base-cset)
|
||||
(%char-set-unfold! char-set-unfold! p f g
|
||||
(%char-set:s/check base-cset char-set-unfold!)
|
||||
seed)
|
||||
base-cset)
|
||||
|
||||
|
||||
|
||||
;;; list <--> char-set
|
||||
|
||||
(define (%list->char-set! chars s)
|
||||
(for-each (lambda (char) (%set1! s (%char->latin1 char)))
|
||||
chars))
|
||||
|
||||
(define (char-set . chars)
|
||||
(let ((s (make-string 256 c0)))
|
||||
(%list->char-set! chars s)
|
||||
(make-char-set s)))
|
||||
|
||||
(define (list->char-set chars . maybe-base)
|
||||
(let ((bs (%default-base maybe-base list->char-set)))
|
||||
(%list->char-set! chars bs)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (list->char-set! chars base-cs)
|
||||
(%list->char-set! chars (%char-set:s/check base-cs list->char-set!))
|
||||
base-cs)
|
||||
|
||||
|
||||
(define (char-set->list cs)
|
||||
(let ((s (%char-set:s/check cs char-set->list)))
|
||||
(let lp ((i 255) (ans '()))
|
||||
(if (< i 0) ans
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(cons (%latin1->char i) ans)))))))
|
||||
|
||||
|
||||
|
||||
;;; string <--> char-set
|
||||
|
||||
(define (%string->char-set! str bs proc)
|
||||
(check-arg string? str proc)
|
||||
(do ((i (- (string-length str) 1) (- i 1)))
|
||||
((< i 0))
|
||||
(%set1! bs (%char->latin1 (string-ref str i)))))
|
||||
|
||||
(define (string->char-set str . maybe-base)
|
||||
(let ((bs (%default-base maybe-base string->char-set)))
|
||||
(%string->char-set! str bs string->char-set)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (string->char-set! str base-cs)
|
||||
(%string->char-set! str (%char-set:s/check base-cs string->char-set!)
|
||||
string->char-set!)
|
||||
base-cs)
|
||||
|
||||
|
||||
(define (char-set->string cs)
|
||||
(let* ((s (%char-set:s/check cs char-set->string))
|
||||
(ans (make-string (char-set-size cs))))
|
||||
(let lp ((i 255) (j 0))
|
||||
(if (< i 0) ans
|
||||
(let ((j (if (si=0? s i) j
|
||||
(begin (string-set! ans j (%latin1->char i))
|
||||
(+ j 1)))))
|
||||
(lp (- i 1) j))))))
|
||||
|
||||
|
||||
;;; -- UCS-range -> char-set
|
||||
|
||||
(define (%ucs-range->char-set! lower upper error? bs proc)
|
||||
(check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) lower proc)
|
||||
(check-arg (lambda (x) (and (integer? x) (exact? x) (<= lower x))) upper proc)
|
||||
|
||||
(if (and (< lower upper) (< 256 upper) error?)
|
||||
(error "Requested UCS range contains unavailable characters -- this implementation only supports Latin-1"
|
||||
proc lower upper))
|
||||
|
||||
(let lp ((i (- (min upper 256) 1)))
|
||||
(cond ((<= lower i) (%set1! bs i) (lp (- i 1))))))
|
||||
|
||||
(define (ucs-range->char-set lower upper . rest)
|
||||
(let-optionals* rest ((error? #f) rest)
|
||||
(let ((bs (%default-base rest ucs-range->char-set)))
|
||||
(%ucs-range->char-set! lower upper error? bs ucs-range->char-set)
|
||||
(make-char-set bs))))
|
||||
|
||||
(define (ucs-range->char-set! lower upper error? base-cs)
|
||||
(%ucs-range->char-set! lower upper error?
|
||||
(%char-set:s/check base-cs ucs-range->char-set!)
|
||||
ucs-range->char-set)
|
||||
base-cs)
|
||||
|
||||
|
||||
;;; -- predicate -> char-set
|
||||
|
||||
(define (%char-set-filter! pred ds bs proc)
|
||||
(check-arg procedure? pred proc)
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (and (si=1? ds i) (pred (%latin1->char i)))
|
||||
(%set1! bs i))
|
||||
(lp (- i 1))))))
|
||||
|
||||
(define (char-set-filter predicate domain . maybe-base)
|
||||
(let ((bs (%default-base maybe-base char-set-filter)))
|
||||
(%char-set-filter! predicate
|
||||
(%char-set:s/check domain char-set-filter!)
|
||||
bs
|
||||
char-set-filter)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (char-set-filter! predicate domain base-cs)
|
||||
(%char-set-filter! predicate
|
||||
(%char-set:s/check domain char-set-filter!)
|
||||
(%char-set:s/check base-cs char-set-filter!)
|
||||
char-set-filter!)
|
||||
base-cs)
|
||||
|
||||
|
||||
;;; {string, char, char-set, char predicate} -> char-set
|
||||
|
||||
(define (x->char-set x)
|
||||
(cond ((char-set? x) x)
|
||||
((string? x) (string->char-set x))
|
||||
((char? x) (char-set x))
|
||||
(else (error "->char-set: Not a charset, string or char." x))))
|
||||
|
||||
|
||||
|
||||
;;; Set algebra
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; The exported ! procs are "linear update" -- allowed, but not required, to
|
||||
;;; side-effect their first argument when computing their result. In other
|
||||
;;; words, you must use them as if they were completely functional, just like
|
||||
;;; their non-! counterparts, and you must additionally ensure that their
|
||||
;;; first arguments are "dead" at the point of call. In return, we promise a
|
||||
;;; more efficient result, plus allowing you to always assume char-sets are
|
||||
;;; unchangeable values.
|
||||
|
||||
;;; Apply P to each index and its char code in S: (P I VAL).
|
||||
;;; Used by the set-algebra ops.
|
||||
|
||||
(define (%string-iter p s)
|
||||
(let lp ((i (- (string-length s) 1)))
|
||||
(cond ((>= i 0)
|
||||
(p i (%char->latin1 (string-ref s i)))
|
||||
(lp (- i 1))))))
|
||||
|
||||
;;; String S represents some initial char-set. (OP s i val) does some
|
||||
;;; kind of s[i] := s[i] op val update. Do
|
||||
;;; S := S OP CSETi
|
||||
;;; for all the char-sets in the list CSETS. The n-ary set-algebra ops
|
||||
;;; all use this internal proc.
|
||||
|
||||
(define (%char-set-algebra s csets op proc)
|
||||
(for-each (lambda (cset)
|
||||
(let ((s2 (%char-set:s/check cset proc)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(op s i (si s2 i))
|
||||
(lp (- i 1)))))))
|
||||
csets))
|
||||
|
||||
|
||||
;;; -- Complement
|
||||
|
||||
(define (char-set-complement cs)
|
||||
(let ((s (%char-set:s/check cs char-set-complement))
|
||||
(ans (make-string 256)))
|
||||
(%string-iter (lambda (i v) (%not! ans i v)) s)
|
||||
(make-char-set ans)))
|
||||
|
||||
(define (char-set-complement! cset)
|
||||
(let ((s (%char-set:s/check cset char-set-complement!)))
|
||||
(%string-iter (lambda (i v) (%not! s i v)) s))
|
||||
cset)
|
||||
|
||||
|
||||
;;; -- Union
|
||||
|
||||
(define (char-set-union! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-union!)
|
||||
csets %or! char-set-union!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-union . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-union))))
|
||||
(%char-set-algebra s (cdr csets) %or! char-set-union)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:empty)))
|
||||
|
||||
|
||||
;;; -- Intersection
|
||||
|
||||
(define (char-set-intersection! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-intersection!)
|
||||
csets %and! char-set-intersection!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-intersection . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-intersection))))
|
||||
(%char-set-algebra s (cdr csets) %and! char-set-intersection)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:full)))
|
||||
|
||||
|
||||
;;; -- Difference
|
||||
|
||||
(define (char-set-difference! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-difference!)
|
||||
csets %minus! char-set-difference!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-difference cs1 . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check cs1 char-set-difference))))
|
||||
(%char-set-algebra s csets %minus! char-set-difference)
|
||||
(make-char-set s))
|
||||
(char-set-copy cs1)))
|
||||
|
||||
|
||||
;;; -- Xor
|
||||
|
||||
(define (char-set-xor! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-xor!)
|
||||
csets %xor! char-set-xor!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-xor . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-xor))))
|
||||
(%char-set-algebra s (cdr csets) %xor! char-set-xor)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:empty)))
|
||||
|
||||
|
||||
;;; -- Difference & intersection
|
||||
|
||||
(define (%char-set-diff+intersection! diff int csets proc)
|
||||
(for-each (lambda (cs)
|
||||
(%string-iter (lambda (i v)
|
||||
(if (not (zero? v))
|
||||
(cond ((si=1? diff i)
|
||||
(%set0! diff i)
|
||||
(%set1! int i)))))
|
||||
(%char-set:s/check cs proc)))
|
||||
csets))
|
||||
|
||||
(define (char-set-diff+intersection! cs1 cs2 . csets)
|
||||
(let ((s1 (%char-set:s/check cs1 char-set-diff+intersection!))
|
||||
(s2 (%char-set:s/check cs2 char-set-diff+intersection!)))
|
||||
(%string-iter (lambda (i v) (if (zero? v)
|
||||
(%set0! s2 i)
|
||||
(if (si=1? s2 i) (%set0! s1 i))))
|
||||
s1)
|
||||
(%char-set-diff+intersection! s1 s2 csets char-set-diff+intersection!))
|
||||
(values cs1 cs2))
|
||||
|
||||
(define (char-set-diff+intersection cs1 . csets)
|
||||
(let ((diff (string-copy (%char-set:s/check cs1 char-set-diff+intersection)))
|
||||
(int (make-string 256 c0)))
|
||||
(%char-set-diff+intersection! diff int csets char-set-diff+intersection)
|
||||
(values (make-char-set diff) (make-char-set int))))
|
||||
|
||||
|
||||
;;;; System character sets
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; These definitions are for Latin-1.
|
||||
;;;
|
||||
;;; If your Scheme implementation allows you to mark the underlying strings
|
||||
;;; as immutable, you should do so -- it would be very, very bad if a client's
|
||||
;;; buggy code corrupted these constants.
|
||||
|
||||
(define char-set:empty (char-set))
|
||||
(define char-set:full (char-set-complement char-set:empty))
|
||||
|
||||
(define char-set:lower-case
|
||||
(let* ((a-z (ucs-range->char-set #x61 #x7B))
|
||||
(latin1 (ucs-range->char-set! #xdf #xf7 #t a-z))
|
||||
(latin2 (ucs-range->char-set! #xf8 #x100 #t latin1)))
|
||||
(char-set-adjoin! latin2 (%latin1->char #xb5))))
|
||||
|
||||
(define char-set:upper-case
|
||||
(let ((A-Z (ucs-range->char-set #x41 #x5B)))
|
||||
;; Add in the Latin-1 upper-case chars.
|
||||
(ucs-range->char-set! #xd8 #xdf #t
|
||||
(ucs-range->char-set! #xc0 #xd7 #t A-Z))))
|
||||
|
||||
(define char-set:title-case char-set:empty)
|
||||
|
||||
(define char-set:letter
|
||||
(let ((u/l (char-set-union char-set:upper-case char-set:lower-case)))
|
||||
(char-set-adjoin! u/l
|
||||
(%latin1->char #xaa) ; FEMININE ORDINAL INDICATOR
|
||||
(%latin1->char #xba)))) ; MASCULINE ORDINAL INDICATOR
|
||||
|
||||
(define char-set:digit (string->char-set "0123456789"))
|
||||
(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
|
||||
|
||||
(define char-set:letter+digit
|
||||
(char-set-union char-set:letter char-set:digit))
|
||||
|
||||
(define char-set:punctuation
|
||||
(let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
|
||||
(latin-1-chars (map %latin1->char '(#xA1 ; INVERTED EXCLAMATION MARK
|
||||
#xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
#xAD ; SOFT HYPHEN
|
||||
#xB7 ; MIDDLE DOT
|
||||
#xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
#xBF)))) ; INVERTED QUESTION MARK
|
||||
(list->char-set! latin-1-chars ascii)))
|
||||
|
||||
(define char-set:symbol
|
||||
(let ((ascii (string->char-set "$+<=>^`|~"))
|
||||
(latin-1-chars (map %latin1->char '(#x00A2 ; CENT SIGN
|
||||
#x00A3 ; POUND SIGN
|
||||
#x00A4 ; CURRENCY SIGN
|
||||
#x00A5 ; YEN SIGN
|
||||
#x00A6 ; BROKEN BAR
|
||||
#x00A7 ; SECTION SIGN
|
||||
#x00A8 ; DIAERESIS
|
||||
#x00A9 ; COPYRIGHT SIGN
|
||||
#x00AC ; NOT SIGN
|
||||
#x00AE ; REGISTERED SIGN
|
||||
#x00AF ; MACRON
|
||||
#x00B0 ; DEGREE SIGN
|
||||
#x00B1 ; PLUS-MINUS SIGN
|
||||
#x00B4 ; ACUTE ACCENT
|
||||
#x00B6 ; PILCROW SIGN
|
||||
#x00B8 ; CEDILLA
|
||||
#x00D7 ; MULTIPLICATION SIGN
|
||||
#x00F7)))) ; DIVISION SIGN
|
||||
(list->char-set! latin-1-chars ascii)))
|
||||
|
||||
|
||||
(define char-set:graphic
|
||||
(char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
|
||||
|
||||
(define char-set:whitespace
|
||||
(list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
|
||||
#x0A ; LINE FEED
|
||||
#x0B ; VERTICAL TABULATION
|
||||
#x0C ; FORM FEED
|
||||
#x0D ; CARRIAGE RETURN
|
||||
#x20 ; SPACE
|
||||
#xA0))))
|
||||
|
||||
(define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) ; NO-BREAK SPACE
|
||||
|
||||
(define char-set:blank
|
||||
(list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
|
||||
#x20 ; SPACE
|
||||
#xA0)))) ; NO-BREAK SPACE
|
||||
|
||||
|
||||
(define char-set:iso-control
|
||||
(ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32)))
|
||||
|
||||
(define char-set:ascii (ucs-range->char-set 0 128))
|
||||
|
||||
; Begin S48 additions
|
||||
|
||||
(define (make-char-set-immutable! char-set)
|
||||
(make-immutable! char-set)
|
||||
(make-immutable! (char-set:s char-set)))
|
||||
|
||||
(make-char-set-immutable! char-set:empty)
|
||||
(make-char-set-immutable! char-set:full)
|
||||
(make-char-set-immutable! char-set:lower-case)
|
||||
(make-char-set-immutable! char-set:upper-case)
|
||||
(make-char-set-immutable! char-set:letter)
|
||||
(make-char-set-immutable! char-set:digit)
|
||||
(make-char-set-immutable! char-set:hex-digit)
|
||||
(make-char-set-immutable! char-set:letter+digit)
|
||||
(make-char-set-immutable! char-set:punctuation)
|
||||
(make-char-set-immutable! char-set:symbol)
|
||||
(make-char-set-immutable! char-set:graphic)
|
||||
(make-char-set-immutable! char-set:whitespace)
|
||||
(make-char-set-immutable! char-set:printing)
|
||||
(make-char-set-immutable! char-set:blank)
|
||||
(make-char-set-immutable! char-set:iso-control)
|
||||
(make-char-set-immutable! char-set:ascii)
|
||||
|
||||
; End S48 additions
|
||||
|
||||
|
||||
;;; Porting & performance-tuning notes
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; See the section at the beginning of this file on external dependencies.
|
||||
;;;
|
||||
;;; First and foremost, rewrite this code to use bit vectors of some sort.
|
||||
;;; This will give big speedup and memory savings.
|
||||
;;;
|
||||
;;; - LET-OPTIONALS* macro.
|
||||
;;; This is only used once. You can rewrite the use, port the hairy macro
|
||||
;;; definition (which is implemented using a Clinger-Rees low-level
|
||||
;;; explicit-renaming macro system), or port the simple, high-level
|
||||
;;; definition, which is less efficient.
|
||||
;;;
|
||||
;;; - :OPTIONAL macro
|
||||
;;; Very simply defined using an R5RS high-level macro.
|
||||
;;;
|
||||
;;; Implementations that can arrange for the base char sets to be immutable
|
||||
;;; should do so. (E.g., Scheme 48 allows one to mark a string as immutable,
|
||||
;;; which can be used to protect the underlying strings.) It would be very,
|
||||
;;; very bad if a client's buggy code corrupted these constants.
|
||||
;;;
|
||||
;;; There is a fair amount of argument checking. This is, strictly speaking,
|
||||
;;; unnecessary -- the actual body of the procedures will blow up if an
|
||||
;;; illegal value is passed in. However, the error message will not be as good
|
||||
;;; as if the error were caught at the "higher level." Also, a very, very
|
||||
;;; smart Scheme compiler may be able to exploit having the type checks done
|
||||
;;; early, so that the actual body of the procedures can assume proper values.
|
||||
;;; This isn't likely; this kind of compiler technology isn't common any
|
||||
;;; longer.
|
||||
;;;
|
||||
;;; The overhead of optional-argument parsing is irritating. The optional
|
||||
;;; arguments must be consed into a rest list on entry, and then parsed out.
|
||||
;;; Function call should be a matter of a few register moves and a jump; it
|
||||
;;; should not involve heap allocation! Your Scheme system may have a superior
|
||||
;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
|
||||
;;; then this is a prime candidate for optimising these procedures,
|
||||
;;; *especially* the many optional BASE-CS parameters.
|
||||
;;;
|
||||
;;; Note that optional arguments are also a barrier to procedure integration.
|
||||
;;; If your Scheme system permits you to specify alternate entry points
|
||||
;;; for a call when the number of optional arguments is known in a manner
|
||||
;;; that enables inlining/integration, this can provide performance
|
||||
;;; improvements.
|
||||
;;;
|
||||
;;; There is enough *explicit* error checking that *all* internal operations
|
||||
;;; should *never* produce a type or index-range error. Period. Feel like
|
||||
;;; living dangerously? *Big* performance win to be had by replacing string
|
||||
;;; and record-field accessors and setters with unsafe equivalents in the
|
||||
;;; code. Similarly, fixnum-specific operators can speed up the arithmetic
|
||||
;;; done on the index values in the inner loops. The only arguments that are
|
||||
;;; not completely error checked are
|
||||
;;; - string lists (complete checking requires time proportional to the
|
||||
;;; length of the list)
|
||||
;;; - procedure arguments, such as char->char maps & predicates.
|
||||
;;; There is no way to check the range & domain of procedures in Scheme.
|
||||
;;; Procedures that take these parameters cannot fully check their
|
||||
;;; arguments. But all other types to all other procedures are fully
|
||||
;;; checked.
|
||||
;;;
|
||||
;;; This does open up the alternate possibility of simply *removing* these
|
||||
;;; checks, and letting the safe primitives raise the errors. On a dumb
|
||||
;;; Scheme system, this would provide speed (by eliminating the redundant
|
||||
;;; error checks) at the cost of error-message clarity.
|
||||
;;;
|
||||
;;; In an interpreted Scheme, some of these procedures, or the internal
|
||||
;;; routines with % prefixes, are excellent candidates for being rewritten
|
||||
;;; in C.
|
||||
;;;
|
||||
;;; It would also be nice to have the ability to mark some of these
|
||||
;;; routines as candidates for inlining/integration.
|
||||
;;;
|
||||
;;; See the comments preceding the hash function code for notes on tuning
|
||||
;;; the default bound so that the code never overflows your implementation's
|
||||
;;; fixnum size into bignum calculation.
|
||||
;;;
|
||||
;;; All the %-prefixed routines in this source code are written
|
||||
;;; to be called internally to this library. They do *not* perform
|
||||
;;; friendly error checks on the inputs; they assume everything is
|
||||
;;; proper. They also do not take optional arguments. These two properties
|
||||
;;; save calling overhead and enable procedure integration -- but they
|
||||
;;; are not appropriate for exported routines.
|
||||
|
||||
;;; Copyright notice
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
|
||||
;;;
|
||||
;;; This material was developed by the Scheme project at the Massachusetts
|
||||
;;; Institute of Technology, Department of Electrical Engineering and
|
||||
;;; Computer Science. Permission to copy and modify this software, to
|
||||
;;; redistribute either the original software or a modified version, and
|
||||
;;; to use this software for any purpose is granted, subject to the
|
||||
;;; following restrictions and understandings.
|
||||
;;;
|
||||
;;; 1. Any copy made of this software must include this copyright notice
|
||||
;;; in full.
|
||||
;;;
|
||||
;;; 2. Users of this software agree to make their best efforts (a) to
|
||||
;;; return to the MIT Scheme project any improvements or extensions that
|
||||
;;; they make, so that these may be included in future releases; and (b)
|
||||
;;; to inform MIT of noteworthy uses of this software.
|
||||
;;;
|
||||
;;; 3. All materials developed as a consequence of the use of this
|
||||
;;; software shall duly acknowledge such use, in accordance with the usual
|
||||
;;; standards of acknowledging credit in academic research.
|
||||
;;;
|
||||
;;; 4. MIT has made no warrantee or representation that the operation of
|
||||
;;; this software will be error-free, and MIT is under no obligation to
|
||||
;;; provide any services, by way of maintenance, update, or otherwise.
|
||||
;;;
|
||||
;;; 5. In conjunction with products arising from the use of this material,
|
||||
;;; there shall be no use of the name of the Massachusetts Institute of
|
||||
;;; Technology nor of any adaptation thereof in any advertising,
|
||||
;;; promotional, or sales literature without prior written consent from
|
||||
;;; MIT in each case.
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
; Copied from Lars T Hansen's SRFI document.
|
||||
|
||||
(define-syntax case-lambda
|
||||
(syntax-rules ()
|
||||
((case-lambda
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...)
|
||||
(lambda args
|
||||
(let ((l (length args)))
|
||||
(case-lambda "CLAUSE" args l
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...))))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
((?a1 ...) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(if (= ?l (length '(?a1 ...)))
|
||||
(apply (lambda (?a1 ...) ?e1 ...) ?args)
|
||||
(case-lambda "CLAUSE" ?args ?l
|
||||
?clause1 ...)))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
((?a1 . ?ar) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...)
|
||||
?clause1 ...))
|
||||
((case-lambda "CLAUSE" ?args ?l
|
||||
(?a1 ?e1 ...)
|
||||
?clause1 ...)
|
||||
(let ((?a1 ?args))
|
||||
?e1 ...))
|
||||
((case-lambda "CLAUSE" ?args ?l)
|
||||
(error "Wrong number of arguments to CASE-LAMBDA."))
|
||||
((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...)
|
||||
?clause1 ...)
|
||||
(case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...)
|
||||
?clause1 ...))
|
||||
((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...)
|
||||
?clause1 ...)
|
||||
(if (>= ?l ?k)
|
||||
(apply (lambda ?al ?e1 ...) ?args)
|
||||
(case-lambda "CLAUSE" ?args ?l
|
||||
?clause1 ...)))))
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
|
||||
(define-syntax set!
|
||||
(syntax-rules ()
|
||||
((set! (?e0 ?e1 ...) ?v)
|
||||
((setter ?e0) ?e1 ... ?v))
|
||||
((set! ?i ?v)
|
||||
(scheme-set! ?i ?v))))
|
||||
|
||||
(define (setter proc)
|
||||
(let ((probe (assv proc setters)))
|
||||
(if probe
|
||||
(cdr probe)
|
||||
(error "No setter found" proc))))
|
||||
|
||||
(define (set-setter! proc setter)
|
||||
(let ((probe (assv proc setters)))
|
||||
(if probe
|
||||
(set-cdr! probe setter)
|
||||
(scheme-set! setters
|
||||
(cons (cons proc setter)
|
||||
setters)))
|
||||
(unspecific)))
|
||||
|
||||
(define (car-setter proc)
|
||||
(lambda (p v)
|
||||
(set-car! (proc p) v)))
|
||||
|
||||
(define (cdr-setter proc)
|
||||
(lambda (p v)
|
||||
(set-cdr! (proc p) v)))
|
||||
|
||||
(define setters
|
||||
(list (cons setter set-setter!)
|
||||
(cons vector-ref vector-set!)
|
||||
(cons string-ref string-set!)
|
||||
(cons car set-car!)
|
||||
(cons cdr set-cdr!)
|
||||
|
||||
(cons caar (car-setter car))
|
||||
(cons cdar (cdr-setter car))
|
||||
(cons cadr (car-setter cdr))
|
||||
(cons cddr (cdr-setter cdr))
|
||||
|
||||
(cons caaar (car-setter caar))
|
||||
(cons cdaar (cdr-setter caar))
|
||||
(cons cadar (car-setter cdar))
|
||||
(cons cddar (cdr-setter cdar))
|
||||
(cons caadr (car-setter cadr))
|
||||
(cons cdadr (cdr-setter cadr))
|
||||
(cons caddr (car-setter cddr))
|
||||
(cons cdddr (cdr-setter cddr))
|
||||
|
||||
(cons caaaar (car-setter caaar))
|
||||
(cons cdaaar (cdr-setter caaar))
|
||||
(cons cadaar (car-setter cdaar))
|
||||
(cons cddaar (cdr-setter cdaar))
|
||||
(cons caadar (car-setter cadar))
|
||||
(cons cdadar (cdr-setter cadar))
|
||||
(cons caddar (car-setter cddar))
|
||||
(cons cdddar (cdr-setter cddar))
|
||||
(cons caaadr (car-setter caadr))
|
||||
(cons cdaadr (cdr-setter caadr))
|
||||
(cons cadadr (car-setter cdadr))
|
||||
(cons cddadr (cdr-setter cdadr))
|
||||
(cons caaddr (car-setter caddr))
|
||||
(cons cdaddr (cdr-setter caddr))
|
||||
(cons cadddr (car-setter cdddr))
|
||||
(cons cddddr (cdr-setter cdddr))))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,102 @@
|
|||
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
; The reference implementation is written in some weird Scheme variant.
|
||||
; This is an attempt to produce the same result using SYNTAX-RULES.
|
||||
|
||||
; I found the both the specification and the implementation unhelpful.
|
||||
; For example, one would think that (AND-LET* ()) -> #T by analogy with
|
||||
; (AND) -> #T. The specification doesn't say.
|
||||
;
|
||||
; The following behaves correctly on the test cases at the end of the
|
||||
; reference implementation, except that it doesn't catch the three syntax
|
||||
; errors. There is no way for SYNTAX-RULES to distinguish between a
|
||||
; constant and a variable, and no easy way to check if a variable is
|
||||
; being used twice in the same AND-LET* (and why is that an error? LET*
|
||||
; allows it).
|
||||
|
||||
(define-syntax and-let*
|
||||
(syntax-rules ()
|
||||
|
||||
; No body - behave like AND.
|
||||
((and-let* ())
|
||||
#t)
|
||||
((and-let* ((var exp)))
|
||||
exp)
|
||||
((and-let* ((exp)))
|
||||
exp)
|
||||
((and-let* (var))
|
||||
var)
|
||||
|
||||
; Have body - behave like LET* but check for #F values.
|
||||
|
||||
; No clauses so just use the body.
|
||||
((and-let* () . body)
|
||||
(begin . body))
|
||||
|
||||
; (VAR VAL) clause - bind the variable and check for #F.
|
||||
((and-let* ((var val) more ...) . body)
|
||||
(let ((var val))
|
||||
(if var
|
||||
(and-let* (more ...) . body)
|
||||
#f)))
|
||||
|
||||
; Error check to catch illegal (A B ...) clauses.
|
||||
((and-let* ((exp junk . more-junk) more ...) . body)
|
||||
(error "syntax error"
|
||||
'(and-let* ((exp junk . more-junk) more ...) . body)))
|
||||
|
||||
; (EXP) and VAR - just check the value for #F.
|
||||
; There is no way for us to check that VAR is an identifier and not a
|
||||
; constant
|
||||
((and-let* ((exp) more ...) . body)
|
||||
(if exp
|
||||
(and-let* (more ...) . body)
|
||||
#f))
|
||||
((and-let* (var more ...) . body)
|
||||
(if var
|
||||
(and-let* (more ...) . body)
|
||||
#f))))
|
||||
|
||||
;(define-syntax expect
|
||||
; (syntax-rules ()
|
||||
; ((expect a b)
|
||||
; (if (not (equal? a b))
|
||||
; (error "test failed" 'a b)))))
|
||||
;
|
||||
;(expect (and-let* () 1) 1)
|
||||
;(expect (and-let* () 1 2) 2)
|
||||
;(expect (and-let* () ) #t)
|
||||
;
|
||||
;(expect (let ((x #f)) (and-let* (x))) #f)
|
||||
;(expect (let ((x 1)) (and-let* (x))) 1)
|
||||
;(expect (and-let* ((x #f)) ) #f)
|
||||
;(expect (and-let* ((x 1)) ) 1)
|
||||
;;(must-be-a-syntax-error (and-let* ( #f (x 1))) )
|
||||
;(expect (and-let* ( (#f) (x 1)) ) #f)
|
||||
;;(must-be-a-syntax-error (and-let* (2 (x 1))) )
|
||||
;(expect (and-let* ( (2) (x 1)) ) 1)
|
||||
;(expect (and-let* ( (x 1) (2)) ) 2)
|
||||
;(expect (let ((x #f)) (and-let* (x) x)) #f)
|
||||
;(expect (let ((x "")) (and-let* (x) x)) "")
|
||||
;(expect (let ((x "")) (and-let* (x) )) "")
|
||||
;(expect (let ((x 1)) (and-let* (x) (+ x 1))) 2)
|
||||
;(expect (let ((x #f)) (and-let* (x) (+ x 1))) #f)
|
||||
;(expect (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2)
|
||||
;(expect (let ((x 1)) (and-let* (((positive? x))) )) #t)
|
||||
;(expect (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f)
|
||||
;(expect (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3)
|
||||
;;(must-be-a-syntax-error
|
||||
;; (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))
|
||||
;;)
|
||||
;
|
||||
;(expect (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2)
|
||||
;(expect (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2)
|
||||
;(expect (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f)
|
||||
;(expect (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f)
|
||||
;(expect (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f)
|
||||
;
|
||||
;(expect (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
|
||||
;(expect (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
|
||||
;(expect (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
|
||||
;(expect (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2)
|
||||
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
; Rewritten, simplified, and corrected from the SRFI document.
|
||||
;
|
||||
; The SRFI implementation gets the scoping wrong for the name. It is visible
|
||||
; to the arguments and should not be.
|
||||
|
||||
(define-syntax let
|
||||
(syntax-rules ()
|
||||
|
||||
; If no name we go straight to the standard LET.
|
||||
((let () body ...)
|
||||
(standard-let () body ...))
|
||||
((let ((variable value) bindings ...) body ...)
|
||||
(standard-let ((variable value) bindings ...) body ...))
|
||||
|
||||
;; Signature-style and standard named LET.
|
||||
((let (name bindings ...) body ...)
|
||||
(let-loop name (bindings ...) () () (body ...)))
|
||||
((let name bindings body ...)
|
||||
(let-loop name bindings () () (body ...)))))
|
||||
|
||||
; A loop to walk down the list of bindings.
|
||||
|
||||
(define-syntax let-loop
|
||||
(syntax-rules ()
|
||||
|
||||
; No more bindings - make a LETREC.
|
||||
((let-loop name () (vars ...) (vals ...) body)
|
||||
((letrec ((name (lambda (vars ...) . body)))
|
||||
name)
|
||||
vals ...))
|
||||
|
||||
; Process a (var val) pair.
|
||||
((let-loop name ((var val) more ...) (vars ...) (vals ...) body)
|
||||
(let-loop name (more ...) (vars ... var) (vals ... val) body))
|
||||
|
||||
; End with a rest variable - make a LETREC.
|
||||
((let-loop name (rest-var rest-vals ...) (vars ...) (vals ...) body)
|
||||
((letrec ((name (lambda (vars ... . rest-var) . body)))
|
||||
name)
|
||||
vals ... rest-vals ...))))
|
||||
|
||||
; Four loops - normal and `signature-style', each with and without a rest
|
||||
; binding.
|
||||
;
|
||||
;(let fibonacci ((n 10) (i 0) (f0 0) (f1 1))
|
||||
; (if (= i n)
|
||||
; f0
|
||||
; (fibonacci n (+ i 1) f1 (+ f0 f1))))
|
||||
;
|
||||
;(let (fibonacci (n 10) (i 0) (f0 0) (f1 1))
|
||||
; (if (= i n)
|
||||
; f0
|
||||
; (fibonacci n (+ i 1) f1 (+ f0 f1))))
|
||||
;
|
||||
;(let fibonacci ((n 10) (i 0) . (f 0 1))
|
||||
; (if (= i n)
|
||||
; (car f)
|
||||
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
|
||||
;
|
||||
;(let (fibonacci (n 10) (i 0) . (f 0 1))
|
||||
; (if (= i n)
|
||||
; (car f)
|
||||
; (fibonacci n (+ i 1) (cadr f) (+ (car f) (cadr f)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,232 @@
|
|||
; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
|
||||
; A command for loading SRFI-7 programs. This is a user command because
|
||||
; it gets loaded after the command processor is built.
|
||||
|
||||
(define-user-command-syntax 'load-srfi-7-program "<name> <filename>"
|
||||
"load an SRFI-7 program"
|
||||
'(name filename))
|
||||
|
||||
; We create a structure, EVAL it in the configuration package, give
|
||||
; it a name, and then load it.
|
||||
|
||||
(define (load-srfi-7-program name filename)
|
||||
(eval `(define ,name ,(read-srfi-7-program filename))
|
||||
(config-package))
|
||||
(let ((structure (eval name (config-package))))
|
||||
(note-structure-name! structure name)
|
||||
(ensure-loaded structure)))
|
||||
|
||||
; Add the LOAD-SRFI-7-PROGRAM to the user's command environment.
|
||||
|
||||
(environment-define! (user-command-environment)
|
||||
'load-srfi-7-program
|
||||
load-srfi-7-program)
|
||||
|
||||
; Read a program from FILENAME and return the code for a structure that
|
||||
; contains it.
|
||||
|
||||
(define (read-srfi-7-program filename)
|
||||
(call-with-input-file filename
|
||||
(lambda (in)
|
||||
(let ((program (read in)))
|
||||
(if (and (pair? program)
|
||||
(eq? (car program) 'program))
|
||||
(receive (needed source)
|
||||
(parse-program program available-srfis)
|
||||
(if needed
|
||||
(program->structure-exp needed source)
|
||||
(error "cannot satisfy program's requirements")))
|
||||
(error "program not found in file" filename))))))
|
||||
|
||||
; Returns a STRUCTURE expression for a program that uses the SRFIs listed
|
||||
; in NEEDED and whose source is SOURCE.
|
||||
|
||||
(define (program->structure-exp needed source)
|
||||
(let ((shadowed (find-shadowed needed)))
|
||||
`(structure (export)
|
||||
(open ,(if (null? shadowed)
|
||||
'scheme
|
||||
`(modify scheme (hide . ,shadowed)))
|
||||
. ,needed)
|
||||
. ,(map (lambda (source)
|
||||
(if (eq? (car source)
|
||||
'code)
|
||||
(cons 'begin (cdr source))
|
||||
source))
|
||||
source))))
|
||||
|
||||
; Returns a list of the names that SRFIS redefine from Scheme.
|
||||
|
||||
(define (find-shadowed srfis)
|
||||
(apply append (map (lambda (srfi)
|
||||
(cond ((assq srfi shadowed)
|
||||
=> cdr)
|
||||
(else
|
||||
'())))
|
||||
srfis)))
|
||||
|
||||
;----------------
|
||||
; Parsing a program to find the source that we will use for it.
|
||||
;
|
||||
; The arguments are a PROGRAM form and a list of the names of available SRFIs.
|
||||
; Two values are returned: a list of needed SRFIs and the program source as
|
||||
; a list of (files ...) and (code ...) clauses.
|
||||
;
|
||||
; This searches through the possible sets of SRFIs to find one that works for
|
||||
; the program. The EITHER macro is used to try choices. There are only two
|
||||
; places where choices occur: FEATURE-COND clauses and OR predicates (which
|
||||
; includes (NOT (AND ...)) predicates).
|
||||
|
||||
(define (parse-program program available)
|
||||
(receive (needed available source)
|
||||
(with-nondeterminism
|
||||
(lambda ()
|
||||
(either (process-clauses (cdr program) '() available)
|
||||
(values #f #f #f))))
|
||||
(if needed
|
||||
(values needed (reverse source))
|
||||
(values #f #f))))
|
||||
|
||||
; NEEDED is a list of SRFIs that we already know we need. AVAILABLE is a list
|
||||
; of other SRFIs that can be used. This returns new needed and available lists
|
||||
; as well as a list of (files ...) and (code ...) clauses.
|
||||
;
|
||||
; This is a simple dispatch on the types of clauses. For REQUIRES and
|
||||
; FEATURE-COND we call another procedure to check the requirements list
|
||||
; or cond clauses.
|
||||
|
||||
(define (process-clauses clauses needed available)
|
||||
(let loop ((clauses clauses)
|
||||
(needed needed)
|
||||
(available available)
|
||||
(source '()))
|
||||
(if (null? clauses)
|
||||
(values needed available source)
|
||||
(let ((clause (car clauses)))
|
||||
(case (car clause)
|
||||
((requires)
|
||||
(receive (needed available)
|
||||
(check-predicate `(and . ,(cdr clause)) #f needed available)
|
||||
(loop (cdr clauses)
|
||||
needed
|
||||
available
|
||||
source)))
|
||||
((feature-cond)
|
||||
(receive (needed available more-source)
|
||||
(process-cond-clauses (cdr clause) needed available)
|
||||
(loop (cdr clauses)
|
||||
needed
|
||||
available
|
||||
(append more-source source))))
|
||||
((code files)
|
||||
(loop (cdr clauses)
|
||||
needed
|
||||
available
|
||||
(cons clause source)))
|
||||
(else
|
||||
(error "bad program clause" clause)))))))
|
||||
|
||||
|
||||
; Loop down CLAUSES looking for one whose predicate can be satisfied.
|
||||
; If we find one we process its clauses. EITHER is used to allow us
|
||||
; to backtrack in case of failure.
|
||||
|
||||
(define (process-cond-clauses clauses needed available)
|
||||
(let loop ((clauses clauses))
|
||||
(if (null? clauses)
|
||||
(fail)
|
||||
(either (receive (needed available)
|
||||
(check-predicate (caar clauses) #f needed available)
|
||||
(process-clauses (cdar clauses) needed available))
|
||||
(loop (cdr clauses))))))
|
||||
|
||||
; REQUIREMENT is one of:
|
||||
; (and <requirement> ...)
|
||||
; (or <requirement> ...)
|
||||
; (not <requirement>)
|
||||
; <srfi-name>
|
||||
; NEGATE? is true if we really want the negation of REQUIREMENT.
|
||||
;
|
||||
; AND and OR have their own procedures, which get flipped by negation.
|
||||
; NOT just flips NEGATE?. There are two separate procedures for positive
|
||||
; and negative occurances of <srfi-name>.
|
||||
|
||||
(define (check-predicate requirement negate? needed available)
|
||||
(cond ((pair? requirement)
|
||||
(case (car requirement)
|
||||
((and)
|
||||
((if negate? any-satisfied all-satisfied)
|
||||
(cdr requirement) negate? needed available))
|
||||
((or)
|
||||
((if negate? all-satisfied any-satisfied)
|
||||
(cdr requirement) negate? needed available))
|
||||
((not)
|
||||
(check-predicate (cadr requirement)
|
||||
(not negate?)
|
||||
needed
|
||||
available))))
|
||||
(negate?
|
||||
(do-not-want requirement needed available))
|
||||
(else
|
||||
(want requirement needed available))))
|
||||
|
||||
; We want SRFI. If it is NEEDED we are fine. If it is in AVAILABLE we
|
||||
; move it to needed. Otherwise we lose.
|
||||
|
||||
(define (want srfi needed available)
|
||||
(cond ((memq srfi needed)
|
||||
(values needed available))
|
||||
((memq srfi available)
|
||||
(values (cons srfi needed)
|
||||
(delq srfi available))) ; not really necessary
|
||||
(else
|
||||
(fail))))
|
||||
|
||||
; We do not want SRFI. If it is NEEDED we lose. If it is in AVAILABLE we
|
||||
; get rid of it. Otherwise we win as-is.
|
||||
|
||||
(define (do-not-want srfi needed available)
|
||||
(cond ((memq srfi needed)
|
||||
(fail))
|
||||
((memq srfi available)
|
||||
(values needed
|
||||
(delq srfi available)))
|
||||
(else
|
||||
(values needed available))))
|
||||
|
||||
; Two loops for `and' and `or'. The `and' loop needs to update NEEDED
|
||||
; and AVAILABLE as it goes, the `or' keeps reusing the originals.
|
||||
|
||||
(define (all-satisfied list negate? needed available)
|
||||
(let loop ((list list) (needed needed) (available available))
|
||||
(if (null? list)
|
||||
(values needed available)
|
||||
(receive (needed available)
|
||||
(check-predicate (car list) negate? needed available)
|
||||
(if needed
|
||||
(loop (cdr list) needed available)
|
||||
(fail))))))
|
||||
|
||||
; Again, we use EITHER to allow for backtracking.
|
||||
|
||||
(define (any-satisfied list negate? needed available)
|
||||
(let loop ((list list))
|
||||
(if (null? list)
|
||||
(fail)
|
||||
(either (check-predicate (car list) negate? needed available)
|
||||
(loop (cdr list))))))
|
||||
|
||||
;----------------
|
||||
; Our own copy to avoid having to load BIG-UTIL to get the original.
|
||||
|
||||
(define (delq thing list)
|
||||
(cond ((null? list)
|
||||
'())
|
||||
((eq? thing (car list))
|
||||
(cdr list))
|
||||
(else
|
||||
(cons (car list)
|
||||
(delq thing (cdr list))))))
|
||||
|
||||
Loading…
Reference in New Issue