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

readtable: case folding

This commit is contained in:
Peter McGoron 2024-09-07 21:10:40 -04:00
parent 3f56b03f1a
commit 6945841d1c
2 changed files with 62 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
README.rst
View File

@ -19,12 +19,12 @@ 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 essental procedures only (with some exceptions)
* uses R3RS essential procedures 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.
A proper implementation must have
A proper implementation must have, in addition to R3RS,
* ``open-input-port``, ``read-char``
* ``open-output-port``, ``write-char``
@ -32,7 +32,6 @@ A proper implementation must have
* ``and``, ``or``
* ``error``
If your system supports any macro system at all, ``cond-expand``,
``and``, and ``or`` can be implemented. ``error`` can be implemented
as in SRFI-23 : https://srfi.schemers.org/srfi-23/srfi-23.html .
Hopefully your implementation has input and output ports (there's no other
way to write a compiler). Everything else can be expressed in terms of
macros or R3RS essential procedures.

88
read.scm
View File

@ -26,6 +26,7 @@
;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Port reader wrapper
;;; ;;;;;;;;;;;;;;;;;;;;;;;;
(define port->read-function
@ -39,38 +40,50 @@
;;; (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.
;;; (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 '()))
(let ((update-position
(lambda (ch)
(cond
((or (eof-object? ch) (not ch)) (set! ch #f))
((eqv? ch #\newline)
(set! line-number (+ 1 line-number)) (set! offset 0))
(offset (set! offset (+ 1 offset))))
ch)))
(lambda (op . args)
(cond
((eq? op 'pos) (list filename line-number offset))
((eq? op 'read)
(update-position
(if (null? pushback-buffer)
(read-function)
(let ((ch (car pushback-buffer)))
(set! pushback-buffer (cdr pushback-buffer))
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))))
(else (error "read->port: invalid" (cons op args)))))))))
(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 '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
@ -315,10 +328,19 @@
(define readtable:top
(readtable:update-many-sequence
readtable:empty
(cons "#!fold-case"
(readtable:exec:new
(lambda (table char acc port)
(port 'fold-case! #t)
'())))
(cons "#!no-fold-case"
(readtable:exec:new
(lambda (table char acc port)
(port 'fold-case! #f)
'())))
(cons "#t" (readtable:return-value #t))
(cons "#f" (readtable:return-value #f))
(cons "#true" (readtable:return-value #t))
(cons "#trouble" (readtable:return-value 15))))
(cons "#true" (readtable:return-value #t))))
;;; ;;;;;;;;;;;
;;; Test reader
@ -334,8 +356,12 @@
ch)))
"test")))
(let ((true-reader (%list->read (string->list "#t#false#true"))))
(let ((true-reader (%list->read (string->list "#!fold-case#TRUE#!no-fold-case#TRUE"))))
(display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
(newline)
(display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))
(newline)
(display (list "third: " (readtable:top (true-reader 'read) #f true-reader)))
(newline)
(display (list "fourth: " (readtable:top (true-reader 'read) #f true-reader)))
(newline))