peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

readtable: correctly add trie values. Incorrectly propogates default procedure

This commit is contained in:
Peter McGoron 2024-09-07 17:58:18 -04:00
parent 53a174f8e2
commit 40b129b0db
1 changed files with 19 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
read.scm
View File

@ -144,17 +144,20 @@
;;; as the default action, and run (UPDATE REST ACTION) on it. ;;; as the default action, and run (UPDATE REST ACTION) on it.
(define readtable:exec:new (define readtable:exec:new
(lambda (proc) (lambda (proc)
(let ((update (letrec
(lambda (rest action) ((update
(if (null? rest) (lambda (rest action)
action (if (null? rest)
((readtable:pass:new readtable:empty) action
'update rest action))))) ((readtable:pass:new (readtable:new exec '()))
(lambda (op . args) 'update rest action))))
(cond (exec
((eq? op 'update) (apply update args)) (lambda (op . args)
((eq? op 'step) (apply proc args)) (cond
(else (error "readtable:exec: invalid" args))))))) ((eq? op 'update) (apply update args))
((eq? op 'step) (apply proc args))
(else (error "readtable:exec: invalid" args))))))
exec)))
;;; Define a new readtable. ;;; Define a new readtable.
;;; ;;;
@ -204,7 +207,6 @@
(lambda (op . args) (lambda (op . args)
(cond (cond
((not op) ((not op)
(display (list op args))
(apply run* default-action op args)) (apply run* default-action op args))
((char? op) (apply run op args)) ((char? op) (apply run op args))
((eq? op 'with-default-action) (apply with-default-action ((eq? op 'with-default-action) (apply with-default-action
@ -277,7 +279,8 @@
readtable:empty readtable:empty
(cons "#t" (readtable:return-value #t)) (cons "#t" (readtable:return-value #t))
(cons "#f" (readtable:return-value #f)) (cons "#f" (readtable:return-value #f))
(cons "#true" (readtable:return-value #t)))) (cons "#true" (readtable:return-value #t))
(cons "#trouble" (readtable:return-value 15))))
;;; ;;;;;;;;;;; ;;; ;;;;;;;;;;;
;;; Test reader ;;; Test reader
@ -294,7 +297,6 @@
ch))) ch)))
"test"))) "test")))
(let ((true-reader (%list->read (list #\# #\t)))) (let ((true-reader (%list->read (list #\# #\t #\r #\u #\e #\f))))
(readtable:top (true-reader 'read) #f true-reader)) (display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
(display (list "second: " (readtable:top (true-reader 'read) #f true-reader))))