From fee4198f2fa304b5f8fa5258f927b5931eb19d8b Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Fri, 27 Sep 2024 11:26:30 -0400 Subject: [PATCH] read: add object encapsulating identifier --- chez-compat.scm | 5 ---- linked-list.scm | 4 ++-- read.scm | 64 ++++++++++++++++++++++++++++++++++++------------- 3 files changed, 49 insertions(+), 24 deletions(-) diff --git a/chez-compat.scm b/chez-compat.scm index f400a3e..39cb31a 100644 --- a/chez-compat.scm +++ b/chez-compat.scm @@ -47,8 +47,3 @@ (begin evaluated ...) (cond-expand rest ...))))) -(define %r6rs-error error) - -(define (error . rest) - (apply %r6rs-error (cons "UNSLISP" rest))) - diff --git a/linked-list.scm b/linked-list.scm index 356b2b2..fb71fe0 100644 --- a/linked-list.scm +++ b/linked-list.scm @@ -62,7 +62,7 @@ (%set-cdr! (lambda (val) (if (null? tail) - (error "cannot set cdr of empty list") + (error 'linked-list "cannot set cdr of empty list") (set-cdr! tail val))))) (lambda args (let ((op (car args))) @@ -72,7 +72,7 @@ ((eq? op 'set-cdr!) (apply %set-cdr! (cdr args))) ((eq? op 'to-list) head) ((eq? op 'traverse-from-head) (linked-list-elem:new head)) - (else (error (cons "invalid operation" args)))))))))) + (else (error 'linked-list (cons "invalid operation" args)))))))))) (define x (linked-list:new)) (x 'push-tail 1) diff --git a/read.scm b/read.scm index 9040772..772ada7 100644 --- a/read.scm +++ b/read.scm @@ -82,6 +82,8 @@ ;; OFFSET is sometimes set to #F to denote an unknown ;; offset. (offset (set! offset (+ 1 offset)))))) + (location + (lambda () (list filename line-number offset))) (set-datum-label! (lambda (label value) (set! datum-labels @@ -107,7 +109,7 @@ (lambda (op . args) ;; TODO: turn into string map? (cond - ((eq? op 'pos) (list filename line-number offset)) + ((eq? op 'location) (location)) ((eq? op 'read) (process (if (null? pushback-buffer) @@ -131,7 +133,7 @@ ((eq? op 'fold-case!) (set! fold-case? (car args))) ((eq? op 'set-datum-label!) (apply set-datum-label! args)) ((eq? op 'get-datum-label) (apply get-datum-label args)) - (else (error "read->port: invalid" (cons op args))))))) + (else (error 'read->port 'invalid (cons op args))))))) port)))) ;;; ;;;;;;;;;;;;;; @@ -283,11 +285,29 @@ ;;; Identifier reader ;;; ;;;;;;;;;;;;;;;;; +(define read:ident + (lambda (name location) + (lambda (op . args) + (cond + ((eq? op 'type) 'ident) + ((eq? op 'value) name) + (else (error 'read:ident "invalid operation" op args)))))) + +(define read:ident-builder + (lambda (start-char location) + (let ((char-list (linked-list:new))) + (char-list 'push start-char) + (lambda (op . args) + (cond + ((eq? op 'finalize->ident) + (read:ident (list->string (char-list 'to-list)) location)) + (else (apply char-list op args))))))) + ;;; Push back CHAR and return ACC. -(define readtable:return-acc-keep-char +(define readtable:return-acc-as-ident (lambda (table char acc port) (port 'push char) - acc)) + (acc 'finalize->ident))) ;;; Push CHAR to ACC and continue reading from TABLE. (define readtable:push-char @@ -300,7 +320,7 @@ (define readtable:exclude-from-identifiers (lambda (table excluded) (fold (lambda (char table) - (readtable:update table char readtable:return-acc-keep-char)) + (readtable:update table char readtable:return-acc-as-ident)) table excluded))) @@ -325,12 +345,11 @@ ;;; Read an identifier starting with CHAR. (define readtable:read-ident (lambda (table char acc port) - (let ((lst (linked-list:new))) - (lst 'push char) - (list->string - ((readtable:act readtable:identifier - (port 'read) lst port) - 'to-list))))) + (readtable:act readtable:identifier + (port 'read) + (read:ident-builder char + (port 'location)) + port))) ;;; ;;;;;;;;;;;;;;;;;;;; ;;; Comments and whitespace reader @@ -357,6 +376,7 @@ (readtable:act (readtable:update table %eol (readtable:error + 'read-improper-cdr "proper list must have cdr")) (port 'read) #f @@ -364,6 +384,7 @@ (acc 'set-cdr! val) (let ((table (readtable:process (readtable:empty/default (readtable:error + 'read-improper-cdr "improper list has 1 cdr")) (list readtable:update-list readtable:ASCII-whitespace @@ -419,7 +440,9 @@ (lambda (table port) (readtable:read-list-loop (readtable:table-for-list table - (readtable:error "expected proper list")) + (readtable:error + 'read-proper-list + "expected proper list")) port))) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -499,7 +522,8 @@ ;;; looks like "#[NUMBER]=" and a reference looks like "#[NUMBER]#". (define readtable:datum-label-next (readtable:process - (readtable:empty/default (readtable:error "invalid datum label/ref")) + (readtable:empty/default (readtable:error 'datum-label-next + "invalid datum label/ref")) (list readtable:update-list readtable:digits readtable:push-char) (list readtable:update #\= (lambda (_ __ acc port) @@ -522,7 +546,7 @@ ;; the datum label. (if (and (pair? next-value) (equal? (car next-value) label)) - (error "datum label cannot be itself") + (error 'datum-label-next "datum label cannot be itself") (set-cdr! datum-label next-value)) next-value))))) (list readtable:update #\# @@ -530,7 +554,8 @@ (let ((label (list->string (acc 'to-list)))) (let ((datum-label (port 'get-datum-label label))) (if (null? datum-label) - (error "unknown reference to datum label" label) + (error 'datum-label-next + "unknown reference to datum label" label) (map:val datum-label)))))))) ;;; Reads the next toplevel datum, discards it, and then continues at the @@ -546,7 +571,7 @@ (define readtable:hash (readtable:process - (readtable:empty/default (readtable:error "unimplemented")) + (readtable:empty/default (readtable:error 'hash "unimplemented")) (list readtable:update #\| (readtable:jump/next readtable:block-comment)) (list readtable:update #\; readtable:datum-comment) (list readtable:update-list readtable:digits ; Datum labels @@ -571,7 +596,7 @@ readtable:skip) (list readtable:update #f (readtable:return 'eof)) (list readtable:update %bol readtable:read-list) - (list readtable:update %eol (readtable:error "unbalanced list")) + (list readtable:update %eol (readtable:error 'top "unbalanced list")) (list readtable:update #\# (readtable:next/old-as-acc readtable:hash)) (list readtable:update #\; @@ -605,6 +630,11 @@ (if (not (null? (intset:in used-counters cur-cntr))) (list 'def cur-cntr '= returned) returned))))))) + ((procedure? value) + (let ((type (value 'type))) + (cond + ((eq? type 'ident) (value 'value)) + (else (vector 'unrepresentable type))))) (else value))))) (uncycle value)))))