UNSLISP/read.scm

;;; 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.
;;; (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 '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)))

;;; 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)))

;;; Toplevel reader.
(define readtable:top
  (readtable:process
   (readtable:empty/default readtable:read-ident)
   (list readtable:add-all-as-skip readtable:ASCII-whitespace)))

;;; ;;;;;;;;;;;
;;; Test reader
;;; ;;;;;;;;;;;
(define %list->read
  (lambda (seq)
    (port->read
     (lambda ()
       (if (null? seq)
           #f
           (let ((ch (car seq)))
             (set! seq (cdr seq))
             ch)))
     "test")))

(let ((true-reader (%list->read (string->list "xyzw    abcd    x!"))))
  (display (list "first:" (readtable:act
                           readtable:top (true-reader 'read) #f true-reader)))
  (newline)
  (display (list "second: " (readtable:act
                             readtable:top (true-reader 'read) #f true-reader)))
  (newline)
  (display (list "third: " (readtable:act
                            readtable:top (true-reader 'read) #f true-reader)))
  (newline))