diff --git a/read.scm b/read.scm index a138041..cd81daf 100644 --- a/read.scm +++ b/read.scm @@ -140,6 +140,12 @@ ((eq? op 'step) (apply step args)) (else (error "readtable:pass: invalid" args))))))) +;;; Create a new PASS with a blank TABLE with DEFAULT-ACTION as the +;;; default action. +(define readtable:pass/blank + (lambda (default-action) + (readtable:pass:new (readtable:new default-action '())))) + ;;; Execute an action. ;;; ;;; STEP calls PROC with the same arguments. @@ -170,7 +176,8 @@ ;;; Default actions ;;; ;;;;;;;;;;;;;;; -(define readtable:update-many +;;; Add multiple literal sequences to the readtable. +(define readtable:update-many-sequence (lambda (table . pairs) (fold (lambda (pair table) (readtable:add-sequence table (car pair) @@ -233,10 +240,8 @@ (readtable:new new-default-action charmap))) (empty-pass/error (lambda () - (readtable:pass:new - (readtable:new (readtable:error-action - "reading long name") - '())))) + (readtable:pass/blank (readtable:error-action + "reading long name")))) (update-oldnode (lambda (rest action) (lambda (_ oldnode) @@ -268,13 +273,15 @@ table))) ;;; Add ACTION as the action to be taken in TABLE following SEQ. +;;; The action is wrapped in an empty PASS table with ACTION as the default +;;; action. This normalizes the character ACTION is passed. (define readtable:add-sequence (lambda (table seq action) (let ((seq (cond ((char? seq) (list seq)) ((string? seq) (string->list seq)) (else seq)))) - (table 'update seq action)))) + (table 'update seq (readtable:pass/blank action))))) ;;; ;;;;;;;;;;;;;;;;;;; ;;; Default readtables @@ -293,7 +300,7 @@ (cons #\newline (readtable:return-value #f)))))) (define readtable:top - (readtable:update-many + (readtable:update-many-sequence readtable:empty (cons "#t" (readtable:return-value #t)) (cons "#f" (readtable:return-value #f)) @@ -314,7 +321,7 @@ ch))) "test"))) -(let ((true-reader (%list->read (string->list "#tro#f")))) +(let ((true-reader (%list->read (string->list "#true#f")))) (display (list "first:" (readtable:top (true-reader 'read) #f true-reader))) (newline) (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))