From 0d5f4545d0d3db7c9ec63cac005bb71b85fe6b23 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Tue, 24 Sep 2024 18:14:46 -0400 Subject: [PATCH] add object helper functions --- linked-list.scm | 93 +++++++++++--------------------- object.scm | 57 ++++++++++++++++++++ read.scm | 138 ++++++++++++++++++++++++------------------------ 3 files changed, 159 insertions(+), 129 deletions(-) create mode 100644 object.scm 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)))))