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

read: add object encapsulating identifier

This commit is contained in:
Peter McGoron 2024-09-27 11:26:30 -04:00
parent df69826312
commit fee4198f2f
3 changed files with 49 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
chez-compat.scm
View File

@ -47,8 +47,3 @@
(begin evaluated ...)
(cond-expand rest ...)))))
(define %r6rs-error error)
(define (error . rest)
(apply %r6rs-error (cons "UNSLISP" rest)))

4
linked-list.scm
View File

@ -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)

64
read.scm
View File

@ -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)))))