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.
;;; 
;;; The reader is based on a readtable that acts (in some instances) like
;;; a trie. The reader reads a character and looks it up in the readtable.
;;; The actions stored in the readtable are either opaque execution actions
;;; or transparent "pass" actions that jump to a new readtable to read more
;;; characters.

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

(define char<=>
  (lambda (x y)
    (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:<=>))

(define charmap:insert-many
  (lambda (cmap . pairs)
    (fold (lambda (pair cmap)
            (car (charmap:insert cmap (car pair) (cdr pair))))
          cmap
          pairs)))

;;; ;;;;;;;;;;
;;; Readtable constructors
;;; 
;;; Readtable actions are objects with the following messages:
;;; 
;;; (STEP TABLE CHAR ACC PORT): Act on CHAR from TABLE with accumulated
;;; value ACC and PORT.
;;; (UPDATE REST ACTION): Return a new readtable action which is the
;;; action of reading REST and executing ACTION after that. This should
;;; preserve the previous action as much as possible.
;;; ;;;;;;;;;;

;;; Pass to new readtable.
;;; 
;;; STEP reads the next character in the sequence and jumps to TABLE
;;; modifying ACC.
;;; 
;;; On UPDATE:
;;; If (NULL? REST), return PASS with a TABLE updated with its default
;;; action to be ACTION.
;;; If (PAIR? REST), return PASS with (TABLE UPDATE REST ACTION).
(define readtable:pass:new
  (lambda (table)
    (let ((step
           (lambda (oldtable char acc port)
             (table (port 'read) acc port)))
          (update
           (lambda (rest action)
             (readtable:pass:new
              (if (null? rest)
                  (table 'with-default-action action)
                  (table 'update rest action))))))
      (lambda (op . args)
        (cond
          ((eq? op 'update) (apply update args))
          ((eq? op 'step) (apply step args))
          (else (error "readtable:pass: invalid" args)))))))

;;; Create a new PASS with a blank TABLE with DEFAULT-ACTION as the
;;; default action.
(define readtable:pass/blank
  (lambda (default-action)
    (readtable:pass:new (readtable:new default-action '()))))

;;; Execute an action.
;;; 
;;; STEP calls PROC with the same arguments.
;;; 
;;; On UPDATE:
;;; If (NULL? REST), then replace this action with ACTION.
;;; If (PAIR? REST), return PASS with an empty table with this object
;;; as the default action, and run (UPDATE REST ACTION) on it.
(define readtable:exec:new
  (lambda (proc)
    (letrec
        ((update
          (lambda (rest action)
            (if (null? rest)
                action
                ((readtable:pass:new (readtable:new exec '()))
                 'update rest action))))
         (exec
          (lambda (op . args)
            (cond
              ((eq? op 'update) (apply update args))
              ((eq? op 'step) (apply proc args))
              (else (error "readtable:exec: invalid" args))))))
      exec)))


;;; ;;;;;;;;;;;;;;;
;;; Default actions
;;; ;;;;;;;;;;;;;;;

;;; Add multiple literal sequences to the readtable.
(define readtable:update-many-sequence
  (lambda (table . pairs)
    (fold (lambda (pair table)
            (readtable:add-sequence table (car pair)
                                    (cdr pair)))
          table
          pairs)))

;;; Signal error on this action.
(define readtable:error-action
  (lambda (emsg)
    (readtable:exec:new
     (lambda (table char acc port)
       (error emsg (list table char acc port))))))

;;; Create an EXEC action that discards the current character.
;;; This should not be a PASS action, because PASS actions emulate
;;; a trie, which is not cyclic.
(define readtable:skip
  (readtable:exec:new
   (lambda (table char acc port)
     (table 'run (port 'read) acc port))))

;;; Ignore everything and return a constant.
(define readtable:return-value
  (lambda (value)
    (readtable:exec:new
     (lambda (table char acc port)
       value))))

;;; Define a new readtable.
;;; 
;;; (X) where (CHAR? X): Execute the action associated with X, or the
;;; default action.
;;; 
;;; (WITH-DEFAULT-ACTION NEW-ACTION): Return a readtable with the same
;;; backing table but with NEW-ACTION as the default action.
;;; 
;;; (UPDATE REST ACTION): Update the action taken by the total application
;;; of REST to be ACTION. REST must be a pair.
(define readtable:new
  (lambda (default-action charmap)
    (letrec
        ((lookup?
          (lambda (char)
            (let ((node (charmap:search charmap char)))
              (if (null? node)
                  #f
                  (map:val node)))))
         (lookup
          (lambda (char)
            (or (lookup? char) default-action)))
         (run*
          (lambda (handler char acc port)
            (handler 'step table char acc port)))
         (run
          (lambda (char acc port)
            (run* (lookup char) char acc port)))
         (with-default-action
             (lambda (new-default-action)
               (readtable:new new-default-action charmap)))
         (empty-pass/error
          (lambda ()
            (readtable:pass/blank (readtable:error-action
                                   "reading long name"))))
         (update-oldnode
          (lambda (rest action)
            (lambda (_ oldnode)
              (if (null? rest)
                  action
                  (let ((replaced (if (null? oldnode)
                                      (empty-pass/error)
                                      (map:val oldnode))))
                    (replaced 'update rest action))))))
         (update
          (lambda (rest action)
            (if (null? rest)
                (error "readtable update: invalid" (list rest action))
                (readtable:new default-action
                               (charmap:update
                                charmap
                                (car rest)
                                (update-oldnode (cdr rest) action))))))
         (table
          (lambda (op . args)
            (cond
              ((not op)
               (apply run* default-action op args))
              ((char? op) (apply run op args))
              ((eq? op 'with-default-action) (apply with-default-action
                                                    args))
              ((eq? op 'update) (apply update args))
              (else (error "readtable: invalid" (cons op args)))))))
      table)))

;;; Wrap ACTION in a readtable, and push bach the currently read character
;;; before calling ACTION.
;;; 
;;; This is designed for readtable actions that already know what they
;;; are matching against.
(define readtable:sequence-wrapper
  (lambda (action)
    (readtable:pass/blank
     (readtable:exec:new
      (lambda (table char acc port)
        (port 'push char)
        (action 'step table #f #f port))))))

;;; Add ACTION as the action to be taken in TABLE following SEQ.
;;; The action is wrapped in an empty PASS table with ACTION as the default
;;; action. This normalizes the character ACTION is passed.
(define readtable:add-sequence
  (lambda (table seq action)
    (let ((seq (cond
                 ((char? seq) (list seq))
                 ((string? seq) (string->list seq))
                 (else seq))))
      (table 'update seq (readtable:sequence-wrapper action)))))

;;; ;;;;;;;;;;;;;;;;;;;
;;; Default readtables
;;; ;;;;;;;;;;;;;;;;;;;

(define readtable:empty
  (readtable:new (readtable:error-action "no more actions")
                 '()))

;;; Ignore all characters until newline.
(define readtable:read-line-comment
  (readtable:new
   readtable:skip
   (charmap:insert-many '()
                        (list
                         (cons #\newline (readtable:return-value #f))))))

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

;;; ;;;;;;;;;;;
;;; 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 "#!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))