From df698263126d34dd6ce771483526bd1f0142d1f9 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Fri, 27 Sep 2024 11:16:25 -0400 Subject: [PATCH] Revert "add object helper functions" This reverts commit 0d5f4545d0d3db7c9ec63cac005bb71b85fe6b23. --- linked-list.scm | 93 +++++++++++++++++++++----------- object.scm | 57 -------------------- read.scm | 138 ++++++++++++++++++++++++------------------------ 3 files changed, 129 insertions(+), 159 deletions(-) delete mode 100644 object.scm diff --git a/linked-list.scm b/linked-list.scm index c9dff5b..356b2b2 100644 --- a/linked-list.scm +++ b/linked-list.scm @@ -12,42 +12,71 @@ ;;; 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! 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. +;;; (PUSH): Pushes a value to the head of the list. +;;; (PUSH-TAIL): Pushes a value to the end of the list. ;;; (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 () - (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))) + (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) + diff --git a/object.scm b/object.scm deleted file mode 100644 index c03d599..0000000 --- a/object.scm +++ /dev/null @@ -1,57 +0,0 @@ -;;; 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 07d708c..9040772 100644 --- a/read.scm +++ b/read.scm @@ -39,7 +39,6 @@ (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. @@ -68,73 +67,72 @@ ;;; (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) - (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))) + (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)))) ;;; ;;;;;;;;;;;;;; ;;; Character maps @@ -288,13 +286,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 @@ -328,7 +326,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) @@ -387,7 +385,7 @@ port))) (cond ((eqv? value 'end-of-list) (acc 'to-list)) - (else (acc 'push-tail! value) + (else (acc 'push-tail value) (loop))))))) (loop)))))