add object helper functions
This commit is contained in:
parent
06d19b2867
commit
0d5f4545d0
|
|
@ -12,71 +12,42 @@
|
|||
;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; 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)))
|
||||
|
|
|
|||
|
|
@ -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
138
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)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue