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

73
linked-list.scm
View File

@ -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
(letrec
((head '())
(tail '())
(this
(object/procedures
'push!
(lambda (val)
(set! head (cons val head))
(if (null? tail)
(set! tail head)
#f)))
(push-tail
(set! tail head))
this)
'push-tail!
(lambda (val)
(if (null? tail)
(push val)
(this 'push! val)
(begin
(set-cdr! tail (cons val '()))
(set! tail (cdr tail))))))
(%set-cdr!
(set! tail (cdr tail))))
this)
'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)
(set-cdr! tail val))
this)
'to-list
(lambda () head))))
this)))

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))))

86
read.scm
View File

@ -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)
(letrec ((line-number 1)
(offset 0)
(pushback-buffer '())
(datum-labels '())
(fold-case? #f))
(letrec ((update-position!
(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!
(offset (set! offset (+ 1 offset)))))
'set-datum-label!
(lambda (label value)
(set! datum-labels
(car (smap:insert datum-labels label value)))))
(get-datum-label
(car (smap:insert datum-labels label value))))
'get-datum-label
(lambda (label)
(smap:search datum-labels label)))
(dump-mutable
(smap:search datum-labels label))
'dump-mutable
(lambda ()
(list datum-labels fold-case?)))
(restore-mutable!
(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
(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))))
((eq? op 'peek)
(let ((ch (port 'read)))
(port 'push ch)
'peek
(lambda ()
(let ((ch (this 'read)))
(this 'push! ch)
ch))
((eq? op 'push)
(let ((ch (car args)))
'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))))
((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))))
(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)))))