(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "LISP")

(il:filecreated "30-Oct-86 11:00:15" il:{eris}<lispcore>sources>defstruct-run-time.\;7
 11955  

      il:|changes| il:|to:|  (il:fns il:\\defprint.defstruct.default)
                             (il:vars il:defstruct-run-timecoms)
                             (il:functions print-structure-instance default-structure-printer 
                                    si::%structure-declare-datatype create-structure-object)
                             (il:variables *print-structure*)

      il:|previous| il:|date:| "29-Oct-86 21:57:58" il:{eris}<lispcore>sources>defstruct-run-time.\;6
)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:defstruct-run-timecoms)

(il:rpaqq il:defstruct-run-timecoms
 ((il:functions si::%structure-declare-datatype 
                                            create-structure-object print-structure-instance)
                                     (il:variables *parsed-structures* *print-structure*)
                                     (il:functions set-parsed-structure parsed-structure 
                                            structure-slot-names default-structure-printer 
                                            il:create-structure structure-constructor)
                                     (il:setfs parsed-structure)
                                     (il:* il:|;;| 
                               "USES STRUCTURE-SLOT-NAMES but for now supports looking on the plist."
                                           )
                                     (il:functions il:slot-list)
                                     (il:fns il:\\defprint.defstruct.default)
                                     (il:prop il:filetype il:defstruct-run-time)
                                     (il:prop il:makefile-environment il:defstruct-run-time)
                                     (il:declare\: il:donteval@load il:doeval@compile il:dontcopy 
                                            il:compilervars (il:addvars (il:nlama)
                                                                   (il:nlaml)
                                                                   (il:lama)))))
(defun si::%structure-declare-datatype
 (name field-specifications field-descriptors word-length 
                                             supertype) "analagous to declare-datatype, but does not prepend the supers descriptors. You must include all descs."
   
                                               (il:* il:|;;;| 

                              "N.B.  descriptions and specs are for ALL slots, not just local-slots.")


                                                  (il:* il:|;;| "field-specifications is a list of the form '(pointer pointer (bits 3) (bits 5) word fixp).  See p. 8.21 IRM")


                                                  (il:* il:|;;| "field-descriptors is the list returned from translate.datatype when given the above FIELD-SPECIFICATIONS.  They are legal to pass to fetchfield.")


                                                  (il:* il:|;;| 

                                        "word-length is the car of the result of translate.datatype.")


                                                  (il:* il:|;;| 

                                                  "supertype is the typename of the supertype.")

   (check-type name symbol)
   (check-type word-length integer)
   (let ((reference-counted-pointers (mapcan #'(lambda (descriptor)
                                                      (case (caddr descriptor)
                                                            ((il:pointer il:fullpointer)
                                                             (list (cadr descriptor))))) 
                                            field-descriptors)))
        (multiple-value-bind (type-number redeclared?)
               (il:\\assigndatatype1 name field-descriptors word-length field-specifications 
                      reference-counted-pointers supertype)

                                                  (il:* il:|;;| 

                                                  "set the magic global to the allocated type number")

               (il:settopval (il:\\typeglobalvariable name t)
                      type-number)
               (values field-descriptors redeclared?))))

(defun create-structure-object
 nil 
                          "creates the empty datatype that is included by every Common Lisp instance"
                                   (si::%structure-declare-datatype %default-structure-include nil 
                                          nil 0 nil)
                                   (il:without-filepkg (deftype structure-object

                                                          nil `(il:datatype ,
                                                                      %default-structure-include))
))

(defun print-structure-instance
 (object stream depth) 
                                "looks up the print function for the structure instance and calls it"
   (funcall (or (ps-print-function (parsed-structure (type-of object)))
                %default-print-function)
          object stream depth))

(defvar *parsed-structures*
 '(nil) "all declared structures" )

(defvar *print-structure*
 nil "Flag indicating whether the contents of structures are to be printed.")

(defun set-parsed-structure
 (name ps) (let ((old (parsed-structure name t)))
                                           (if old (rplacd (il:assoc name *parsed-structures*)
                                                          ps)
                                               (setq *parsed-structures* (push (cons name ps)
                                                                               *parsed-structures*)))
                                           ))

(defmacro parsed-structure
 (name &optional (no-error nil)) 
                                                 "returns the parsed-structure corresponding to name"
   (cond
      (no-error `(cdr (il:assoc ,name *parsed-structures*)))
      (t `(or (cdr (il:assoc ,name *parsed-structures*))
              (error "~s is not a defined structure" ,name)))))

(defun structure-slot-names
 (structure-name &optional (dont-copy nil)) (let* ((ps (parsed-structure
                                                                                   structure-name))
                                                                              names)
                                                                             (if (not ps)
                                                                                 (error 
                                                                    "~S is not a declared structure." 
                                                                                       structure-name
                                                                                        ))
                                                                             (setq names (
                                                                                    ps-all-slot-names
                                                                                          ps))
                                                                             (if dont-copy names
                                                                                 (copy-list names))))

(defun default-structure-printer
 (il:structure stream il:print-depth) (declare
 (ignore il:print-depth
                                                                                      ))
                                                                      (
                                                                      il:\\defprint.defstruct.default
                                                                       il:structure stream 
                                                                       il:print-depth))

(defun il:create-structure
 (structure-form) (apply (structure-constructor (car structure-form))
                                                   (il:for
 tail il:on
 (cdr structure-form)
                                                      il:by
 (cddr tail)
                                                      il:join
 (list (make-keyword (car tail))
                                                                    (cadr tail)))))

(defun structure-constructor
 (structure-name) (or (get structure-name 'il:structure-constructor)
                                                  (let* ((ps (parsed-structure structure-name))
                                                         (constructor (ps-standard-constructor ps)))
                                                        (or constructor (error 
                                                    "~S is a structure with no standard constructor."
                                                                               (ps-name ps))))))

(defsetf parsed-structure
 set-parsed-structure)




(il:* il:|;;| "USES STRUCTURE-SLOT-NAMES but for now supports looking on the plist.")


(defun il:slot-list
 (name) (or (il:copy (get name 'il:%slot-descriptions))
                               (structure-slot-names name)))

(il:defineq

(il:\\defprint.defstruct.default

  (il:lambda (il:struc stream print-level)
                   (il:* il:|gbn| "30-Oct-86 10:59")

    (if (not *print-structure*)
        (il:\\print-using-address il:struc stream 0)
        (let ((type (il:typename il:struc))
              label
              (first-time? t))
             (when il:*print-circle-hashtable* 
   (il:* il:|;;| 

                                 "only true if *print-circle* is true and the structure is circular.")

                   (multiple-value-setq (label first-time?)
                          (il:print-circle-lookup il:struc)))
             (when label 
                         (il:* il:|;;| 

                                                  "this guy needs to be flagged for circle-printing")

                   (il:prin3 label))
             (when first-time? (il:\\outchar stream (il:|fetch|
 (readtablep il:hashmacrochar)
                                                       il:|of|
 *readtable*))
                   (il:prin3 "S(" stream)
                   (il:prin2 type stream)
                   (let ((*print-level* (and *print-level* (il:sub1 *print-level*))))
                        (declare
 (il:specvars *print-level*))
                        (il:|for|
 il:field il:|in|
 (il:slot-list type) il:|as|
 il:descriptor
                           il:|in|
 (il:getdescriptors type) il:|do|
 (il:prin1 " " stream)
                                                                  (il:prin2 il:field stream)
                                                                  (il:prin1 " " stream)
                                                                  (il:\\prindatum (il:fetchfield
                                                                                   il:descriptor 
                                                                                   il:struc)
                                                                         stream)))
                   (il:prin1 ")" stream))
             t))))
)

(il:putprops il:defstruct-run-time il:filetype
 compile-file)

(il:putprops il:defstruct-run-time il:makefile-environment
 (:readtable "XCL" :package "LISP"))
(il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars 

(il:addtovar il:nlama
 )

(il:addtovar il:nlaml
 )

(il:addtovar il:lama
 )
)
(il:putprops il:defstruct-run-time il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil (9435 11518 (il:\\defprint.defstruct.default 9448 . 11516)))))
il:stop