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

read: improper lists

This commit is contained in:
Peter McGoron 2024-09-20 22:27:17 -04:00
parent 5271cc67c6
commit 75f915d0e5
1 changed files with 40 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
read.scm
View File

@ -19,6 +19,11 @@
(load "set.scm") (load "set.scm")
(load "linked-list.scm") (load "linked-list.scm")
;;; My text editor cannot parse Scheme's character syntax.
(define %bol #\()
(define %eol #\))
;;; ;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Port reader wrapper ;;; Port reader wrapper
;;; ;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
@ -228,7 +233,7 @@
(list readtable:exclude-from-identifiers (list readtable:exclude-from-identifiers
readtable:ASCII-whitespace) readtable:ASCII-whitespace)
(list readtable:exclude-from-identifiers (list readtable:exclude-from-identifiers
(list #\| #\( #\) #\' #\; #f)))) (list #\| %bol %eol #\' #\; #f))))
;;; Read an identifier starting with CHAR. ;;; Read an identifier starting with CHAR.
(define readtable:read-ident (define readtable:read-ident
@ -255,52 +260,60 @@
(readtable:empty/default readtable:skip) (readtable:empty/default readtable:skip)
(list readtable:update #\newline (readtable:return #f)))) (list readtable:update #\newline (readtable:return #f))))
;;; Read the end of an improper list.
(define readtable:read-improper-cdr
(lambda (table acc port)
(let ((val
(readtable:act (readtable:update table
%eol
(readtable:error
"proper list must have cdr"))
(port 'read)
#f
port)))
(acc 'set-cdr! val)
(let ((table (readtable:process
(readtable:empty/default (readtable:error
"improper list has 1 cdr"))
(list readtable:add-all-as-skip readtable:ASCII-whitespace)
(list readtable:update %eol
(lambda dummy acc)))))
(readtable:act table (port 'read) acc port)))))
;;; List reader. ;;; List reader.
;;; ;;;
;;; The reader updates the previous readtable to handle ). This means ;;; The reader updates the previous readtable to handle ). This means
;;; that this read table does not have to handle end-of-line, whitespace, ;;; that this read table does not have to handle end-of-line, whitespace,
;;; etc. ;;; etc.
;;;
;;; TODO: Put improper list into new function
(define readtable:read-list (define readtable:read-list
(lambda (table char acc port) (lambda (oldtable char acc port)
(let ((acc (linked-list:new)) (let ((acc (linked-list:new))
(table (readtable:process (table (readtable:process
table oldtable
(list readtable:update #\) (list readtable:update %eol
(readtable:return 'end-of-list)) (readtable:return 'end-of-list))
(list readtable:update #\. (list readtable:update #\.
(lambda (table char acc port) (lambda (table char acc port)
(let ((id (readtable:read-ident (let ((id (readtable:read-ident
table table
char char
acc #f
port))) port)))
;; todo: list needs a car
(if (equal? id ".") (if (equal? id ".")
'period (begin
(readtable:read-improper-cdr
oldtable acc port)
'end-of-list)
id))))))) id)))))))
(letrec ((loop (letrec ((loop
(lambda () (lambda ()
(let ((value (readtable:act table (let ((value (readtable:act table
(port 'read) (port 'read)
#f acc
port))) port)))
(cond (cond
((eqv? value 'end-of-list) (acc 'to-list)) ((eqv? value 'end-of-list) (acc 'to-list))
((eqv? value 'period)
(let ((final-value (readtable:act table
(port 'read)
#f
port)))
(acc 'set-cdr! final-value)
(let ((expect-eol (readtable:act table
(port 'read)
#f
port)))
(if (not (eqv? expect-eol 'end-of-list))
(error "found instead of end of improper list"
expect-eol)
(acc 'to-list)))))
(else (acc 'push-tail value) (else (acc 'push-tail value)
(loop))))))) (loop)))))))
(loop))))) (loop)))))
@ -314,8 +327,8 @@
(readtable:empty/default readtable:read-ident) (readtable:empty/default readtable:read-ident)
(list readtable:add-all-as-skip readtable:ASCII-whitespace) (list readtable:add-all-as-skip readtable:ASCII-whitespace)
(list readtable:update #f (readtable:return 'eof)) (list readtable:update #f (readtable:return 'eof))
(list readtable:update #\( readtable:read-list) (list readtable:update %bol readtable:read-list)
(list readtable:update #\) (readtable:error "unbalanced list")) (list readtable:update %eol (readtable:error "unbalanced list"))
(list readtable:update #\; (list readtable:update #\;
(readtable:jump-discard readtable:read-to-newline))))) (readtable:jump-discard readtable:read-to-newline)))))
@ -352,3 +365,4 @@
(read-all "x yy zz ; this is a comment\nx call/cc ") (read-all "x yy zz ; this is a comment\nx call/cc ")
(read-all "(a b c def (ghi j) k )") (read-all "(a b c def (ghi j) k )")
(read-all "( a . b )") (read-all "( a . b )")
(read-all "( a .b . c)")