Implement weak-pair procedures as primitives and open-code them.

Also put the primitives in "boot" so they are available early.

diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm
index 087e4b1e4f2a743f8c1d58f1a55b923e2b0ff7e8..62d005ac2fc0176b4520af094f429b04733457db 100644 (file)
--- a/src/compiler/base/utils.scm
+++ b/src/compiler/base/utils.scm
@@ -318,6 +318,7 @@ USA.
        (ucode-primitive positive?)
        (ucode-primitive string?)
        (ucode-primitive vector?)
+       (ucode-primitive weak-pair? 1)
        (ucode-primitive zero-fixnum?)
        (ucode-primitive zero?)))
 
@@ -333,7 +334,8 @@ USA.
        (ucode-primitive string-allocate)
        (ucode-primitive system-pair-cons)
        (ucode-primitive vector)
-       (ucode-primitive vector-cons)))
+       (ucode-primitive vector-cons)
+       (ucode-primitive weak-cons 2)))
 \f
 (define additional-function-primitives
   (list (ucode-primitive %record-length)
@@ -414,7 +416,9 @@ USA.
        (ucode-primitive system-vector-size)
        (ucode-primitive vector-8b-ref)
        (ucode-primitive vector-length)
-       (ucode-primitive vector-ref)))
+       (ucode-primitive vector-ref)
+       (ucode-primitive weak-car 1)
+       (ucode-primitive weak-cdr 1)))
 \f
 ;;;; "Foldable" and side-effect-free operators
 

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index e31d69a8858b4dbc74f5b2ee661ac7ed6aaf8bc3..8da250000573e9ca426911d2e8120aa69b8fb826 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -691,7 +691,8 @@ USA.
     (simple-type-test 'flonum?         (ucode-type flonum))
     (simple-type-test 'pair?           (ucode-type pair))
     (simple-type-test 'string?         (ucode-type string))
-    (simple-type-test 'vector?         (ucode-type vector))))
+    (simple-type-test 'vector?         (ucode-type vector))
+    (simple-type-test 'weak-pair?      (ucode-type weak-cons))))
 
 (define-open-coder/predicate 'EQ?
   (simple-open-coder
@@ -912,6 +913,11 @@ USA.
   (define-open-coder/value 'CONS
     (simple-open-coder (open-code/pair-cons (ucode-type pair)) '(0 1) false))
 
+  (define-open-coder/value 'weak-cons
+    (simple-open-coder (open-code/pair-cons (ucode-type weak-cons))
+                      '(0 1)
+                      false))
+
   (define-open-coder/value 'SYSTEM-PAIR-CONS
     (filter/type-code open-code/pair-cons 0 '(1 2) false))
 
@@ -1039,6 +1045,8 @@ USA.
            0)
   (user-ref 'CAR rtl:make-fetch (ucode-type pair) 0)
   (user-ref 'CDR rtl:make-fetch (ucode-type pair) 1)
+  (user-ref 'weak-car rtl:make-fetch (ucode-type weak-cons) 0)
+  (user-ref 'weak-cdr rtl:make-fetch (ucode-type weak-cons) 1)
   (user-ref '%tagged-object-tag rtl:make-fetch (ucode-type tagged-object) 0)
   (user-ref '%tagged-object-datum rtl:make-fetch (ucode-type tagged-object) 1))
 
@@ -1095,7 +1103,9 @@ USA.
            '(0 1)
            internal-close-coding-for-type-checks)))))
   (fixed-assignment 'SET-CAR! (ucode-type pair) 0)
-  (fixed-assignment 'SET-CDR! (ucode-type pair) 1))
+  (fixed-assignment 'SET-CDR! (ucode-type pair) 1)
+  (fixed-assignment 'weak-set-car! (ucode-type weak-cons) 0)
+  (fixed-assignment 'weak-set-cdr! (ucode-type weak-cons) 1))
 
 (let ((make-assignment
        (lambda (name type)

diff --git a/src/microcode/list.c b/src/microcode/list.c
index f207425b6696f77dc8cad8a26ce826abe7fb865b..99424b1b47c4a588d08eadb99d63c5cea102fc05 100644 (file)
--- a/src/microcode/list.c
+++ b/src/microcode/list.c
@@ -240,13 +240,13 @@ DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0)
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
 \f
-DEFINE_PRIMITIVE ("%TAGGED-OBJECT?", Prim_tagged_object_p, 1, 1, 0)
+DEFINE_PRIMITIVE ("%tagged-object?", Prim_tagged_object_p, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (TAGGED_OBJECT_P (ARG_REF (1))));
 }
 
-DEFINE_PRIMITIVE ("%MAKE-TAGGED-OBJECT", Prim_make_tagged_object, 2, 2, 0)
+DEFINE_PRIMITIVE ("%make-tagged-object", Prim_make_tagged_object, 2, 2, 0)
 {
   PRIMITIVE_HEADER (2);
   Primitive_GC_If_Needed (2);
@@ -256,16 +256,62 @@ DEFINE_PRIMITIVE ("%MAKE-TAGGED-OBJECT", Prim_make_tagged_object, 2, 2, 0)
   PRIMITIVE_RETURN (result);
 }
 
-DEFINE_PRIMITIVE ("%TAGGED-OBJECT-TAG", Prim_tagged_object_tag, 1, 1, 0)
+DEFINE_PRIMITIVE ("%tagged-object-tag", Prim_tagged_object_tag, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   CHECK_ARG (1, TAGGED_OBJECT_P);
   PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 0));
 }
 
-DEFINE_PRIMITIVE ("%TAGGED-OBJECT-DATUM", Prim_tagged_object_datum, 1, 1, 0)
+DEFINE_PRIMITIVE ("%tagged-object-datum", Prim_tagged_object_datum, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
   CHECK_ARG (1, TAGGED_OBJECT_P);
   PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 1));
 }
+
+DEFINE_PRIMITIVE ("weak-pair?", Prim_weak_pair_p, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (WEAK_PAIR_P (ARG_REF (1))));
+}
+
+DEFINE_PRIMITIVE ("weak-cons", Prim_weak_cons, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  Primitive_GC_If_Needed (2);
+  SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_WEAK_CONS, Free));
+  (*Free++) = (ARG_REF (1));
+  (*Free++) = (ARG_REF (2));
+  PRIMITIVE_RETURN (result);
+}
+
+DEFINE_PRIMITIVE ("weak-car", Prim_weak_car, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, WEAK_PAIR_P);
+  PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 0));
+}
+
+DEFINE_PRIMITIVE ("weak-cdr", Prim_weak_cdr, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  CHECK_ARG (1, WEAK_PAIR_P);
+  PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), 1));
+}
+
+DEFINE_PRIMITIVE ("weak-set-car!", Prim_weak_set_car, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  CHECK_ARG (1, WEAK_PAIR_P);
+  MEMORY_SET ((ARG_REF (1)), 0, (ARG_REF (2)));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("weak-set-cdr!", Prim_weak_set_cdr, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  CHECK_ARG (1, WEAK_PAIR_P);
+  MEMORY_SET ((ARG_REF (1)), 1, (ARG_REF (2)));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}

diff --git a/src/microcode/object.h b/src/microcode/object.h
index 197d3da622dc6581a7b412f01de3952cd3665777..063830c4d2ccf4b31e3600dd6dd76f5808eba8fe 100644 (file)
--- a/src/microcode/object.h
+++ b/src/microcode/object.h
@@ -499,6 +499,7 @@ extern bool string_p (SCHEME_OBJECT);
    7 #!default
    8 #!aux
    9 '()
+   10 weak #f
  */
 
 #define SHARP_F                        MAKE_OBJECT (TC_FALSE, 0)

diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm
index 22737930647715e07ab3e1aac45e474a47f4370f..783d9e3bae79a7c3489602dc634f0aefe5fe91e3 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -40,7 +40,14 @@ USA.
   (%record? 1)
   (%tagged-object-datum 1)
   (%tagged-object-tag 1)
-  (%tagged-object? 1))
+  (%tagged-object? 1)
+  (%weak-cons weak-cons 2)
+  (%weak-car weak-car 1)
+  (%weak-set-car! weak-set-car! 2)
+  (weak-cdr 1)
+  (weak-pair? 1)
+  (weak-pair/car? weak-car 1)
+  (weak-set-cdr! 2))
 
 (define (%make-record tag length #!optional fill)
   (let ((fill (if (default-object? fill) #f fill)))
@@ -68,6 +75,34 @@ USA.
                      (%record-set! record 0 tag)
                      record)))))))
       (expand-cases 16))))
+
+(define (weak-cons car cdr)
+  (%weak-cons (%false->weak-false car) cdr))
+
+(define (weak-car weak-pair)
+  (%weak-false->false (%weak-car weak-pair)))
+
+(define (weak-set-car! weak-pair object)
+  (%weak-set-car! weak-pair (%false->weak-false object)))
+
+(define-integrable (%false->weak-false object)
+  (if object object %weak-false))
+
+(declare (integrate-operator %weak-false->false))
+(define (%weak-false->false object)
+  (if (%weak-false? object) #f object))
+
+(define-integrable (%weak-false? object)
+  (eq? object %weak-false))
+
+(define-integrable %weak-false
+  (let-syntax
+      ((ugh
+       (sc-macro-transformer
+        (lambda (form use-env)
+          (declare (ignore form use-env))
+          (object-new-type (ucode-type constant) 10)))))
+    (ugh)))
 \f
 ;;;; Interrupt control
 

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index d9c4a8ea305832ce69f3a85836b0b228cb9549af..7d7f02df7c2d4c26e62b81dbef8c05823f6298b8 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -377,43 +377,19 @@ USA.
 (define (car+cdr pair)
   (values (car pair) (cdr pair)))
 \f
-;;;; Weak Pairs
-
-(define-integrable (weak-cons car cdr)
-  (system-pair-cons (ucode-type weak-cons) (or car weak-pair/false) cdr))
-
-(define-integrable (weak-pair? object)
-  (object-type? (ucode-type weak-cons) object))
-
-(define-integrable (weak-pair/car? weak-pair)
-  (system-pair-car weak-pair))
-
-(define (weak-car weak-pair)
-  (let ((car (system-pair-car weak-pair)))
-    (and (not (eq? car weak-pair/false))
-        car)))
-
-(define-integrable (weak-set-car! weak-pair object)
-  (system-pair-set-car! weak-pair (or object weak-pair/false)))
-
-(define-integrable (weak-cdr weak-pair)
-  (system-pair-cdr weak-pair))
-
-(define-integrable (weak-set-cdr! weak-pair object)
-  (system-pair-set-cdr! weak-pair object))
+;;;; Weak lists
 
 (define (weak-list->list items)
   (let loop ((items* items) (result '()))
     (if (weak-pair? items*)
-       (loop (system-pair-cdr items*)
-             (let ((item (system-pair-car items*)))
-               (if (not item)
-                   result
-                   (cons (if (eq? item weak-pair/false) #f item)
-                         result))))
+       (loop (weak-cdr items*)
+             (let ((item (%weak-car items*)))
+               (if item
+                   (cons (%weak-false->false item) result)
+                   result)))
        (begin
          (if (not (null? items*))
-             (error:not-a weak-list? items 'WEAK-LIST->LIST))
+             (error:not-a weak-list? items 'weak-list->list))
          (reverse! result)))))
 
 (define (list->weak-list items)
@@ -423,12 +399,9 @@ USA.
              (weak-cons (car items*) result))
        (begin
          (if (not (null? items*))
-             (error:not-a list? items 'LIST->WEAK-LIST))
+             (error:not-a list? items 'list->weak-list))
          result))))
 
-(define weak-pair/false
-  "weak-pair/false")
-
 (define (weak-list? object)
   (let loop ((l1 object) (l2 object))
     (if (weak-pair? l1)
@@ -438,45 +411,44 @@ USA.
                   (loop (weak-cdr l1) (weak-cdr l2))
                   (null? l1))))
        (null? l1))))
-\f
-(define (weak-memq object items)
-  (let ((object (or object weak-pair/false)))
+
+(define (weak-memq item items)
+  (let ((item (%false->weak-false item)))
     (let loop ((items* items))
       (if (weak-pair? items*)
-         (if (eq? object (system-pair-car items*))
+         (if (eq? item (%weak-car items*))
              items*
-             (loop (system-pair-cdr items*)))
+             (loop (weak-cdr items*)))
          (begin
            (if (not (null? items*))
-               (error:not-a weak-list? items 'WEAK-MEMQ))
+               (error:not-a weak-list? items 'weak-memq))
            #f)))))
 
 (define (weak-delq! item items)
-  (letrec ((trim-initial-segment
-           (lambda (items*)
-             (if (weak-pair? items*)
-                 (if (or (eq? item (system-pair-car items*))
-                         (eq? #f (system-pair-car items*)))
-                     (trim-initial-segment (system-pair-cdr items*))
-                     (begin
-                       (locate-initial-segment items*
-                                               (system-pair-cdr items*))
-                       items*))
-                 (begin
-                   (if (not (null? items*))
-                       (error:not-a weak-list? items 'WEAK-DELQ!))
-                   '()))))
-          (locate-initial-segment
-           (lambda (last this)
-             (if (weak-pair? this)
-                 (if (or (eq? item (system-pair-car this))
-                         (eq? #f (system-pair-car this)))
-                     (set-cdr! last
-                               (trim-initial-segment (system-pair-cdr this)))
-                     (locate-initial-segment this (system-pair-cdr this)))
-                 (if (not (null? this))
-                     (error:not-a weak-list? items 'WEAK-DELQ!))))))
-    (trim-initial-segment items)))
+  (let ((item (%false->weak-false item)))
+    (letrec ((trim-initial-segment
+             (lambda (items*)
+               (if (weak-pair? items*)
+                   (if (or (eq? item (%weak-car items*))
+                           (eq? #f (%weak-car items*)))
+                       (trim-initial-segment (weak-cdr items*))
+                       (begin
+                         (locate-initial-segment items* (weak-cdr items*))
+                         items*))
+                   (begin
+                     (if (not (null? items*))
+                         (error:not-a weak-list? items 'weak-delq!))
+                     '()))))
+            (locate-initial-segment
+             (lambda (last this)
+               (if (weak-pair? this)
+                   (if (or (eq? item (%weak-car this))
+                           (eq? #f (%weak-car this)))
+                       (set-cdr! last (trim-initial-segment (weak-cdr this)))
+                       (locate-initial-segment this (weak-cdr this)))
+                   (if (not (null? this))
+                       (error:not-a weak-list? items 'weak-delq!))))))
+      (trim-initial-segment items))))
 \f
 ;;;; General CAR CDR
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 767d115a8aa27b471304d632d4a1bfe3289e96c5..181d77039367b04862e63ef2b5f47938d37ab427 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -135,6 +135,7 @@ USA.
   (files "boot")
   (parent (runtime))
   (export ()
+         %false->weak-false
          %make-record
          %make-tagged-object
          %record
@@ -145,6 +146,11 @@ USA.
          %tagged-object-datum
          %tagged-object-tag
          %tagged-object?
+         %weak-car
+         %weak-cons
+         %weak-false->false
+         %weak-false?
+         %weak-set-car!
          bracketed-unparser-method
          bytes-per-object
          default-object
@@ -174,6 +180,13 @@ USA.
          simple-unparser-method
          standard-unparser-method
          unparser-method?
+         weak-car
+         weak-cdr
+         weak-cons
+         weak-pair/car?
+         weak-pair?
+         weak-set-car!
+         weak-set-cdr!
          with-absolutely-no-interrupts
          with-limited-interrupts
          without-interrupts)
@@ -3020,17 +3033,10 @@ USA.
          third
          tree-copy
          unique-keyword-list?
-         weak-car
-         weak-cdr
-         weak-cons
          weak-delq!
          weak-list->list
          weak-list?
          weak-memq
-         weak-pair/car?
-         weak-pair?
-         weak-set-car!
-         weak-set-cdr!
          xcons))
 
 (define-package (runtime lambda-list)

diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index e1cd2ed3df69c65204d94117ac4bf6d42a70b9ee..7d43deb2459cb1627a935663986f5466689cea8a 100644 (file)
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -41,15 +41,18 @@ USA.
     UNSPECIFIC))
 
 (define global-primitives
-  '((%MAKE-TAGGED-OBJECT %MAKE-TAGGED-OBJECT 2)
+  '((%make-tagged-object %make-tagged-object 2)
     (%RECORD %RECORD)
     (%RECORD-LENGTH %RECORD-LENGTH)
     (%RECORD-REF %RECORD-REF)
     (%RECORD-SET! %RECORD-SET!)
     (%RECORD? %RECORD?)
-    (%TAGGED-OBJECT-DATUM %TAGGED-OBJECT-DATUM 1)
-    (%TAGGED-OBJECT-TAG %TAGGED-OBJECT-TAG 1)
-    (%TAGGED-OBJECT? %TAGGED-OBJECT? 1)
+    (%tagged-object-datum %tagged-object-datum 1)
+    (%tagged-object-tag %tagged-object-tag 1)
+    (%tagged-object? %tagged-object? 1)
+    (%weak-cons weak-cons 2)
+    (%weak-car weak-car 1)
+    (%weak-set-car! weak-set-car! 2)
     (BIT-STRING->UNSIGNED-INTEGER BIT-STRING->UNSIGNED-INTEGER)
     (BIT-STRING-ALLOCATE BIT-STRING-ALLOCATE)
     (BIT-STRING-AND! BIT-STRING-AND!)
@@ -215,6 +218,10 @@ USA.
     (VECTOR-REF VECTOR-REF)
     (VECTOR-SET! VECTOR-SET!)
     (VECTOR? VECTOR?)
+    (weak-cdr weak-cdr 1)
+    (weak-pair? weak-pair? 1)
+    (weak-pair/car? weak-car 1)
+    (weak-set-cdr! weak-set-cdr! 2)
     (WITH-HISTORY-DISABLED WITH-HISTORY-DISABLED)
     (WITH-INTERRUPT-MASK WITH-INTERRUPT-MASK)
     (WRITE-BITS! WRITE-BITS!)))
\ No newline at end of file