diff --git a/read.scm b/read.scm index c430240..df2f97c 100644 --- a/read.scm +++ b/read.scm @@ -35,7 +35,6 @@ ;;; All tokens are procedure-encapsulated objects, since the reader should ;;; never return a literal procedure. Each procedure has a TYPE message. - (load "chez-compat.scm") (load "util.scm") (load "set.scm") @@ -515,16 +514,6 @@ port)))))) loop)) -;;; Encapsulate LINKED-LIST object with an additional value for the -;;; toplevel table. -(define linked-list/toplevel:new - (lambda (toplevel) - (let ((ll (linked-list:new))) - (lambda (op . args) - (cond - ((eq? op 'toplevel) toplevel) - (else (apply ll op args))))))) - (define read:datum-label (lambda (location toplevel) (let ((finalized? #f) @@ -597,9 +586,42 @@ (port 'restore-mutable! mutable)) (readtable:next toplevel #f port))) +;;; String map from constants to procedures with formal arguments +;;; (TOPLEVEL PORT) +;;; with TOPLEVEL being the current toplevel table and PORT being the +;;; current port being read from. +;;; +;;; Each one must return something. Directives that return nothing must +;;; call the toplevel again. +(define read:hash-constants + (smap:insert-many + '() + (cons "true" (lambda unused #t)) + (cons "false" (lambda unused #f)) + (cons "t" (lambda unused #t)) + (cons "f" (lambda unused #f)) + (cons "!fold-case" + (lambda (toplevel port) + (port 'fold-case! #t) + (readtable:act toplevel (port 'read) #f port))) + (cons "!no-fold-case" + (lambda (toplevel port) + (port 'fold-case! #f) + (readtable:act toplevel (port 'read) #f port))))) + +(define read:read-hash-constants + (lambda (_ char acc port) + (let ((ident (readtable:read-ident #f char #f port))) + (let ((container (smap:search read:hash-constants + (ident 'value)))) + (if (null? container) + (error 'read-hash-constants 'unknown-constant + (ident 'value)) + ((map:val container) acc port)))))) + (define readtable:hash (readtable:process - (readtable:empty/default (readtable:error 'hash "unimplemented")) + (readtable:empty/default read:read-hash-constants) (list readtable:update #\| (readtable:jump/next readtable:block-comment)) (list readtable:update #\; readtable:datum-comment) (list readtable:update-list readtable:digits ; Datum labels @@ -712,3 +734,6 @@ (read-all "#(a b #(c #|close#|comment|#|#y))") (read-all "(this has a #;(call with (current continuation)) datum comment)") (read-all "#0=(#0# not unix)") +(read-all "#!no-fold-case #!fold-case #!NO-FOLD-CASE #false") +(read-all "#!fold-case #TRUE") + diff --git a/set.scm b/set.scm index 52d10b6..f096121 100644 --- a/set.scm +++ b/set.scm @@ -463,7 +463,7 @@ (define smap:insert-many (lambda (smap . pairs) (fold (lambda (pair smap) - (smap:insert smap (car pair) (cdr pair))) + (car (smap:insert smap (car pair) (cdr pair)))) smap pairs)))