peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add object helper functions

This commit is contained in:
Peter McGoron 2024-09-24 18:14:46 -04:00
parent 06d19b2867
commit 0d5f4545d0
3 changed files with 159 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
linked-list.scm
View File

@ -12,71 +12,42 @@
;;; along with this program. If not, see <https://www.gnu.org/licenses/>. ;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Singly linked list with tail pointer, message passing style. ;;; 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: ;;; LINKED-LIST:
;;; ;;;
;;; (PUSH): Pushes a value to the head of the list. ;;; (PUSH! VAL): Pushes a value to the head of the list.
;;; (PUSH-TAIL): Pushes a value to the end 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. ;;; (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 (define linked-list:new
(lambda () (lambda ()
(let ((head '()) (letrec
(tail '())) ((head '())
(letrec ((push (tail '())
(lambda (val) (this
(set! head (cons val head)) (object/procedures
(if (null? tail) 'push!
(set! tail head) (lambda (val)
#f))) (set! head (cons val head))
(push-tail (if (null? tail)
(lambda (val) (set! tail head))
(if (null? tail) this)
(push val) 'push-tail!
(begin (lambda (val)
(set-cdr! tail (cons val '())) (if (null? tail)
(set! tail (cdr tail)))))) (this 'push! val)
(%set-cdr! (begin
(lambda (val) (set-cdr! tail (cons val '()))
(if (null? tail) (set! tail (cdr tail))))
(error "cannot set cdr of empty list") this)
(set-cdr! tail val))))) 'set-cdr!
(lambda args (lambda (val)
(let ((op (car args))) (if (null? tail)
(cond (error "cannot set cdr of empty list")
((eq? op 'push) (apply push (cdr args))) (set-cdr! tail val))
((eq? op 'push-tail) (apply push-tail (cdr args))) this)
((eq? op 'set-cdr!) (apply %set-cdr! (cdr args))) 'to-list
((eq? op 'to-list) head) (lambda () head))))
((eq? op 'traverse-from-head) (linked-list-elem:new head)) this)))
(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)

57
object.scm Normal file
View File

@ -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 <https://www.gnu.org/licenses/>.
;;;
;;;
;;; 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))))

138
read.scm
View File

@ -39,6 +39,7 @@
(load "chez-compat.scm") (load "chez-compat.scm")
(load "util.scm") (load "util.scm")
(load "set.scm") (load "set.scm")
(load "object.scm")
(load "linked-list.scm") (load "linked-list.scm")
;;; My text editor cannot parse Scheme's character syntax. ;;; My text editor cannot parse Scheme's character syntax.
@ -67,72 +68,73 @@
;;; (PEEK): Read character, push it back, and return it. ;;; (PEEK): Read character, push it back, and return it.
;;; (FOLD-CASE?): Returns a boolean if case folding is enabled. ;;; (FOLD-CASE?): Returns a boolean if case folding is enabled.
;;; (FOLD-CASE! BOOL): Sets the case folding to BOOL. ;;; (FOLD-CASE! BOOL): Sets the case folding to BOOL.
(define port->read (define port->read
(lambda (read-function filename) (lambda (read-function filename)
(let ((line-number 1) (letrec ((line-number 1)
(offset 0) (offset 0)
(pushback-buffer '()) (pushback-buffer '())
(datum-labels '()) (datum-labels '())
(fold-case? #f)) (fold-case? #f)
(letrec ((update-position! (this
(lambda (ch) (object/procedures
(cond 'process
((eqv? ch #\newline) (lambda (ch)
(set! line-number (+ 1 line-number)) (set! offset 0)) (this 'update-position! ch)
;; OFFSET is sometimes set to #F to denote an unknown (cond
;; offset. ((or (eof-object? ch) (not ch)) ch)
(offset (set! offset (+ 1 offset)))))) (fold-case? (char-downcase ch))
(set-datum-label! (else ch)))
(lambda (label value) 'update-position!
(set! datum-labels (lambda (ch)
(car (smap:insert datum-labels label value))))) (cond
(get-datum-label ((eqv? ch #\newline)
(lambda (label) (set! line-number (+ 1 line-number)) (set! offset 0))
(smap:search datum-labels label))) ;; OFFSET is sometimes set to #F to denote an unknown
(dump-mutable ;; offset.
(lambda () (offset (set! offset (+ 1 offset)))))
(list datum-labels fold-case?))) 'set-datum-label!
(restore-mutable! (lambda (label value)
(lambda (state) (set! datum-labels
(set! datum-labels (car state)) (car (smap:insert datum-labels label value))))
(set! fold-case? (cadr state)))) 'get-datum-label
(process (lambda (label)
(lambda (ch) (smap:search datum-labels label))
(update-position! ch) 'dump-mutable
(cond (lambda ()
((or (eof-object? ch) (not ch)) ch) (list datum-labels fold-case?))
(fold-case? (char-downcase ch)) 'restore-mutable!
(else ch)))) (lambda (state)
(port (set! datum-labels (car state))
(lambda (op . args) (set! fold-case? (cadr state)))
;; TODO: turn into string map? 'pos
(cond (lambda () (list filename line-number offset))
((eq? op 'pos) (list filename line-number offset)) 'read
((eq? op 'read) (lambda ()
(process (this 'process
(if (null? pushback-buffer) (if (null? pushback-buffer)
(read-function) (read-function)
(let ((ch (car pushback-buffer))) (let ((ch (car pushback-buffer)))
(set! pushback-buffer (cdr pushback-buffer)) (set! pushback-buffer (cdr pushback-buffer))
ch)))) ch))))
((eq? op 'peek) 'peek
(let ((ch (port 'read))) (lambda ()
(port 'push ch) (let ((ch (this 'read)))
ch)) (this 'push! ch)
((eq? op 'push) ch))
(let ((ch (car args))) 'push!
(if (eqv? ch #\newline) (lambda (ch)
(begin (if (eqv? ch #\newline)
(set! line-number (- line-number 1)) (begin
(set! offset #f)) (set! line-number (- line-number 1))
(set! offset (- offset 1))) (set! offset #f))
(set! pushback-buffer (cons ch pushback-buffer)))) (set! offset (- offset 1)))
((eq? op 'fold-case?) fold-case?) (set! pushback-buffer (cons ch pushback-buffer)))
((eq? op 'fold-case!) (set! fold-case? (car args))) 'fold-case?
((eq? op 'set-datum-label!) (apply set-datum-label! args)) (lambda () fold-case?)
((eq? op 'get-datum-label) (apply get-datum-label args)) 'fold-case!
(else (error "read->port: invalid" (cons op args))))))) (lambda (val) (set! fold-case? val)))))
port)))) this)))
;;; ;;;;;;;;;;;;;; ;;; ;;;;;;;;;;;;;;
;;; Character maps ;;; Character maps
@ -286,13 +288,13 @@
;;; Push back CHAR and return ACC. ;;; Push back CHAR and return ACC.
(define readtable:return-acc-keep-char (define readtable:return-acc-keep-char
(lambda (table char acc port) (lambda (table char acc port)
(port 'push char) (port 'push! char)
acc)) acc))
;;; Push CHAR to ACC and continue reading from TABLE. ;;; Push CHAR to ACC and continue reading from TABLE.
(define readtable:push-char (define readtable:push-char
(lambda (table char acc port) (lambda (table char acc port)
(acc 'push-tail char) (acc 'push-tail! char)
(readtable:act table (port 'read) acc port))) (readtable:act table (port 'read) acc port)))
;;; Define a readtable that constructs an identifier by accepting all ;;; Define a readtable that constructs an identifier by accepting all
@ -326,7 +328,7 @@
(define readtable:read-ident (define readtable:read-ident
(lambda (table char acc port) (lambda (table char acc port)
(let ((lst (linked-list:new))) (let ((lst (linked-list:new)))
(lst 'push char) (lst 'push! char)
(list->string (list->string
((readtable:act readtable:identifier ((readtable:act readtable:identifier
(port 'read) lst port) (port 'read) lst port)
@ -385,7 +387,7 @@
port))) port)))
(cond (cond
((eqv? value 'end-of-list) (acc 'to-list)) ((eqv? value 'end-of-list) (acc 'to-list))
(else (acc 'push-tail value) (else (acc 'push-tail! value)
(loop))))))) (loop)))))))
(loop))))) (loop)))))