lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / builtin.lisp

diff --git a/src/builtin.lisp b/src/builtin.lisp
index d7d0fcb18e99a5164e13b18ae55240c1922ef059..63107419e58e6518bb3db5313e1e84243871edde 100644 (file)
--- a/src/builtin.lisp
+++ b/src/builtin.lisp
@@ -85,6 +85,9 @@ (define-class-slot "nick" (class) const-string
 (define-class-slot "initsz" (class) size-t
   (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
 
 (define-class-slot "initsz" (class) size-t
   (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
 

+(define-class-slot "align" (class) size-t
+  (format nil "SOD__ALIGNOF(struct ~A)" (ilayout-struct-tag class)))
+

 (define-class-slot "imprint" (class stream)
     (* (fun (* void) ("/*p*/" (* void))))
   (format nil "~A__imprint" class)
 (define-class-slot "imprint" (class stream)
     (* (fun (* void) ("/*p*/" (* void))))
   (format nil "~A__imprint" class)


@@ -246,6 +249,49 @@ (defun declare-me (codegen class)
                                             (sod-class-chain-head class))
                                            (sod-class-nickname class)))))
 
                                             (sod-class-chain-head class))
                                            (sod-class-nickname class)))))
 

+(defun collect-initarg-keywords (class)
+  "Return a list of keyword arguments corresponding to CLASS's initargs.
+
+   For each distinct name among the initargs defined on CLASS and its
+   superclasses, return a single `argument' object containing the (agreed
+   common) type, and the (unique, if present) default value from the most
+   specific defining superclass.
+
+   The arguments are not returned in any especially meaningful order."
+
+  (let ((map (make-hash-table :test #'equal))
+       (default-map (make-hash-table :test #'equal))
+       (list nil))
+    (dolist (super (sod-class-precedence-list class))
+      (dolist (initarg (sod-class-initargs super))
+       (let ((name (sod-initarg-name initarg))
+             (default (sod-initarg-default initarg)))
+         (unless (gethash name default-map)
+           (when (or default (not (gethash name map)))
+             (setf (gethash name map) (sod-initarg-argument initarg)))
+           (when default
+             (setf (gethash name default-map) t))))))
+    (maphash (lambda (key value)
+              (declare (ignore key))
+              (push value list))
+            map)
+    list))
+
+(definst suppliedp-struct (stream) (flags var)
+  "Declare a `suppliedp' structure VAR containing a bit for each named FLAG.
+
+   The output looks like this:
+
+       struct {
+         unsigned FLAG: 1;
+         /* ... */
+       } VAR;
+
+   Note that this will not be valid C unless there is at least one flag."
+  (format stream
+         "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
+         flags var))
+

 ;; Initialization.
 
 (defclass initialization-message (lifecycle-message)
 ;; Initialization.
 
 (defclass initialization-message (lifecycle-message)


@@ -258,13 +304,47 @@ (defmethod sod-message-effective-method-class
     ((message initialization-message))
   'initialization-effective-method)
 
     ((message initialization-message))
   'initialization-effective-method)
 

+(defmethod sod-message-keyword-argument-lists
+    ((message initialization-message) (class sod-class) direct-methods state)
+  (append (call-next-method)
+         (mapcan (lambda (class)
+                   (let* ((initargs (sod-class-initargs class))
+                          (map (make-hash-table))
+                          (arglist (mapcar
+                                    (lambda (initarg)
+                                      (let ((arg (sod-initarg-argument
+                                                  initarg)))
+                                        (setf (gethash arg map) initarg)
+                                        arg))
+                                    initargs)))
+                     (and initargs
+                          (list (cons (lambda (arg)
+                                        (info-with-location
+                                         (gethash arg map)
+                                         "Type `~A' from initarg ~
+                                          in class `~A' (here)"
+                                         (argument-type arg) class)
+                                        (report-inheritance-path
+                                         state class))
+                                      arglist)))))
+                 (sod-class-precedence-list class))))
+

 (defmethod lifecycle-method-kernel
     ((method initialization-effective-method) codegen target)
   (let* ((class (effective-method-class method))
 (defmethod lifecycle-method-kernel
     ((method initialization-effective-method) codegen target)
   (let* ((class (effective-method-class method))

+        (keywords (collect-initarg-keywords class))

         (ilayout (sod-class-ilayout class))
         (obj-tag (ilayout-struct-tag class))
         (ilayout (sod-class-ilayout class))
         (obj-tag (ilayout-struct-tag class))

-        (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
-        (func-name (format nil "~A__init" class)))
+        (kw-tag (effective-method-keyword-struct-tag method))
+        (kw-tail (and keywords
+                      (list (make-argument
+                             "sod__kw"
+                             (c-type (* (struct kw-tag :const)))))))
+        (func-type (c-type (fun void
+                                ("sod__obj" (* (struct obj-tag)))
+                                . kw-tail)))
+        (func-name (format nil "~A__init" class))
+        (done-setup-p nil))

 
     ;; Start building the initialization function.
     (codegen-push codegen)
 
     ;; Start building the initialization function.
     (codegen-push codegen)


@@ -278,7 +358,46 @@ (defmethod lifecycle-method-kernel
               (codegen-push codegen)
               (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
               (deliver-expr codegen var *sod-tmp-val*)
               (codegen-push codegen)
               (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
               (deliver-expr codegen var *sod-tmp-val*)

-              (codegen-pop-block codegen)))
+              (codegen-pop-block codegen))
+            (setup ()
+              ;; Do any necessary one-time initialization required to set up
+              ;; the environment for the initialization code.
+              (unless done-setup-p
+
+                ;; Extract the keyword arguments into local variables.
+                (when keywords
+                  (emit-decl codegen
+                             (make-suppliedp-struct-inst
+                              (mapcar #'argument-name keywords)
+                              "suppliedp"))
+                  (emit-banner codegen "Collect the keyword arguments.")
+                  (dolist (arg keywords)
+                    (let* ((name (argument-name arg))
+                           (type (argument-type arg))
+                           (default (argument-default arg))
+                           (kwvar (format nil "sod__kw->~A" name))
+                           (kwset (make-set-inst name kwvar))
+                           (suppliedp (format nil "suppliedp.~A" name)))
+                      (emit-decl codegen (make-var-inst name type))
+                      (deliver-expr codegen suppliedp
+                                    (format nil "sod__kw->~A__suppliedp"
+                                            name))
+                      (emit-inst
+                       codegen
+                       (if default
+                           (make-if-inst suppliedp kwset
+                                         (set-from-initializer name
+                                                               type
+                                                               default))
+                           kwset))))
+
+                  (deliver-call codegen :void
+                                "SOD__IGNORE" "suppliedp")
+                  (dolist (arg keywords)
+                    (deliver-call codegen :void
+                                  "SOD__IGNORE" (argument-name arg))))
+
+                (setf done-setup-p t))))

 
       ;; Initialize the structure defined by the various superclasses, in
       ;; reverse precedence order.
 
       ;; Initialize the structure defined by the various superclasses, in
       ;; reverse precedence order.


@@ -297,6 +416,7 @@ (defmethod lifecycle-method-kernel
          (flet ((focus-this-class ()
                   ;; Delayed initial preparation.  Don't bother defining the
                   ;; `me' pointer if there's actually nothing to do.
          (flet ((focus-this-class ()
                   ;; Delayed initial preparation.  Don't bother defining the
                   ;; `me' pointer if there's actually nothing to do.

+                  (setup)

                   (unless this-class-focussed-p
                     (emit-banner codegen
                                  "Initialization for class `~A'." super)
                   (unless this-class-focussed-p
                     (emit-banner codegen
                                  "Initialization for class `~A'." super)


@@ -307,16 +427,31 @@ (defmethod lifecycle-method-kernel
            ;; Work through each slot in turn.
            (dolist (slot (and islots (islots-slots islots)))
              (let ((dslot (effective-slot-direct-slot slot))
            ;; Work through each slot in turn.
            (dolist (slot (and islots (islots-slots islots)))
              (let ((dslot (effective-slot-direct-slot slot))

-                   (init (effective-slot-initializer slot)))
-               (when init
+                   (init (effective-slot-initializer slot))
+                   (initargs (effective-slot-initargs slot)))
+               (when (or init initargs)

                  (focus-this-class)
                  (let* ((slot-type (sod-slot-type dslot))
                  (focus-this-class)
                  (let* ((slot-type (sod-slot-type dslot))

-                        (slot-default (sod-initializer-value init))

                         (target (format nil "~A.~A"
                                         isl (sod-slot-name dslot)))
                         (target (format nil "~A.~A"
                                         isl (sod-slot-name dslot)))

-                        (initinst (set-from-initializer target
-                                                        slot-type
-                                                        slot-default)))
+                        (initinst (and init
+                                       (set-from-initializer
+                                        target slot-type
+                                        (sod-initializer-value init)))))
+
+                   ;; If there are applicable initialization arguments,
+                   ;; check to see whether they were supplied.
+                   (dolist (initarg (reverse (remove-duplicates
+                                              initargs
+                                              :key #'sod-initarg-name
+                                              :test #'string=
+                                              :from-end t)))
+                     (let ((arg-name (sod-initarg-name initarg)))
+                       (setf initinst (make-if-inst
+                                       (format nil "suppliedp.~A" arg-name)
+                                       (make-set-inst target arg-name)
+                                       initinst))))
+

                    (emit-inst codegen initinst)))))
 
            ;; Emit the class's initialization fragments.
                    (emit-inst codegen initinst)))))
 
            ;; Emit the class's initialization fragments.


@@ -341,7 +476,8 @@ (defmethod lifecycle-method-kernel
                           for class `~A'."
                          class)
 
                           for class `~A'."
                          class)
 

-    (deliver-call codegen :void func-name "sod__obj")))
+    (apply #'deliver-call codegen :void func-name
+          "sod__obj" (and keywords (list (keyword-struct-pointer))))))

 
 ;; Teardown.
 
 
 ;; Teardown.
 


@@ -391,9 +527,11 @@ (defun bootstrap-classes (module)
    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
    an instance of itself)."
   (let* ((sod-object (make-sod-class "SodObject" nil
    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
    an instance of itself)."
   (let* ((sod-object (make-sod-class "SodObject" nil

-                                    (make-property-set :nick 'obj)))
+                                    (make-property-set :nick 'obj
+                                                       :%bootstrapping t)))

         (sod-class (make-sod-class "SodClass" (list sod-object)
         (sod-class (make-sod-class "SodClass" (list sod-object)

-                                   (make-property-set :nick 'cls)))
+                                   (make-property-set :nick 'cls
+                                                      :%bootstrapping t)))

         (classes (list sod-object sod-class)))
 
     ;; Attach the built-in messages.
         (classes (list sod-object sod-class)))
 
     ;; Attach the built-in messages.


@@ -426,11 +564,12 @@ (defun bootstrap-classes (module)
 
     ;; Done.
     (dolist (class classes)
 
     ;; Done.
     (dolist (class classes)

-      (finalize-sod-class class)
+      (unless (finalize-sod-class class)
+       (error "Failed to finalize built-in class"))

       (add-to-module module class))))
 
 (export '*builtin-module*)
       (add-to-module module class))))
 
 (export '*builtin-module*)

-(defvar *builtin-module* nil
+(defvar-unbound *builtin-module*

   "The builtin module.")
 
 (export 'make-builtin-module)
   "The builtin module.")
 
 (export 'make-builtin-module)


@@ -449,8 +588,6 @@ (defun make-builtin-module ()
                                                    :case :common)
                               :state nil)))
     (with-module-environment (module)
                                                    :case :common)
                               :state nil)))
     (with-module-environment (module)

-      (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
-       (add-to-module module (make-instance 'type-item :name name)))

       (flet ((header-name (name)
               (concatenate 'string "\"" (string-downcase name) ".h\""))
             (add-includes (reason &rest names)
       (flet ((header-name (name)
               (concatenate 'string "\"" (string-downcase name) ".h\""))
             (add-includes (reason &rest names)


@@ -469,6 +606,6 @@ (defun make-builtin-module ()
     (setf *builtin-module* module)))
 
 (define-clear-the-decks builtin-module
     (setf *builtin-module* module)))
 
 (define-clear-the-decks builtin-module

-  (unless *builtin-module* (make-builtin-module)))
+  (unless (boundp '*builtin-module*) (make-builtin-module)))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------