diff --git a/README.rst b/README.rst index 7fa167d..abb5f5a 100644 --- a/README.rst +++ b/README.rst @@ -19,7 +19,7 @@ designed to be used by a severely limited Scheme interpreter, which * has fixnums only * only uses immutable strings * does not use "load" recursively -* uses R3RS essential procedures only (with some exceptions) +* uses R3RS essential procedures/syntax only (with some exceptions) The goal is to have the compiler run under the MiniScheme in ``miniscm`` in DOS, and then run in GLLV to compile itself. diff --git a/read.scm b/read.scm index 63a119d..7158f58 100644 --- a/read.scm +++ b/read.scm @@ -17,6 +17,7 @@ (load "chez-compat.scm") (load "util.scm") (load "set.scm") +(load "linked-list.scm") ;;; ;;;;;;;;;;;;;;;;;;;;;;;; ;;; Port reader wrapper @@ -159,6 +160,12 @@ ;;; Default readtables ;;; ;;;;;;;;;;;;;;;;;; +;;; Return an error. +(define readtable:error + (lambda emsg + (lambda tablemsg + (apply error tablemsg emsg)))) + ;;; Discard the current character and continue reading the readtable. (define readtable:skip (lambda (table char acc port) @@ -178,6 +185,12 @@ (readtable:act newtable (port 'read) '() port) (readtable:act oldtable (port 'read) acc port)))) +;;; Jump to a new readtable with the same characters. +(define readtable:jump + (lambda (newtable) + (lambda (oldtable char acc port) + (readtable:act newtable char acc port)))) + ;;; Push back CHAR and return ACC. (define readtable:return-acc-keep-char (lambda (table char acc port) @@ -185,9 +198,10 @@ acc)) ;;; Push CHAR to ACC and continue reading from TABLE. -(define readtable:push-acc +(define readtable:push-char (lambda (table char acc port) - (readtable:act table (port 'read) (cons char acc) port))) + (acc 'push-tail char) + (readtable:act table (port 'read) acc port))) ;;; Define a readtable that constructs an identifier by accepting all ;;; characters that are not listed. @@ -210,7 +224,7 @@ ;;; Readtable for identifiers. (define readtable:identifier (readtable:process - (readtable:empty/default readtable:push-acc) + (readtable:empty/default readtable:push-char) (list readtable:exclude-from-identifiers readtable:ASCII-whitespace) (list readtable:exclude-from-identifiers @@ -219,8 +233,12 @@ ;;; Read an identifier starting with CHAR. (define readtable:read-ident (lambda (table char acc port) - (reverse (readtable:act readtable:identifier - (port 'read) (list char) port)))) + (let ((lst (linked-list:new))) + (lst 'push char) + (list->string + ((readtable:act readtable:identifier + (port 'read) lst port) + 'to-list))))) ;;; Add all chars in TO-SKIP to TABLE as skipped characters. Used for ;;; whitespace. @@ -237,14 +255,69 @@ (readtable:empty/default readtable:skip) (list readtable:update #\newline (readtable:return #f)))) +;;; List reader. +;;; +;;; The reader updates the previous readtable to handle ). This means +;;; that this read table does not have to handle end-of-line, whitespace, +;;; etc. +;;; +;;; TODO: Put improper list into new function +(define readtable:read-list + (lambda (table char acc port) + (let ((acc (linked-list:new)) + (table (readtable:process + table + (list readtable:update #\) + (readtable:return 'end-of-list)) + (list readtable:update #\. + (lambda (table char acc port) + (let ((id (readtable:read-ident + table + char + acc + port))) + (if (equal? id ".") + 'period + id))))))) + (letrec ((loop + (lambda () + (let ((value (readtable:act table + (port 'read) + #f + port))) + (cond + ((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) + (loop))))))) + (loop))))) + ;;; Toplevel reader. +;;; This is defined as a function so that it dynamically loads each +;;; sub-readtable. (define readtable:top - (readtable:process - (readtable:empty/default readtable:read-ident) - (list readtable:add-all-as-skip readtable:ASCII-whitespace) - (list readtable:update #f (readtable:return 'eof)) - (list readtable:update #\; - (readtable:jump-discard readtable:read-to-newline)))) + (lambda () + (readtable:process + (readtable:empty/default readtable:read-ident) + (list readtable:add-all-as-skip readtable:ASCII-whitespace) + (list readtable:update #f (readtable:return 'eof)) + (list readtable:update #\( readtable:read-list) + (list readtable:update #\) (readtable:error "unbalanced list")) + (list readtable:update #\; + (readtable:jump-discard readtable:read-to-newline))))) ;;; ;;;;;;;;;;; ;;; Test reader @@ -268,7 +341,7 @@ (if (not (reader 'peek)) #t (let ((value (readtable:act - readtable:top (reader 'read) + (readtable:top) (reader 'read) #f reader))) (display (list "return" value)) @@ -277,5 +350,5 @@ (loop))))) (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)")