281 lines
8.9 KiB
Scheme
281 lines
8.9 KiB
Scheme
;;; Copyright (C) Peter McGoron 2024
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation, version 3 of the License.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful,
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; R7RS reader. This is the lexer-parser end, so it returns tokens and
|
|
;;; not concrete objects.
|
|
|
|
(load "chez-compat.scm")
|
|
(load "util.scm")
|
|
(load "set.scm")
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Port reader wrapper
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define port->read-function
|
|
(lambda (port)
|
|
(lambda ()
|
|
(read-char port))))
|
|
|
|
;;; READ:
|
|
;;;
|
|
;;; (POS): Return (LIST FILENAME LINE-NUMBER OFFSET).
|
|
;;; (READ): Read the next character in the stream. Returns #F on EOF.
|
|
;;; (PUSH CHAR): Push CHAR such that it will be the next character read
|
|
;;; when (READ) is called.
|
|
;;; (PEEK): Read character, push it back, and return it.
|
|
;;; (FOLD-CASE?): Returns a boolean if case folding is enabled.
|
|
;;; (FOLD-CASE! BOOL): Sets the case folding to BOOL.
|
|
(define port->read
|
|
(lambda (read-function filename)
|
|
(let ((line-number 1)
|
|
(offset 0)
|
|
(pushback-buffer '())
|
|
(fold-case? #f))
|
|
(letrec ((update-position!
|
|
(lambda (ch)
|
|
(cond
|
|
((eqv? ch #\newline)
|
|
(set! line-number (+ 1 line-number)) (set! offset 0))
|
|
(offset (set! offset (+ 1 offset))))))
|
|
(process
|
|
(lambda (ch)
|
|
(update-position! ch)
|
|
(cond
|
|
((or (eof-object? ch) (not ch)) ch)
|
|
(fold-case? (char-downcase ch))
|
|
(else ch))))
|
|
(port
|
|
(lambda (op . args)
|
|
(cond
|
|
((eq? op 'pos) (list filename line-number offset))
|
|
((eq? op 'read)
|
|
(process
|
|
(if (null? pushback-buffer)
|
|
(read-function)
|
|
(let ((ch (car pushback-buffer)))
|
|
(set! pushback-buffer (cdr pushback-buffer))
|
|
ch))))
|
|
((eq? op 'peek)
|
|
(let ((ch (port 'read)))
|
|
(port 'push ch)
|
|
ch))
|
|
((eq? op 'push)
|
|
(let ((ch (car args)))
|
|
(if (eqv? ch #\newline)
|
|
(begin
|
|
(set! line-number (- line-number 1))
|
|
(set! offset #f))
|
|
(set! offset (- offset 1)))
|
|
(set! pushback-buffer (cons ch pushback-buffer))))
|
|
((eq? op 'fold-case?) fold-case?)
|
|
((eq? op 'fold-case!) (set! fold-case? (car args)))
|
|
(else (error "read->port: invalid" (cons op args)))))))
|
|
port))))
|
|
|
|
;;; ;;;;;;;;;;;;;;
|
|
;;; Character maps
|
|
;;; ;;;;;;;;;;;;;;
|
|
|
|
(define integer<=>
|
|
(lambda (x y)
|
|
(cond
|
|
((< x y) '<)
|
|
((= x y) '=)
|
|
(else '>))))
|
|
|
|
;;; Comparison on characters extended to #F, which is less than all
|
|
;;; characters.
|
|
(define char*<=>
|
|
(lambda (x y)
|
|
(cond
|
|
((and (not x) y) '<)
|
|
((and x (not y)) '>)
|
|
((and (not x) (not y) '=))
|
|
(else (integer<=> (char->integer x)
|
|
(char->integer y))))))
|
|
|
|
(define %charmap:<=> (set:<=>-to-map char*<=>))
|
|
(define %charmap:update (set:update %charmap:<=>))
|
|
|
|
(define charmap:update (map:update %charmap:update))
|
|
(define charmap:insert (map:insert %charmap:update))
|
|
(define charmap:search (map:search %charmap:<=>))
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Readtable constructors
|
|
;;; ;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; (READTABLE:NEW DEFAULT-ACTION CHARMAP)
|
|
(define readtable:new cons)
|
|
|
|
(define %readtable:default-action car)
|
|
(define %readtable:charmap cdr)
|
|
|
|
;;; Run the action in TABLE assigned to CHAR, or the default action of
|
|
;;; TABLE if there is no entry for CHAR.
|
|
(define readtable:act
|
|
(lambda (table char acc port)
|
|
(let ((node (charmap:search (%readtable:charmap table)
|
|
char)))
|
|
(let ((action (if (null? node)
|
|
(%readtable:default-action table)
|
|
(map:val node))))
|
|
(action table char acc port)))))
|
|
|
|
;;; Return a new readtable where CHAR is bound to ACTION.
|
|
(define readtable:update
|
|
(lambda (table char action)
|
|
(readtable:new (%readtable:default-action table)
|
|
(car (charmap:insert
|
|
(%readtable:charmap table) char action)))))
|
|
|
|
;;; Construct new readtable with no characters in its map and
|
|
;;; DEFAULT-ACTION as the default action.
|
|
(define readtable:empty/default
|
|
(lambda (default-action)
|
|
(readtable:new default-action '())))
|
|
|
|
;;; Each value in FUNCTIONS is a list (PROCEDURE ARGS...) which is called
|
|
;;; like (PROCEDURE TABLE ARGS...) and returns a table.
|
|
(define readtable:process
|
|
(lambda (table . functions)
|
|
(fold (lambda (function table)
|
|
(apply (car function) table (cdr function)))
|
|
table
|
|
functions)))
|
|
|
|
;;; ;;;;;;;;;;;;;;;;;;
|
|
;;; Default readtables
|
|
;;; ;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Discard the current character and continue reading the readtable.
|
|
(define readtable:skip
|
|
(lambda (table char acc port)
|
|
(readtable:act table (port 'read) acc port)))
|
|
|
|
;;; Discard char and return constant.
|
|
(define readtable:return
|
|
(lambda (return)
|
|
(lambda (table char acc port)
|
|
return)))
|
|
|
|
;;; Jump to a new readtable, discard it's return, and continue reading
|
|
;;; in the table.
|
|
(define readtable:jump-discard
|
|
(lambda (newtable)
|
|
(lambda (oldtable char acc port)
|
|
(readtable:act newtable (port 'read) '() port)
|
|
(readtable:act oldtable (port 'read) acc port))))
|
|
|
|
;;; Push back CHAR and return ACC.
|
|
(define readtable:return-acc-keep-char
|
|
(lambda (table char acc port)
|
|
(port 'push char)
|
|
acc))
|
|
|
|
;;; Push CHAR to ACC and continue reading from TABLE.
|
|
(define readtable:push-acc
|
|
(lambda (table char acc port)
|
|
(readtable:act table (port 'read) (cons char acc) port)))
|
|
|
|
;;; Define a readtable that constructs an identifier by accepting all
|
|
;;; characters that are not listed.
|
|
(define readtable:exclude-from-identifiers
|
|
(lambda (table excluded)
|
|
(fold (lambda (char table)
|
|
(readtable:update table char readtable:return-acc-keep-char))
|
|
table
|
|
excluded)))
|
|
|
|
;;; ASCII whitespace.
|
|
(define readtable:ASCII-whitespace
|
|
(list #\newline
|
|
#\space
|
|
(integer->char #x09)
|
|
(integer->char #x0B)
|
|
(integer->char #x0C)
|
|
(integer->char #x0D)))
|
|
|
|
;;; Readtable for identifiers.
|
|
(define readtable:identifier
|
|
(readtable:process
|
|
(readtable:empty/default readtable:push-acc)
|
|
(list readtable:exclude-from-identifiers
|
|
readtable:ASCII-whitespace)
|
|
(list readtable:exclude-from-identifiers
|
|
(list #\| #\( #\) #\' #\; #f))))
|
|
|
|
;;; 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))))
|
|
|
|
;;; Add all chars in TO-SKIP to TABLE as skipped characters. Used for
|
|
;;; whitespace.
|
|
(define readtable:add-all-as-skip
|
|
(lambda (table to-skip)
|
|
(fold (lambda (char table)
|
|
(readtable:update table char readtable:skip))
|
|
table
|
|
to-skip)))
|
|
|
|
;;; Readtable for a line comment.
|
|
(define readtable:read-to-newline
|
|
(readtable:process
|
|
(readtable:empty/default readtable:skip)
|
|
(list readtable:update #\newline (readtable:return #f))))
|
|
|
|
;;; Toplevel reader.
|
|
(define readtable:top
|
|
(readtable:process
|
|
(readtable:empty/default readtable:read-ident)
|
|
(list readtable:add-all-as-skip readtable:ASCII-whitespace)
|
|
(list readtable:update #\;
|
|
(readtable:jump-discard readtable:read-to-newline))))
|
|
|
|
;;; ;;;;;;;;;;;
|
|
;;; Test reader
|
|
;;; ;;;;;;;;;;;
|
|
(define %list->read
|
|
(lambda (seq)
|
|
(port->read
|
|
(lambda ()
|
|
(if (null? seq)
|
|
#f
|
|
(let ((ch (car seq)))
|
|
(set! seq (cdr seq))
|
|
ch)))
|
|
"test")))
|
|
|
|
(define read-all
|
|
(lambda (str)
|
|
(let ((reader (%list->read (string->list str))))
|
|
(letrec ((loop
|
|
(lambda ()
|
|
(if (not (reader 'peek))
|
|
#t
|
|
(let ((value (readtable:act
|
|
readtable:top (reader 'read)
|
|
#f
|
|
reader)))
|
|
(display (list "return" value))
|
|
(newline)
|
|
(loop))))))
|
|
(loop)))))
|
|
|
|
(read-all "x yy zz ; this is a comment\nx")
|
|
|
|
|