diff --git a/linked-list.scm b/linked-list.scm
index 356b2b2..c9dff5b 100644
--- a/linked-list.scm
+++ b/linked-list.scm
@@ -12,71 +12,42 @@
;;; along with this program. If not, see .
;;; Singly linked list with tail pointer, message passing style.
-
-;;; LINKED-LIST-ELEM:
;;;
-;;; (NEXT): Goes to the next element, if it exists. Does nothing if the
-;;; iterator is at the end of the list.
-;;; (GET): Gets the element at this list, signals error if at the end
-;;; of the list.
-;;; (EMPTY?): True if there are no more values to go to.
-
-(define linked-list-elem:new
- (lambda (ptr)
- (lambda args
- (let ((op (car args)))
- (cond
- ((eq? op 'next)
- (if (not (null? ptr))
- (set! ptr (cdr ptr))
- #f)
- (null? ptr))
- ((eq? op 'get) (car ptr))
- ((eq? op 'empty?) (null? ptr)))))))
-
;;; LINKED-LIST:
;;;
-;;; (PUSH): Pushes a value to the head of the list.
-;;; (PUSH-TAIL): Pushes a value to the end of the list.
+;;; (PUSH! VAL): Pushes a value to the head of the list.
+;;; (PUSH-TAIL! VAL): Pushes a value to the end of the list.
+;;; (SET-CDR! VAL): Set the cdr of TAIL to VAL. This will be overrwitten
+;;; if PUSH-TAIL! is called again.
;;; (TO-LIST): Returns a list structure.
-;;; (TRAVERSE-FROM-HEAD): Returns an instance of LINKED-LIST-ELEM pointing
-;;; to the head of the list.
(define linked-list:new
(lambda ()
- (let ((head '())
- (tail '()))
- (letrec ((push
- (lambda (val)
- (set! head (cons val head))
- (if (null? tail)
- (set! tail head)
- #f)))
- (push-tail
- (lambda (val)
- (if (null? tail)
- (push val)
- (begin
- (set-cdr! tail (cons val '()))
- (set! tail (cdr tail))))))
- (%set-cdr!
- (lambda (val)
- (if (null? tail)
- (error "cannot set cdr of empty list")
- (set-cdr! tail val)))))
- (lambda args
- (let ((op (car args)))
- (cond
- ((eq? op 'push) (apply push (cdr args)))
- ((eq? op 'push-tail) (apply push-tail (cdr args)))
- ((eq? op 'set-cdr!) (apply %set-cdr! (cdr args)))
- ((eq? op 'to-list) head)
- ((eq? op 'traverse-from-head) (linked-list-elem:new head))
- (else (error (cons "invalid operation" args))))))))))
-
-(define x (linked-list:new))
-(x 'push-tail 1)
-(x 'push-tail 2)
-(x 'push-tail 3)
-(x 'to-list)
-
+ (letrec
+ ((head '())
+ (tail '())
+ (this
+ (object/procedures
+ 'push!
+ (lambda (val)
+ (set! head (cons val head))
+ (if (null? tail)
+ (set! tail head))
+ this)
+ 'push-tail!
+ (lambda (val)
+ (if (null? tail)
+ (this 'push! val)
+ (begin
+ (set-cdr! tail (cons val '()))
+ (set! tail (cdr tail))))
+ this)
+ 'set-cdr!
+ (lambda (val)
+ (if (null? tail)
+ (error "cannot set cdr of empty list")
+ (set-cdr! tail val))
+ this)
+ 'to-list
+ (lambda () head))))
+ this)))
diff --git a/object.scm b/object.scm
new file mode 100644
index 0000000..c03d599
--- /dev/null
+++ b/object.scm
@@ -0,0 +1,57 @@
+;;; 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 .
+;;;
+;;;
+;;; Handles messages passed to objects. The state of each object is
+;;; expected to be in the table or in the environment. Each message
+;;; invokes a procedure whose name is the first argument to the object,
+;;; and the arguments to that procedure are the rest of the arguments to
+;;; the object.
+
+;;; Lookup NAME-AS-SYMBOL in TABLE and returns the handler, or the default
+;;; handler if not available.
+(define object:lookup
+ (lambda (table name-as-symbol)
+ (let ((node (smap:search table (symbol->string name-as-symbol))))
+ (if (null? node)
+ (set! node (smap:search table "default")))
+ (if (null? node)
+ (error "object:lookup" "no handler found for" name-as-symbol)
+ (map:val node)))))
+
+;;; Create an object with TABLE as its procedure table.
+(define object/table
+ (lambda (table)
+ (lambda (op . args)
+ (apply (object:lookup table op) args))))
+
+;;; Append procedures to a table.
+(define object:append-table
+ (lambda (table next-pairs)
+ (if (null? next-pairs)
+ table
+ (let ((key (symbol->string (car next-pairs)))
+ (proc (cadr next-pairs)))
+ (object:append-table
+ (car (smap:insert table key proc))
+ (cddr next-pairs))))))
+
+;;; Convert a list of 'SYMBOL PROCEDURE ... into a table.
+(define object:list->table
+ (lambda pairs
+ (object:append-table '() pairs)))
+
+
+(define object/procedures
+ (lambda procedures
+ (object/table (apply object:list->table procedures))))
\ No newline at end of file
diff --git a/read.scm b/read.scm
index 9040772..07d708c 100644
--- a/read.scm
+++ b/read.scm
@@ -39,6 +39,7 @@
(load "chez-compat.scm")
(load "util.scm")
(load "set.scm")
+(load "object.scm")
(load "linked-list.scm")
;;; My text editor cannot parse Scheme's character syntax.
@@ -67,72 +68,73 @@
;;; (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 '())
- (datum-labels '())
- (fold-case? #f))
- (letrec ((update-position!
- (lambda (ch)
- (cond
- ((eqv? ch #\newline)
- (set! line-number (+ 1 line-number)) (set! offset 0))
- ;; OFFSET is sometimes set to #F to denote an unknown
- ;; offset.
- (offset (set! offset (+ 1 offset))))))
- (set-datum-label!
- (lambda (label value)
- (set! datum-labels
- (car (smap:insert datum-labels label value)))))
- (get-datum-label
- (lambda (label)
- (smap:search datum-labels label)))
- (dump-mutable
- (lambda ()
- (list datum-labels fold-case?)))
- (restore-mutable!
- (lambda (state)
- (set! datum-labels (car state))
- (set! fold-case? (cadr state))))
- (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)
- ;; TODO: turn into string map?
- (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)))
- ((eq? op 'set-datum-label!) (apply set-datum-label! args))
- ((eq? op 'get-datum-label) (apply get-datum-label args))
- (else (error "read->port: invalid" (cons op args)))))))
- port))))
+ (letrec ((line-number 1)
+ (offset 0)
+ (pushback-buffer '())
+ (datum-labels '())
+ (fold-case? #f)
+ (this
+ (object/procedures
+ 'process
+ (lambda (ch)
+ (this 'update-position! ch)
+ (cond
+ ((or (eof-object? ch) (not ch)) ch)
+ (fold-case? (char-downcase ch))
+ (else ch)))
+ 'update-position!
+ (lambda (ch)
+ (cond
+ ((eqv? ch #\newline)
+ (set! line-number (+ 1 line-number)) (set! offset 0))
+ ;; OFFSET is sometimes set to #F to denote an unknown
+ ;; offset.
+ (offset (set! offset (+ 1 offset)))))
+ 'set-datum-label!
+ (lambda (label value)
+ (set! datum-labels
+ (car (smap:insert datum-labels label value))))
+ 'get-datum-label
+ (lambda (label)
+ (smap:search datum-labels label))
+ 'dump-mutable
+ (lambda ()
+ (list datum-labels fold-case?))
+ 'restore-mutable!
+ (lambda (state)
+ (set! datum-labels (car state))
+ (set! fold-case? (cadr state)))
+ 'pos
+ (lambda () (list filename line-number offset))
+ 'read
+ (lambda ()
+ (this 'process
+ (if (null? pushback-buffer)
+ (read-function)
+ (let ((ch (car pushback-buffer)))
+ (set! pushback-buffer (cdr pushback-buffer))
+ ch))))
+ 'peek
+ (lambda ()
+ (let ((ch (this 'read)))
+ (this 'push! ch)
+ ch))
+ 'push!
+ (lambda (ch)
+ (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)))
+ 'fold-case?
+ (lambda () fold-case?)
+ 'fold-case!
+ (lambda (val) (set! fold-case? val)))))
+ this)))
;;; ;;;;;;;;;;;;;;
;;; Character maps
@@ -286,13 +288,13 @@
;;; Push back CHAR and return ACC.
(define readtable:return-acc-keep-char
(lambda (table char acc port)
- (port 'push char)
+ (port 'push! char)
acc))
;;; Push CHAR to ACC and continue reading from TABLE.
(define readtable:push-char
(lambda (table char acc port)
- (acc 'push-tail char)
+ (acc 'push-tail! char)
(readtable:act table (port 'read) acc port)))
;;; Define a readtable that constructs an identifier by accepting all
@@ -326,7 +328,7 @@
(define readtable:read-ident
(lambda (table char acc port)
(let ((lst (linked-list:new)))
- (lst 'push char)
+ (lst 'push! char)
(list->string
((readtable:act readtable:identifier
(port 'read) lst port)
@@ -385,7 +387,7 @@
port)))
(cond
((eqv? value 'end-of-list) (acc 'to-list))
- (else (acc 'push-tail value)
+ (else (acc 'push-tail! value)
(loop)))))))
(loop)))))