>>>>> " " == <dtillman_at_cannonexpress.com> writes:
> That may be a bad phrase for the subject. I have a need to
> store stklos objects in a persistent manner - in a text file
> or dbm file, for example.
> Is there any way to do this? Or, should just give up on
> trying to use the objects and just use simple lists?
It's actually pretty painless to store objects, unless you need to
store "references" within the data of the object. Then it gets
tricky. I simply store objects as expressions which "make
themselves", then you can just "read" and then "eval".
I received some code from a kind soul, but there is a small problem.
The newer versions of stk broke it :-( This is mostly due to the fact
that it accesses some "low-level" functions in stk which I think have
been hidden by the module stuff. However I corrected the obvious
problems and there are still some not so obvious problems lurking.
I haven't had time to fix it, but I gleaned many useful techniques
from it. For one thing, it is a very useful example of metaclasses.
Unfortunately metaclasses still don't quite make sense to me :-(
I include the code here. If you if you don't use it, it would be well
worth your time to study it, I learned a lot about class and slot
manipulation from it. If the person who originally sent it to me can
take a look at it and fix it that would be great !
Brian
P.S. There are _three_ files here.
-------------------------------------------------------------
;;; file.stk: code to read and write files
(require "nixlib")
;;; metaclass for read/writable objects
;;; your object should subclass <saveable>. then
;;; put a :saveable #t in a slot declaration and you
;;; can do read/write
;;;
(define-class <ioclass> (<class>)
(saveable))
(define-class <saveable> ()
()
:metaclass <ioclass>)
;;; look for the :saveable keyword in the slot list
(define (compute-slots-saveable class slots)
(let loop ((slots slots)
(saveable '()))
(cond
((null? slots)
;; keep the saveable list in the same order as the slot list
(slot-set! class 'saveable (reverse! saveable)))
((and (pair? (car slots)) (get-keyword :saveable (cdar slots) #f))
(loop (cdr slots) (cons (caar slots) saveable)))
(else
(loop (cdr slots) saveable)))))
;;; initialize the saveable slot
(define-method initialize ((class <ioclass>) initargs)
(next-method class initargs)
(compute-slots-saveable class (slot-ref class 'slots))
(debug "saveable slots" class (slot-ref class 'saveable))
)
;;; in order to patch up internal references when reading,
;;; we need to be able to allocate before initializing...
;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;
(define global-objs '())
(define (define-id obj id)
(set! global-objs (cons (cons obj id) global-objs)))
;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;
(define-class <writer> ()
((indent :initform 0 :accessor indent-of)
(counter :initform 0 :accessor counter-of)
(obj->data :initform (make-hash-table) :accessor obj->data)
(saved :initform (make-hash-table) :accessor saved)
(to-save :initform '() :accessor to-save)
(do-close? :initform #f)
(port :accessor port-of)
))
(define-method initialize ((wr <writer>) initargs)
(next-method wr initargs)
(let ((port-given (get-keyword :port initargs #f))
(file-given (get-keyword :file initargs #f)))
(cond
(port-given
(set! (port-of wr) port-given))
(file-given
(set! (port-of wr) (open-output-file file-given))
(slot-set! wr 'do-close? #t))
(else
(set! (port-of wr) (current-output-port))))
(for-each (lambda (entry)
(make-id wr (car entry) (cdr entry)))
global-objs)))
(define-method write-list ((wr <writer>) item)
(cond
((null? item)
(display wr ")"))
((pair? item)
(display wr " ")
(write wr (car item))
(write-list wr (cdr item)))
(else
(display wr " . ")
(write wr item)
(display wr ")"))
))
;; this writes out all the slots
(define-method save ((wr <writer>) (o <saveable>))
(display wr "(") (push wr)
(write wr o) (display wr " ")
(for-each (lambda (s)
(write wr (slot-ref o s))
(display wr #\ht)
(format wr ";; ~a" s)
(newline wr))
(slot-ref (class-of o) 'saveable))
(display wr ")") (pop wr) (newline wr)
(hash-table-put! (saved wr) o #t))
;; this writes out all the slots
(define-method save ((wr <writer>) (o <object>))
(display o (port-of wr))
(newline wr)
(hash-table-put! (saved wr) o #t))
;; this makes sure all referenced objects have been saved and then
;; closes the output port if appropriate
(define-method close ((wr <writer>))
(let loop ()
(let ((ts (to-save wr)))
(if (not (null? ts))
(let ((t (car ts)))
(set! (to-save wr) (cdr ts))
(if (not (hash-table-get (saved wr) t #f))
(save wr t))
(loop)))))
(if (slot-ref wr 'do-close?)
(close-output-port (port-of wr)))
)
;; this writes out a reference and remembers to save the object later
;; if necessary
(define-method write ((wr <writer>) (o <saveable>))
(display (obj->id wr o) (port-of wr))
(set! (to-save wr) (cons o (to-save wr))))
(define-method write ((wr <writer>) (o <object>))
(display (obj->id wr o) (port-of wr)))
(define-method write ((wr <writer>) item)
(cond
((pair? item)
(display wr "(")
(write-list wr item))
((symbol? item)
(format wr "(quote ~a)" item))
(else
(format wr "~s" item))))
(define-method display ((wr <writer>) item)
(cond
((pair? item)
(display wr "(")
(write-list wr item))
((symbol? item)
(format wr "(quote ~a)" item))
(else
(display item (port-of wr)))))
(define-method indent ((wr <writer>))
(display (make-string (indent-of wr) #\space) (port-of wr)))
(define-method push ((wr <writer>))
(set! (indent-of wr) (+ 1 (indent-of wr))))
(define-method pop ((wr <writer>))
(if (eq? (indent-of wr) 0)
(error "can't pop below top level"))
(set! (indent-of wr) (- (indent-of wr) 1)))
(define-method make-id ((wr <writer>) (o <top>) id)
(hash-table-put! (obj->data wr) o (cons id #f)))
(define-method obj->id ((wr <writer>) (o <top>))
(let* ((data (hash-table-get (obj->data wr) o #f)))
(if data (car data)
(let* ((index (counter-of wr))
(id (string->symbol
(format #f "~a-~a" (class-name (class-of o)) index))))
(set! (counter-of wr) (+ 1 (counter-of wr)))
(hash-table-put! (obj->data wr) o (cons id index))
id))))
(define-method format ((wr <writer>) string . rest)
(apply format (port-of wr) string rest))
(define-method newline ((wr <writer>))
(newline (port-of wr))
(indent wr))
;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;
(define-class <reader> ()
(;; data is of the form (object . slot-data)
;; if nothing there, the id has not been encountered yet
;; if slot-data is #f, the definition has not been encountered yet
;; if slot-data is #t, object has been reinitialized
(id->data :initform (make-hash-table) :accessor id->data)
(do-close? :initform #f)
(port :accessor port-of)
))
(define-method initialize ((r <reader>) initargs)
(next-method r initargs)
(let ((port-given (get-keyword :port initargs #f))
(file-given (get-keyword :file initargs #f)))
(cond
(port-given
(set! (port-of r) port-given))
(file-given
(set! (port-of r) (open-input-file file-given))
(slot-set! r 'do-close? #t))
(else
(set! (port-of r) (current-input-port))))
(for-each (lambda (entry)
(hash-table-put! (id->data r) (cdr entry)
(cons (car entry) #t)))
global-objs)
))
(define-method close ((r <reader>))
(if (slot-ref r 'do-close?)
(close-input-port (port-of r))))
(define (parse-id id)
(let ((s (symbol->string id)))
(let loop ((index (- (string-length s) 1)))
(cond
((eq? index 0)
(error "can't parse id ~a" id))
((eq? (string-ref s index) #\-)
(cons (substring s 0 index)
(substring s (+ index 1) (string-length s))))
(else
(loop (- index 1)))))))
(define-method id->obj ((r <reader>) id)
(let ((d (hash-table-get (id->data r) id #f)))
(if d (car d)
(let* ((parsed-id (parse-id id))
(o (allocate-instance (eval-string (car parsed-id)))))
(hash-table-put! (id->data r) id (cons o #f))
o))))
(define-method read-item ((r <reader>) id slot-data)
(debug "read-item" id slot-data)
(let* ((o (id->obj r id)))
(hash-table-put! (id->data r) id (cons o slot-data))))
(define-method parse-datum ((r <reader>) d)
(cond
((pair? d)
(if (eq? (car d) 'quote)
(cadr d) ;; actually a symbol
(cons (parse-datum r (car d)) (parse-datum r (cdr d)))))
((vector? d)
(list->vector (map (lambda (d) (parse-datum r d))
(vector->list d))))
((symbol? d)
;; check if it's a reference
(id->obj r d))
(else
d)))
;; this is the base reinitialize method
;; it looks for the :saveable and :initform keywords and does the
;; right thing
(define-method reinitialize ((o <saveable>) r id)
;; go through slots of o
(let* ((ent (hash-table-get (id->data r) id))
(slot-data (cdr ent)))
;; (debug "reinitialize" (format #f "~a" o) slot-data
;; (slot-ref (class-of o) 'slots))
(cond
((eq? slot-data #t)
(debug "already initialized" id))
(else
(let loop ((ss (slot-ref (class-of o) 'slots))
(ds slot-data)
;; (is (slot-ref (class-of o) 'initializers)))
)
(cond
((and (null? ss) (null? ds))
#f)
((null? ss)
(error "reinitialize: more data than saveable slots"))
(else
(let ((s (car ss)))
(if (pair? s)
(let* ((saveable? (get-keyword :saveable (cdr s) #f)))
;;(debug "saveable?" (get-keyword :saveable (cdr s) #f) s)
(cond
(saveable?
(if (null? ds)
(error
"reinitialize: no data for saveable slots ~a" ss))
(slot-set! o (car s)
(parse-datum r (car ds)))
(debug "restored slot" (car s) "to"
(format #f "~a" (slot-ref o (car s))))
; (loop (cdr ss) (cdr ds) (cdr is)))
(loop (cdr ss) (cdr ds)))
; (else
; ;; call the initializer if there is one
; (unless (null? (car is))
; (slot-set! o (car s) ((car is)))
; (debug "initialized slot" (car s) "to"
; (format #f "~a" (slot-ref o (car s)))))
; (loop (cdr ss) ds (cdr is)))
)
))))))))))
(define-method finish ((r <reader>))
;;(debug "finish")
;; check that everything needed is referenced
(hash-table-map (id->data r)
(lambda (key val)
(if (not (cdr val))
(error "no definition for id ~a found" key))))
;; call reinitialize on everything
(hash-table-map (id->data r)
(lambda (key val)
(let ((o (car val))
(data (cdr val)))
(cond
((pair? data)
(reinitialize o r key)
(set-cdr! val #t))
))))
)
;; should reinitialize take the slot-data array?
;; yes, it allows more control of reinitialization order if
;; we delay all reinitialization until the end
(define-method read ((r <reader>))
(debug "read")
(let loop ()
(let ((key (read (port-of r))))
(cond
((eof-object? key)
;; (display "done") (newline)
(finish r))
(else
(cond
((symbol? key)
(display key) (newline)
(loop))
((pair? key)
(read-item r (car key) (cdr key)))
(else
(display key) (newline)))
(loop))))))
;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;
(provide "file")
------------------------------------------------------------
;;; nix-debug.stk: routines to print debug messages, with some
;;; handy features to turn messages off and so on
;;; todo:
;;; really want an outliner / browser to look at messages
;;; make errlist better - use a frame instead of text
;;; scrollbar can add and delete items from packer
;;; options to stop and save state when certain messages are hit
;;; like breakpoint actions in a debugger, but mostly specified in code
;;; live comments
;;; nested messages (for begin-end fn, etc.)
;;; put up an editor window to turn messages on and off
;; message display: rename objects as they show up in the message
;; box to critter-1, critter-2, etc.
;; use hash tables to map object->name and name->object
;; allow new names to be typed in and remember them
;; allow name prefixes to be assigned from within the code too (like runner)
;; really want weak references to do this, objects will never be gc'd...
(define debug-active "0")
(define debug-name->obj (make-hash-table))
(define debug-obj->name (make-hash-table))
(define (debug-assign-name name obj)
(hash-table-put! debug-name->obj name obj)
(hash-table-put! debug-obj->name obj name))
(define (debug-lookup-obj obj)
(cond
((or (is-a? obj <thing>) (is-a? obj <part>))
(obj->id (writer-of the-critter-system) obj))
((pair? obj)
(cons (debug-lookup-obj (car obj)) (debug-lookup-obj (cdr obj))))
((vector? obj)
(list->vector (map debug-lookup-obj (vector->list obj))))
(else
(let ((name (hash-table-get debug-obj->name obj #f)))
(if name name
(format #f "~a" obj))))
))
;; if debug were a macro, could get variable names from the arguments
;; try to make debugging nicer
;; current name stack
;; this could get hairy with recursion...
;; would be cool if it could be kept inside the STk stack
(define debug-name-stack '())
;; name stacks enabled / disabled
;; this is a tree. each node has the form
;; (default profcount . children-alist)
;; default is 'show, 'hide, or 'inherit
(define debug-scopes (vector #t 0 '()))
;; add the argument count to the count for the current scope
(define (debug-add-count c)
(let loop ((parent debug-scopes)
(names (reverse debug-name-stack)))
(let ((scopes (vector-ref parent 2)))
(if (not (null? names))
(let ((next-scopes (assoc (car names) scopes)))
;; if there's no entry yet, make one
(if (not next-scopes)
(begin
(set! next-scopes (cons (car names) (vector 'inherit 0 '())))
(vector-set! parent 2 (cons next-scopes
(vector-ref parent 2)))))
;; proceed to the next one
(loop (cdr next-scopes)
(cdr names)))
(vector-set! parent 1 (+ c (vector-ref parent 1)))))))
(define (debug-show-message? msg)
(if (equal? debug-active "1")
(let loop ((parent debug-scopes) ;; top vector
(default (vector-ref debug-scopes 0))
(names (reverse debug-name-stack)))
(let ((scopes (vector-ref parent 2))) ;; alist
(if (not (null? names))
(let ((next-scopes (assoc (car names) scopes)))
;; next-scopes is (name . vector)
;; if there's no entry yet, make one
(if (not next-scopes)
(begin
(set! next-scopes (cons (car names)
(vector 'inherit 0 '())))
(vector-set! parent 2 (cons next-scopes
(vector-ref parent 2)))))
;; proceed to the next one
(loop (cdr next-scopes)
(if (eq? (vector-ref (cdr next-scopes) 0) 'inherit)
default
(vector-ref (cdr next-scopes) 0))
(cdr names)))
default)))
#f))
(define-macro (debug message . rest)
`(cond
((debug-show-message? ,message)
(display (map debug-lookup-obj ,(cons list (cons message rest))))
(newline)
(flush))))
;; (debug "a" 1 2 3)
;; (debug debug-scopes)
;; (debug-assign-name 'debug-scopes debug-scopes)
(define-macro (debug-scope name . body)
`(let ((ns debug-name-stack))
(dynamic-wind
,(if (symbol-bound? 'prof-total)
`(lambda ()
;; save the old count
(debug-add-count (prof-total 'clear))
(set! debug-name-stack (cons ,name ns)))
`(lambda ()
(set! debug-name-stack (cons ,name ns))))
(lambda () ,_at_body)
,(if (symbol-bound? 'prof-total)
`(lambda ()
;; save the old count
(debug-add-count (prof-total 'clear))
(set! debug-name-stack ns))
`(lambda ()
(set! debug-name-stack ns))))))
;; (debug "foo" "bar")
;; (set! debug-name-stack '())
;; (set! debug-scopes '(#t))
;; (debug-scope 'gaggle (error "uh uh"))
;;
;;
;;
;;
;;
(define (raw-prof-print)
(for-each
(lambda (x)
(let* ((sym (vector-ref x 0))
(ratio (vector-ref x 1))
(count (vector-ref x 2)))
(if (> ratio 0.01)
(let ((pct (round (* ratio 100))))
(display sym) (display " ")
(display pct) (display "% ")
(display count)
(newline)))))
(prof-counts)))
(define (prof-print)
(define (print-scope s i)
(let* ((name (car s))
(count (vector-ref (cdr s) 1))
(kids (vector-ref (cdr s) 2)))
(display (make-string i #\space))
(display name) (display " ")
(display count) (newline)
(for-each (lambda (x)
(print-scope x (+ i 1)))
kids)))
(print-scope (cons 'top debug-scopes) 1))
(define (prof-scope-clear)
(define (clear-scope s)
(let* ((kids (vector-ref (cdr s) 2)))
(vector-set! (cdr s) 1 0)
(for-each clear-scope kids)))
(clear-scope (cons 'top debug-scopes)))
(provide "nix-debug")
------------------------------------------------------------
;;; nixlib.stk: random useful functions. i should probably use
;;; slib or something...
(require "Basics")
(define (delq! x xs)
(let ((extra (cons #f xs)))
(let loop ((tail extra))
(if (null? (cdr tail))
(cdr extra)
(if (eq? (cadr tail) x)
(begin
(set-cdr! tail (cddr tail))
(loop tail))
(loop (cdr tail)))))))
;; for some reason these aren't in the default stk setup
(define-method configure ((obj <Tk-object>))
((Eid obj) 'configure))
(define-method configure ((obj <Tk-object>) option)
(list-ref ((Eid obj) 'configure option) 4))
(define-method configure ((obj <Tk-object>) option value)
((Eid obj) 'configure option value))
;; destructive reverse
(define (reverse! l)
(if (not (null? l))
(let loop ((head l)
(rest (cdr l))
(acc '()))
(set-cdr! head acc)
(cond
((null? rest)
head)
((pair? rest)
(loop rest (cdr rest) head))
(else
(error "reverse!: bad list"))))
'()))
;; (reverse! '())
;; (reverse! '(1))
;; (reverse! '(1 2 3 4 5))
;; (reverse! '(1 2 3 4 5 . 7))
;; remove all redundant items from a list
(define (uniq items)
(let loop ((l items)
(acc '()))
(cond
((null? l)
;; preserve order
(reverse! acc))
((not (pair? l))
(error "uniq: bad list: ~a" items))
((memq (car l) acc)
(loop (cdr l) acc))
(else
(loop (cdr l) (cons (car l) acc))))))
;; (uniq '())
;; (uniq '(1))
;; (uniq '(1 1))
;; (uniq '(1 2 1))
;; (uniq '(1 2 2 1 2 1))
;; (uniq '(1 2 2 1 2 1 . 3))
;; double-ended queue
;; represented as a doubly linked chain of vectors
;; 0: datum
;; 1: prev
;; 2: next
(define-class <deque> ()
((head :initform #f)
(tail :initform #f)
(first :allocation :virtual :accessor first
:slot-ref (lambda (o) (vector-ref (slot-ref o 'head) 0))
:slot-set! (lambda (o v) (vector-set! (slot-ref o 'head) 0 v)))
))
(define-method empty? ((q <deque>))
(and (eq? head #f) (eq? tail #f)))
(define-method enq ((q <deque>) datum)
(let* ((head (slot-ref q 'head))
(new-head (vector datum #f head)))
(slot-set! q 'head new-head)
(vector-set! head 1 new-head)
datum))
(define-method deq ((q <deque>))
(if (empty? q) (error "deq: empty deque ~a" q))
(let* ((tail (slot-ref q 'tail))
(new-tail (vector-ref tail 1)))
(slot-set! q 'tail new-tail)
(if new-tail
(vector-set! new-tail 2 #f)
(slot-set! q 'head #f))
(vector-ref tail 0)))
(define-method pop ((q <deque>))
(if (empty? q) (error "pop: empty deque ~a" q))
(let* ((head (slot-ref q 'head))
(new-head (vector-ref head 2)))
(slot-set! q 'head new-head)
(if new-head
(vector-set! new-head 1 #f)
(slot-set! q 'tail #f))
(vector-ref head 0)))
(define old:newline newline)
(define-method newline rest
(apply old:newline rest))
(define old:format format)
(define-method format rest
(apply old:format rest))
(define old:write write)
(define-method write rest
(apply old:write rest))
(define old:display display)
(define-method display rest
(apply old:display rest))
(define old:read read)
(define-method read rest
(apply old:read rest))
(require "nix-debug")
(provide "nixlib")
Received on Wed Mar 24 1999 - 19:46:01 CET