Changeset 8624


Ignore:
Timestamp:
02/22/05 18:39:23 (16 years ago)
Author:
piso
Message:

Work in progress.

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/compile-file.lisp

    r8622 r8624  
    22;;;
    33;;; Copyright (C) 2004-2005 Peter Graves
    4 ;;; $Id: compile-file.lisp,v 1.57 2005-02-21 18:28:55 piso Exp $
     4;;; $Id: compile-file.lisp,v 1.58 2005-02-22 18:38:14 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    6060          (load-compiled-function classfile)))))
    6161
     62(defun dump-object (object stream)
     63  (cond ((consp object)
     64         (write-char #\( stream)
     65         (loop
     66           (dump-object (car object) stream)
     67           (setf object (cdr object))
     68           (when (null object)
     69             (return))
     70           (write-char #\space stream)
     71           (when (atom object)
     72             (dump-object object stream)
     73             (return)))
     74         (write-char #\) stream))
     75        ((structure-object-p object)
     76         (multiple-value-bind (creation-form initialization-form)
     77             (make-load-form object)
     78           (write-string "#." stream)
     79           (write `(prog1 ,creation-form ,initialization-form) :stream stream)))
     80        (t
     81         (write object :stream stream))))
     82
    6283(defun dump-form (form stream)
    6384  (when (and (consp form) (neq (car form) 'QUOTE))
     
    6889      (if (eq (car form) 'IMPORT)
    6990          ;; Make sure package prefix is printed when symbols are imported.
    70           (let ((*package* (find-package "COMMON-LISP")))
    71             (write form :stream stream))
    72           (write form :stream stream)))
     91          (let ((*package* +keyword-package+))
     92            (dump-object form stream))
     93          (dump-object form stream)))
    7394    (terpri stream)))
    7495
     
    226247            (when compile-time-too
    227248              (eval form))))))
    228 ;;   (when (and (consp form) (neq (car form) 'QUOTE))
    229 ;;     (let ((*print-fasl* t)
    230 ;;           (*print-level* nil)
    231 ;;           (*print-length* nil)
    232 ;;           (*print-circle* nil))
    233 ;;       (if (eq (car form) 'IMPORT)
    234 ;;           ;; Make sure package prefix is printed when symbols are imported.
    235 ;;           (let ((*package* (find-package "COMMON-LISP")))
    236 ;;             (write form :stream stream))
    237 ;;           (write form :stream stream)))
    238 ;;     (terpri stream))
    239   (dump-form form stream)
    240   )
     249  (dump-form form stream))
    241250
    242251(defun process-toplevel-progn (forms stream compile-time-too)
  • trunk/j/src/org/armedbear/lisp/make-load-form-saving-slots.lisp

    r8173 r8624  
    11;;; make-load-form-saving-slots.lisp
    22;;;
    3 ;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id: make-load-form-saving-slots.lisp,v 1.2 2004-11-21 04:34:06 piso Exp $
     3;;; Copyright (C) 2004-2005 Peter Graves
     4;;; $Id: make-load-form-saving-slots.lisp,v 1.3 2005-02-22 18:39:23 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2424(defun make-load-form-saving-slots (object &key slot-names environment)
    2525  (let ((class (class-of object))
    26         (inits ()))
     26        (inits ())
     27        (instance (gensym "INSTANCE-")))
    2728    (cond ((typep object 'structure-object)
    2829           (let ((index 0))
     
    3233                           (null slot-names))
    3334                   (let ((value (%structure-ref object index)))
    34                      (push `(%structure-set ,object ,index ',value) inits))))
     35                     (push `(%structure-set ,instance ,index ',value) inits))))
    3536               (incf index))))
    3637          ((typep object 'standard-object)
     
    4142                 (when (slot-boundp object slot-name)
    4243                   (let ((value (slot-value object slot-name)))
    43                      (push `(setf (slot-value ,object ',slot-name) ',value) inits))))))))
    44     (values `(allocate-instance (find-class ',(sys::%class-name class)))
    45             `(progn ,@inits))))
     44                     (push `(setf (slot-value ,instance ',slot-name) ',value) inits))))))))
     45;;     (values `(allocate-instance (find-class ',(%class-name class)))
     46;;             `(progn ,@inits))))
     47    (values `(let ((,instance (allocate-instance (find-class ',(%class-name class)))))
     48               (progn ,@inits)
     49               ,instance)
     50            nil)))
Note: See TracChangeset for help on using the changeset viewer.