diff options
Diffstat (limited to 'module/oop/goops/save.scm')
-rw-r--r-- | module/oop/goops/save.scm | 874 |
1 files changed, 874 insertions, 0 deletions
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm new file mode 100644 index 000000000..20c3b0541 --- /dev/null +++ b/module/oop/goops/save.scm @@ -0,0 +1,874 @@ +;;; installed-scm-file + +;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (oop goops save) + :use-module (oop goops internal) + :export (make-unbound save-objects load-objects restore + enumerate! enumerate-component! + write-readably write-component write-component-procedure + literal? readable make-readable)) + +(define (make-unbound) + *unbound*) + +;;; +;;; save-objects ALIST PORT [EXCLUDED] [USES] +;;; +;;; ALIST ::= ((NAME . OBJECT) ...) +;;; +;;; Save OBJECT ... to PORT so that when the data is read and evaluated +;;; OBJECT ... are re-created under names NAME ... . +;;; Exclude any references to objects in the list EXCLUDED. +;;; Add a (use-modules . USES) line to the top of the saved text. +;;; +;;; In some instances, when `save-object' doesn't know how to produce +;;; readable syntax for an object, you can explicitly register read +;;; syntax for an object using the special form `readable'. +;;; +;;; Example: +;;; +;;; The function `foo' produces an object of obscure structure. +;;; Only `foo' can construct such objects. Because of this, an +;;; object such as +;;; +;;; (define x (vector 1 (foo))) +;;; +;;; cannot be saved by `save-objects'. But if you instead write +;;; +;;; (define x (vector 1 (readable (foo)))) +;;; +;;; `save-objects' will happily produce the necessary read syntax. +;;; +;;; To add new read syntax, hang methods on `enumerate!' and +;;; `write-readably'. +;;; +;;; enumerate! OBJECT ENV +;;; Should call `enumerate-component!' (which takes same args) on +;;; each component object. Should return #t if the composite object +;;; can be written as a literal. (`enumerate-component!' returns #t +;;; if the component is a literal. +;;; +;;; write-readably OBJECT PORT ENV +;;; Should write a readable representation of OBJECT to PORT. +;;; Should use `write-component' to print each component object. +;;; Use `literal?' to decide if a component is a literal. +;;; +;;; Utilities: +;;; +;;; enumerate-component! OBJECT ENV +;;; +;;; write-component OBJECT PATCHER PORT ENV +;;; PATCHER is an expression which, when evaluated, stores OBJECT +;;; into its current location. +;;; +;;; Example: +;;; +;;; (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) +;;; +;;; write-component is a macro. +;;; +;;; literal? COMPONENT ENV +;;; + +(define-method (immediate? (o <top>)) #f) + +(define-method (immediate? (o <null>)) #t) +(define-method (immediate? (o <number>)) #t) +(define-method (immediate? (o <boolean>)) #t) +(define-method (immediate? (o <symbol>)) #t) +(define-method (immediate? (o <char>)) #t) +(define-method (immediate? (o <keyword>)) #t) + +;;; enumerate! OBJECT ENVIRONMENT +;;; +;;; Return #t if object is a literal. +;;; +(define-method (enumerate! (o <top>) env) #t) + +(define-method (write-readably (o <top>) file env) + ;;(goops-error "No read-syntax defined for object `~S'" o) + (write o file) ;doesn't catch bugs, but is much more flexible + ) + +;;; +;;; Readables +;;; + +(define readables (make-weak-key-hash-table 61)) + +(define-macro (readable exp) + `(make-readable ,exp ',(copy-tree exp))) + +(define (make-readable obj expr) + (hashq-set! readables obj expr) + obj) + +(define (readable-expression obj) + `(readable ,(hashq-ref readables obj))) + +;; FIXME: if obj is nil or false, this can return a false value. OTOH +;; usually this is only for non-immediates. +(define (readable? obj) + (hashq-ref readables obj)) + +;;; +;;; Writer helpers +;;; + +(define (write-component-procedure o file env) + "Return #f if circular reference" + (cond ((immediate? o) (write o file) #t) + ((readable? o) (write (readable-expression o) file) #t) + ((excluded? o env) (display #f file) #t) + (else + (let ((info (object-info o env))) + (cond ((not (binding? info)) (write-readably o file env) #t) + ((not (eq? (visiting info) #:defined)) #f) ;forward reference + (else (display (binding info) file) #t)))))) + +;;; write-component OBJECT PATCHER FILE ENV +;;; +(define-macro (write-component object patcher file env) + `(or (write-component-procedure ,object ,file ,env) + (begin + (display #f ,file) + (add-patcher! ,patcher ,env)))) + +;;; +;;; Strings +;;; + +(define-method (enumerate! (o <string>) env) #f) + +;;; +;;; Vectors +;;; + +(define-method (enumerate! (o <vector>) env) + (or (not (vector? o)) + (let ((literal? #t)) + (array-for-each (lambda (o) + (if (not (enumerate-component! o env)) + (set! literal? #f))) + o) + literal?))) + +(define-method (write-readably (o <vector>) file env) + (if (not (vector? o)) + (write o file) + (let ((n (vector-length o))) + (if (zero? n) + (display "#()" file) + (let ((not-literal? (not (literal? o env)))) + (display (if not-literal? + "(vector " + "#(") + file) + (if (and not-literal? + (literal? (vector-ref o 0) env)) + (display #\' file)) + (write-component (vector-ref o 0) + `(vector-set! ,o 0 ,(vector-ref o 0)) + file + env) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (if (and not-literal? + (literal? (vector-ref o i) env)) + (display #\' file)) + (write-component (vector-ref o i) + `(vector-set! ,o ,i ,(vector-ref o i)) + file + env)) + (display #\) file)))))) + + +;;; +;;; Arrays +;;; + +(define-method (enumerate! (o <array>) env) + (enumerate-component! (shared-array-root o) env)) + +(define (make-mapper array) + (let* ((n (array-rank array)) + (indices (reverse (if (<= n 11) + (list-tail '(t s r q p n m l k j i) (- 11 n)) + (let loop ((n n) + (ls '())) + (if (zero? n) + ls + (loop (- n 1) + (cons (gensym "i") ls)))))))) + `(lambda ,indices + (+ ,(shared-array-offset array) + ,@(map (lambda (ind dim inc) + `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind))) + indices + (array-dimensions array) + (shared-array-increments array)))))) + +(define (write-array prefix o not-literal? file env) + (letrec ((inner (lambda (n indices) + (if (not (zero? n)) + (let ((el (apply array-ref o + (reverse (cons 0 indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env))) + (do ((i 1 (+ 1 i))) + ((= i n)) + (display #\space file) + (let ((el (apply array-ref o + (reverse (cons i indices))))) + (if (and not-literal? + (literal? el env)) + (display #\' file)) + (write-component + el + `(array-set! ,o ,el ,@indices) + file + env)))))) + (display prefix file) + (let loop ((dims (array-dimensions o)) + (indices '())) + (cond ((null? (cdr dims)) + (inner (car dims) indices)) + (else + (let ((n (car dims))) + (do ((i 0 (+ 1 i))) + ((= i n)) + (if (> i 0) + (display #\space file)) + (display prefix file) + (loop (cdr dims) (cons i indices)) + (display #\) file)))))) + (display #\) file))) + +(define-method (write-readably (o <array>) file env) + (let ((root (shared-array-root o))) + (cond ((literal? o env) + (if (not (vector? root)) + (write o file) + (begin + (display #\# file) + (display (array-rank o) file) + (write-array #\( o #f file env)))) + ((binding? root env) + (display "(make-shared-array " file) + (if (literal? root env) + (display #\' file)) + (write-component root + (goops-error "write-readably(<array>): internal error") + file + env) + (display #\space file) + (display (make-mapper o) file) + (for-each (lambda (dim) + (display #\space file) + (display dim file)) + (array-dimensions o)) + (display #\) file)) + (else + (display "(list->uniform-array " file) + (display (array-rank o) file) + (display " '() " file) + (write-array "(list " o #f file env))))) + +;;; +;;; Pairs +;;; + +;;; These methods have more complex structure than is required for +;;; most objects, since they take over some of the logic of +;;; `write-component'. +;;; + +(define-method (enumerate! (o <pair>) env) + (let ((literal? (enumerate-component! (car o) env))) + (and (enumerate-component! (cdr o) env) + literal?))) + +(define-method (write-readably (o <pair>) file env) + (let ((proper? (let loop ((ls o)) + (or (null? ls) + (and (pair? ls) + (not (binding? (cdr ls) env)) + (loop (cdr ls)))))) + (1? (or (not (pair? (cdr o))) + (binding? (cdr o) env))) + (not-literal? (not (literal? o env))) + (infos '()) + (refs (ref-stack env))) + (display (cond ((not not-literal?) #\() + (proper? "(list ") + (1? "(cons ") + (else "(cons* ")) + file) + (if (and not-literal? + (literal? (car o) env)) + (display #\' file)) + (write-component (car o) `(set-car! ,o ,(car o)) file env) + (do ((ls (cdr o) (cdr ls)) + (prev o ls)) + ((or (not (pair? ls)) + (binding? ls env)) + (if (not (null? ls)) + (begin + (if (not not-literal?) + (display " ." file)) + (display #\space file) + (if (and not-literal? + (literal? ls env)) + (display #\' file)) + (write-component ls `(set-cdr! ,prev ,ls) file env))) + (display #\) file)) + (display #\space file) + (set! infos (cons (object-info ls env) infos)) + (push-ref! ls env) ;*fixme* optimize + (set! (visiting? (car infos)) #t) + (if (and not-literal? + (literal? (car ls) env)) + (display #\' file)) + (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) + ) + (for-each (lambda (info) + (set! (visiting? info) #f)) + infos) + (set! (ref-stack env) refs) + )) + +;;; +;;; Objects +;;; + +;;; Doesn't yet handle unbound slots + +;; Don't export this function! This is all very temporary. +;; +(define (get-set-for-each proc class) + (for-each (lambda (slot) + (unless (memq (slot-definition-allocation slot) + '(#:class #:each-subclass)) + (let ((ref (slot-definition-slot-ref slot)) + (set (slot-definition-slot-set! slot)) + (index (slot-definition-index slot))) + (if ref + (proc ref set) + (proc (standard-get index) (standard-set index)))))) + (class-slots class))) + +(define (access-for-each proc class) + (for-each (lambda (slot) + (unless (memq (slot-definition-allocation slot) + '(#:class #:each-subclass)) + (let ((name (slot-definition-name slot)) + (accessor (and=> (slot-definition-accessor slot) + generic-function-name)) + (ref (slot-definition-slot-ref slot)) + (set (slot-definition-slot-set! slot)) + (index (slot-definition-index slot))) + (if ref + (proc name accessor ref set) + (proc name accessor + (standard-get index) (standard-set index)))))) + (class-slots class))) + +(define-macro (restore class slots . exps) + "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)" + `(let ((o ((@@ (oop goops) %allocate-instance) ,class '()))) + (for-each (lambda (name val) + (slot-set! o name val)) + ',slots + (list ,@exps)) + o)) + +(define-method (enumerate! (o <object>) env) + (get-set-for-each (lambda (get set) + (let ((val (get o))) + (if (not (unbound? val)) + (enumerate-component! val env)))) + (class-of o)) + #f) + +(define-method (write-readably (o <object>) file env) + (let ((class (class-of o))) + (display "(restore " file) + (display (class-name class) file) + (display " (" file) + (let ((slotdefs + (filter (lambda (slotdef) + (not (or (memq (slot-definition-allocation slotdef) + '(#:class #:each-subclass)) + (and (slot-bound? o (slot-definition-name slotdef)) + (excluded? + (slot-ref o (slot-definition-name slotdef)) + env))))) + (class-slots class)))) + (if (not (null? slotdefs)) + (begin + (display (slot-definition-name (car slotdefs)) file) + (for-each (lambda (slotdef) + (display #\space file) + (display (slot-definition-name slotdef) file)) + (cdr slotdefs))))) + (display #\) file) + (access-for-each (lambda (name aname get set) + (display #\space file) + (let ((val (get o))) + (cond ((unbound? val) + (display '(make-unbound) file)) + ((excluded? val env)) + (else + (if (literal? val env) + (display #\' file)) + (write-component val + (if aname + `(set! (,aname ,o) ,val) + `(slot-set! ,o ',name ,val)) + file env))))) + class) + (display #\) file))) + +;;; +;;; Classes +;;; + +;;; Currently, we don't support reading in class objects +;;; + +(define-method (enumerate! (o <class>) env) #f) + +(define-method (write-readably (o <class>) file env) + (display (class-name o) file)) + +;;; +;;; Generics +;;; + +;;; Currently, we don't support reading in generic functions +;;; + +(define-method (enumerate! (o <generic>) env) #f) + +(define-method (write-readably (o <generic>) file env) + (display (generic-function-name o) file)) + +;;; +;;; Method +;;; + +;;; Currently, we don't support reading in methods +;;; + +(define-method (enumerate! (o <method>) env) #f) + +(define-method (write-readably (o <method>) file env) + (goops-error "No read-syntax for <method> defined")) + +;;; +;;; Environments +;;; + +(define-class <environment> () + (object-info #:accessor object-info + #:init-form (make-hash-table 61)) + (excluded #:accessor excluded + #:init-form (make-hash-table 61)) + (pass-2? #:accessor pass-2? + #:init-value #f) + (ref-stack #:accessor ref-stack + #:init-value '()) + (objects #:accessor objects + #:init-value '()) + (pre-defines #:accessor pre-defines + #:init-value '()) + (locals #:accessor locals + #:init-value '()) + (stand-ins #:accessor stand-ins + #:init-value '()) + (post-defines #:accessor post-defines + #:init-value '()) + (patchers #:accessor patchers + #:init-value '()) + (multiple-bound #:accessor multiple-bound + #:init-value '()) + ) + +(define-method (initialize (env <environment>) initargs) + (next-method) + (cond ((get-keyword #:excluded initargs #f) + => (lambda (excludees) + (for-each (lambda (e) + (hashq-create-handle! (excluded env) e #f)) + excludees))))) + +(define-method (object-info o env) + (hashq-ref (object-info env) o)) + +(define-method ((setter object-info) o env x) + (hashq-set! (object-info env) o x)) + +(define (excluded? o env) + (hashq-get-handle (excluded env) o)) + +(define (add-patcher! patcher env) + (set! (patchers env) (cons patcher (patchers env)))) + +(define (push-ref! o env) + (set! (ref-stack env) (cons o (ref-stack env)))) + +(define (pop-ref! env) + (set! (ref-stack env) (cdr (ref-stack env)))) + +(define (container env) + (car (ref-stack env))) + +(define-class <object-info> () + (visiting #:accessor visiting + #:init-value #f) + (binding #:accessor binding + #:init-value #f) + (literal? #:accessor literal? + #:init-value #f) + ) + +(define visiting? visiting) + +(define-method (binding (info <boolean>)) + #f) + +(define-method (binding o env) + (binding (object-info o env))) + +(define binding? binding) + +(define-method (literal? (info <boolean>)) + #t) + +;;; Note that this method is intended to be used only during the +;;; writing pass +;;; +(define-method (literal? o env) + (or (immediate? o) + (excluded? o env) + (let ((info (object-info o env))) + ;; write-component sets all bindings first to #:defining, + ;; then to #:defined + (and (or (not (binding? info)) + ;; we might be using `literal?' in a write-readably method + ;; to query about the object being defined + (and (eq? (visiting info) #:defining) + (null? (cdr (ref-stack env))))) + (literal? info))))) + +;;; +;;; Enumeration +;;; + +;;; Enumeration has two passes. +;;; +;;; Pass 1: Detect common substructure, circular references and order +;;; +;;; Pass 2: Detect literals + +(define (enumerate-component! o env) + (cond ((immediate? o) #t) + ((readable? o) #f) + ((excluded? o env) #t) + ((pass-2? env) + (let ((info (object-info o env))) + (if (binding? info) + ;; if circular reference, we print as a literal + ;; (note that during pass-2, circular references are + ;; forward references, i.e. *not* yet marked with #:pass-2 + (not (eq? (visiting? info) #:pass-2)) + (and (enumerate! o env) + (begin + (set! (literal? info) #t) + #t))))) + ((object-info o env) + => (lambda (info) + (set! (binding info) #t) + (if (visiting? info) + ;; circular reference--mark container + (set! (binding (object-info (container env) env)) #t)))) + (else + (let ((info (make <object-info>))) + (set! (object-info o env) info) + (push-ref! o env) + (set! (visiting? info) #t) + (enumerate! o env) + (set! (visiting? info) #f) + (pop-ref! env) + (set! (objects env) (cons o (objects env))))))) + + +;;; +;;; Main engine +;;; + +(define binding-name car) +(define binding-object cdr) + +(define (pass-1! alist env) + ;; Determine object order and necessary bindings + (for-each (lambda (binding) + (enumerate-component! (binding-object binding) env)) + alist)) + +(define (make-local i) + (string->symbol (string-append "%o" (number->string i)))) + +(define (name-bindings! alist env) + ;; Name top-level bindings + (for-each (lambda (b) + (let ((o (binding-object b))) + (if (not (or (immediate? o) + (readable? o) + (excluded? o env))) + (let ((info (object-info o env))) + (if (symbol? (binding info)) + ;; already bound to a variable + (set! (multiple-bound env) + (acons (binding info) + (binding-name b) + (multiple-bound env))) + (set! (binding info) + (binding-name b))))))) + alist) + ;; Name rest of bindings and create stand-in and definition lists + (let post-loop ((ls (objects env)) + (post-defs '())) + (cond ((or (null? ls) + (eq? (binding (car ls) env) #t)) + (set! (post-defines env) post-defs) + (set! (objects env) ls)) + ((not (binding (car ls) env)) + (post-loop (cdr ls) post-defs)) + (else + (post-loop (cdr ls) (cons (car ls) post-defs))))) + (let pre-loop ((ls (reverse (objects env))) + (i 0) + (pre-defs '()) + (locs '()) + (sins '())) + (if (null? ls) + (begin + (set! (pre-defines env) (reverse pre-defs)) + (set! (locals env) (reverse locs)) + (set! (stand-ins env) (reverse sins))) + (let ((info (object-info (car ls) env))) + (cond ((not (binding? info)) + (pre-loop (cdr ls) i pre-defs locs sins)) + ((boolean? (binding info)) + ;; local + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + sins)) + ((null? locs) + (pre-loop (cdr ls) + i + (cons (car ls) pre-defs) + locs + sins)) + (else + (let ((real-name (binding info))) + (set! (binding info) (make-local i)) + (pre-loop (cdr ls) + (+ 1 i) + pre-defs + (cons (car ls) locs) + (acons (binding info) real-name sins))))))))) + +(define (pass-2! env) + (set! (pass-2? env) #t) + (for-each (lambda (o) + (let ((info (object-info o env))) + (set! (literal? info) (enumerate! o env)) + (set! (visiting info) #:pass-2))) + (append (pre-defines env) + (locals env) + (post-defines env)))) + +(define (write-define! name val literal? file) + (display "(define " file) + (display name file) + (display #\space file) + (if literal? (display #\' file)) + (write val file) + (display ")\n" file)) + +(define (write-empty-defines! file env) + (for-each (lambda (stand-in) + (write-define! (cdr stand-in) #f #f file)) + (stand-ins env)) + (for-each (lambda (o) + (write-define! (binding o env) #f #f file)) + (post-defines env))) + +(define (write-definition! prefix o file env) + (display prefix file) + (let ((info (object-info o env))) + (display (binding info) file) + (display #\space file) + (if (literal? info) + (display #\' file)) + (push-ref! o env) + (set! (visiting info) #:defining) + (write-readably o file env) + (set! (visiting info) #:defined) + (pop-ref! env) + (display #\) file))) + +(define (write-let*-head! file env) + (display "(let* (" file) + (write-definition! "(" (car (locals env)) file env) + (for-each (lambda (o) + (write-definition! "\n (" o file env)) + (cdr (locals env))) + (display ")\n" file)) + +(define (write-rebindings! prefix bindings file env) + (for-each (lambda (patch) + (display prefix file) + (display (cdr patch) file) + (display #\space file) + (display (car patch) file) + (display ")\n" file)) + bindings)) + +(define (write-definitions! selector prefix file env) + (for-each (lambda (o) + (write-definition! prefix o file env) + (newline file)) + (selector env))) + +(define (write-patches! prefix file env) + (for-each (lambda (patch) + (display prefix file) + (display (let name-objects ((patcher patch)) + (cond ((binding patcher env) + => (lambda (name) + (cond ((assq name (stand-ins env)) + => cdr) + (else name)))) + ((pair? patcher) + (cons (name-objects (car patcher)) + (name-objects (cdr patcher)))) + (else patcher))) + file) + (newline file)) + (reverse (patchers env)))) + +(define (write-immediates! alist file) + (for-each (lambda (b) + (if (immediate? (binding-object b)) + (write-define! (binding-name b) + (binding-object b) + #t + file))) + alist)) + +(define (write-readables! alist file env) + (let ((written '())) + (for-each (lambda (b) + (cond ((not (readable? (binding-object b)))) + ((assq (binding-object b) written) + => (lambda (p) + (set! (multiple-bound env) + (acons (cdr p) + (binding-name b) + (multiple-bound env))))) + (else + (write-define! (binding-name b) + (readable-expression (binding-object b)) + #f + file) + (set! written (acons (binding-object b) + (binding-name b) + written))))) + alist))) + +(define-method (save-objects (alist <pair>) (file <string>) . rest) + (let ((port (open-output-file file))) + (apply save-objects alist port rest) + (close-port port) + *unspecified*)) + +(define-method (save-objects (alist <pair>) (file <output-port>) . rest) + (let ((excluded (if (>= (length rest) 1) (car rest) '())) + (uses (if (>= (length rest) 2) (cadr rest) '()))) + (let ((env (make <environment> #:excluded excluded))) + (pass-1! alist env) + (name-bindings! alist env) + (pass-2! env) + (if (not (null? uses)) + (begin + (write `(use-modules ,@uses) file) + (newline file))) + (write-immediates! alist file) + (if (null? (locals env)) + (begin + (write-definitions! post-defines "(define " file env) + (write-patches! "" file env)) + (begin + (write-definitions! pre-defines "(define " file env) + (write-empty-defines! file env) + (write-let*-head! file env) + (write-rebindings! " (set! " (stand-ins env) file env) + (write-definitions! post-defines " (set! " file env) + (write-patches! " " file env) + (display " )\n" file))) + (write-readables! alist file env) + (write-rebindings! "(define " (reverse (multiple-bound env)) file env)))) + +(define-method (load-objects (file <string>)) + (let* ((port (open-input-file file)) + (objects (load-objects port))) + (close-port port) + objects)) + +(define iface (module-public-interface (current-module))) + +(define-method (load-objects (file <input-port>)) + (let ((m (make-module))) + (module-use! m the-scm-module) + (module-use! m iface) + (save-module-excursion + (lambda () + (set-current-module m) + (let loop ((sexp (read file))) + (if (not (eof-object? sexp)) + (begin + (eval sexp m) + (loop (read file))))))) + (module-map (lambda (name var) + (cons name (variable-ref var))) + m))) |