From 4d40be38d0224140d90430897ca3af5378d4a274 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Sat, 7 Sep 2024 18:37:17 -0400 Subject: [PATCH] Readtable: fix propagation of default handlers in trie paths Previous version did (ACTION 'UPDATE (CDR REST) ACTION) when a new action had to be made. This caused default actions to propagate through the trie. While this isn't bad (it causes #TRU to be equal to #TRUE when that was the last prefix in the tree), it can cause unexpected errors at runtime, and no program should ever depend on its behavior. The current solution is to make a new PASS readtable with a default error action. --- read.scm | 147 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 80 insertions(+), 67 deletions(-) diff --git a/read.scm b/read.scm index 440d910..8724e3c 100644 --- a/read.scm +++ b/read.scm @@ -159,70 +159,6 @@ (else (error "readtable:exec: invalid" args)))))) exec))) -;;; Define a new readtable. -;;; -;;; (X) where (CHAR? X): Execute the action associated with X, or the -;;; default action. -;;; -;;; (WITH-DEFAULT-ACTION NEW-ACTION): Return a readtable with the same -;;; backing table but with NEW-ACTION as the default action. -;;; -;;; (UPDATE REST ACTION): Update the action taken by the total application -;;; of REST to be ACTION. REST must be a pair. -(define readtable:new - (lambda (default-action charmap) - (letrec - ((lookup? - (lambda (char) - (let ((node (charmap:search charmap char))) - (if (null? node) - #f - (map:val node))))) - (lookup - (lambda (char) - (or (lookup? char) default-action))) - (run* - (lambda (handler char acc port) - (handler 'step table char acc port))) - (run - (lambda (char acc port) - (run* (lookup char) char acc port))) - (with-default-action - (lambda (new-default-action) - (readtable:new new-default-action charmap))) - (update - (lambda (rest action) - (if (null? rest) - (error "readtable update: invalid" (list rest action)) - (readtable:new default-action - (charmap:update - charmap - (car rest) - (lambda (_ oldnode) - (if (null? oldnode) - (action 'update (cdr rest) action) - ((map:val oldnode) - 'update (cdr rest) action)))))))) - (table - (lambda (op . args) - (cond - ((not op) - (apply run* default-action op args)) - ((char? op) (apply run op args)) - ((eq? op 'with-default-action) (apply with-default-action - args)) - ((eq? op 'update) (apply update args)) - (else (error "readtable: invalid" args)))))) - table))) - -;;; Add ACTION as the action to be taken in TABLE following SEQ. -(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)))) ;;; ;;;;;;;;;;;;;;; ;;; Default actions @@ -258,6 +194,82 @@ (lambda (table char acc port) value)))) +;;; Define a new readtable. +;;; +;;; (X) where (CHAR? X): Execute the action associated with X, or the +;;; default action. +;;; +;;; (WITH-DEFAULT-ACTION NEW-ACTION): Return a readtable with the same +;;; backing table but with NEW-ACTION as the default action. +;;; +;;; (UPDATE REST ACTION): Update the action taken by the total application +;;; of REST to be ACTION. REST must be a pair. +(define readtable:new + (lambda (default-action charmap) + (letrec + ((lookup? + (lambda (char) + (let ((node (charmap:search charmap char))) + (if (null? node) + #f + (map:val node))))) + (lookup + (lambda (char) + (or (lookup? char) default-action))) + (run* + (lambda (handler char acc port) + (handler 'step table char acc port))) + (run + (lambda (char acc port) + (run* (lookup char) char acc port))) + (with-default-action + (lambda (new-default-action) + (readtable:new new-default-action charmap))) + (empty-pass/error + (lambda () + (readtable:pass:new + (readtable:new (readtable:error-action + "reading long name") + '())))) + (update-oldnode + (lambda (rest action) + (lambda (_ oldnode) + (if (null? rest) + action + (let ((replaced (if (null? oldnode) + (empty-pass/error) + (map:val oldnode)))) + (replaced 'update rest action)))))) + (update + (lambda (rest action) + (if (null? rest) + (error "readtable update: invalid" (list rest action)) + (readtable:new default-action + (charmap:update + charmap + (car rest) + (update-oldnode (cdr rest) action)))))) + (table + (lambda (op . args) + (cond + ((not op) + (apply run* default-action op args)) + ((char? op) (apply run op args)) + ((eq? op 'with-default-action) (apply with-default-action + args)) + ((eq? op 'update) (apply update args)) + (else (error "readtable: invalid" (cons op args))))))) + table))) + +;;; Add ACTION as the action to be taken in TABLE following SEQ. +(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)))) + ;;; ;;;;;;;;;;;;;;;;;;; ;;; Default readtables ;;; ;;;;;;;;;;;;;;;;;;; @@ -285,7 +297,6 @@ ;;; ;;;;;;;;;;; ;;; Test reader ;;; ;;;;;;;;;;; - (define %list->read (lambda (seq) (port->read @@ -297,6 +308,8 @@ ch))) "test"))) -(let ((true-reader (%list->read (list #\# #\t #\r #\u #\e #\f)))) +(let ((true-reader (%list->read (string->list "#tro#f")))) (display (list "first:" (readtable:top (true-reader 'read) #f true-reader))) - (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))) + (newline) + (display (list "second: " (readtable:top (true-reader 'read) #f true-reader))) + (newline))