/usr/share/guile/2.0/oop/goops/
/usr/share/guile/2.0/oop/goops
NameSizeModeActions
accessors.scm27950644editdlrm
active-slot.scm23110644editdlrm
compile.scm9640644editdlrm
composite-slot.scm27360644editdlrm
describe.scm59790644editdlrm
dispatch.scm106290644editdlrm
internal.scm12980644editdlrm
save.scm245420644editdlrm
simple.scm11870644editdlrm
stklos.scm27960644editdlrm
util.scm22730644editdlrm
Edit: /usr/share/guile/2.0/oop/goops/save.scm (24542B)
;;; installed-scm-file ;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013 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) :use-module (oop goops util) :re-export (make-unbound) :export (save-objects load-objects restore enumerate! enumerate-component! write-readably write-component write-component-procedure literal? readable make-readable)) ;;; ;;; 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 )) #f) (define-method (immediate? (o )) #t) (define-method (immediate? (o )) #t) (define-method (immediate? (o )) #t) (define-method (immediate? (o )) #t) (define-method (immediate? (o )) #t) (define-method (immediate? (o )) #t) ;;; enumerate! OBJECT ENVIRONMENT ;;; ;;; Return #t if object is a literal. ;;; (define-method (enumerate! (o ) env) #t) (define-method (write-readably (o ) 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 ) env) #f) ;;; ;;; Vectors ;;; (define-method (enumerate! (o ) 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 ) 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 ) 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 ) 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(): 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 ) env) (let ((literal? (enumerate-component! (car o) env))) (and (enumerate-component! (cdr o) env) literal?))) (define-method (write-readably (o ) 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 (slotdef g-n-s) (let ((g-n-s (cddr g-n-s))) (cond ((integer? g-n-s) (proc (standard-get g-n-s) (standard-set g-n-s))) ((not (memq (slot-definition-allocation slotdef) '(#:class #:each-subclass))) (proc (car g-n-s) (cadr g-n-s)))))) (class-slots class) (slot-ref class 'getters-n-setters))) (define (access-for-each proc class) (for-each (lambda (slotdef g-n-s) (let ((g-n-s (cddr g-n-s)) (a (slot-definition-accessor slotdef))) (cond ((integer? g-n-s) (proc (slot-definition-name slotdef) (and a (generic-function-name a)) (standard-get g-n-s) (standard-set g-n-s))) ((not (memq (slot-definition-allocation slotdef) '(#:class #:each-subclass))) (proc (slot-definition-name slotdef) (and a (generic-function-name a)) (car g-n-s) (cadr g-n-s)))))) (class-slots class) (slot-ref class 'getters-n-setters))) (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 ) 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 ) 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 ) env) #f) (define-method (write-readably (o ) file env) (display (class-name o) file)) ;;; ;;; Generics ;;; ;;; Currently, we don't support reading in generic functions ;;; (define-method (enumerate! (o ) env) #f) (define-method (write-readably (o ) file env) (display (generic-function-name o) file)) ;;; ;;; Method ;;; ;;; Currently, we don't support reading in methods ;;; (define-method (enumerate! (o ) env) #f) (define-method (write-readably (o ) file env) (goops-error "No read-syntax for defined")) ;;; ;;; Environments ;;; (define-class () (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 ) 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 () (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 )) #f) (define-method (binding o env) (binding (object-info o env))) (define binding? binding) (define-method (literal? (info )) #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 ))) (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 ) (file ) . rest) (let ((port (open-output-file file))) (apply save-objects alist port rest) (close-port port) *unspecified*)) (define-method (save-objects (alist ) (file ) . rest) (let ((excluded (if (>= (length rest) 1) (car rest) '())) (uses (if (>= (length rest) 2) (cadr rest) '()))) (let ((env (make #: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 )) (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 )) (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)))