diff --git a/README.rst b/README.rst index ebc68a0..7fa167d 100644 --- a/README.rst +++ b/README.rst @@ -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. diff --git a/read.scm b/read.scm index 224a910..edea2b5 100644 --- a/read.scm +++ b/read.scm @@ -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))