adding structure type properties

cs019/teachhelp.rkt

@@ -0,0 +1,82 @@
+(module teachhelp mzscheme
+  (require "firstorder.rkt"
+           "rewrite-error-message.rkt"
+           stepper/private/shared)
+
+  (require-for-syntax stepper/private/shared)
+
+  (provide make-undefined-check
+           make-first-order-function)
+
+  (define (make-undefined-check check-proc tmp-id)
+    (let ([set!-stx (datum->syntax-object check-proc 'set!)])
+      (make-set!-transformer
+       (lambda (stx)
+	 (syntax-case stx ()
+	   [(set! id expr)
+	    (module-identifier=? (syntax set!) set!-stx)
+	    (with-syntax ([tmp-id tmp-id])
+	      (syntax/loc stx (set! tmp-id expr)))]
+	   [(id . args)
+	    (datum->syntax-object
+	     check-proc
+	     (cons (stepper-syntax-property
+		    (datum->syntax-object
+		     check-proc
+		     (list check-proc 
+			   (list 'quote (syntax id))
+			   tmp-id))
+		    'stepper-skipto
+                    (append skipto/cdr
+                            skipto/third))
+		   (syntax args))
+	     stx)]
+	   [id
+            (stepper-syntax-property
+             (datum->syntax-object
+              check-proc
+              (list check-proc 
+                    (list 'quote (syntax id))
+                    tmp-id)
+              stx)
+             'stepper-skipto
+             (append skipto/cdr
+                     skipto/third))])))))
+#;    
+  (define (appropriate-use what)
+    (case what
+     [(constructor)
+      "called with values for the structure fields"]
+     [(selector) 
+      "applied to a structure to get the field value"]
+     [(predicate procedure)
+      "applied to arguments"]))
+
+  (define (make-first-order-function what arity orig-id app)
+    (make-set!-transformer
+     (make-first-order
+      (lambda (stx)
+	(syntax-case stx (set!)
+	  [(set! . _) (raise-syntax-error 
+		       #f stx #f 
+		       "internal error: assignment to first-order function")]
+	  [id
+	   (identifier? #'id)
+	   (raise-syntax-error
+	    #f
+	    (format "expected a function call, but there is no open parenthesis before this function")
+	    stx
+	    #f)]
+	  [(id . rest)
+	   (let ([found (length (syntax->list #'rest))])
+	     (unless (= found arity)
+	       (raise-syntax-error
+		#f
+                (argcount-error-message arity found)
+		stx
+		#f))
+	     (datum->syntax-object
+	      app
+	      (list* app (datum->syntax-object orig-id (syntax-e orig-id) #'id #'id) #'rest)
+	      stx stx))]))
+      (syntax-local-introduce orig-id)))))

js-assembler/runtime-src/baselib-primitives.js

@@ -2196,18 +2196,17 @@
                           guard,      // FIXME: currently ignored
                           constructorName
                          ) {
-
                     var structType = baselib.structs.makeStructureType(
                         name,
                         superType,
                         initFieldCount,
                         autoFieldCount,
                         autoV,
-                        //props,
                         //inspector,
                         //procSpec,
                         //immutables,
-                        guard);
+                        guard,
+                        props);
 
                     var constructorValue =
                         makePrimitiveProcedure(

js-assembler/runtime-src/baselib-structs.js

@@ -51,8 +51,8 @@
         }
         for (i = 0; i < this._fields.length; i++) {
             if (! baselib.equality.equals(this._fields[i],
-                         other._fields[i],
+                                          other._fields[i],
-                         aUnionFind)) {
+                                          aUnionFind)) {
                 return false;
             }
         }
@@ -74,7 +74,8 @@
                                constructor,
                                predicate, 
                                accessor,
-                               mutator) {
+                               mutator,
+                               propertiesList) {
         this.name = name;
         this.type = type;
         this.numberOfArgs = numberOfArgs;
@@ -86,6 +87,7 @@
         this.predicate = predicate;
         this.accessor = accessor;
         this.mutator = mutator;
+        this.propertiesList = propertiesList;
     };
 
 
@@ -133,7 +135,8 @@
                                       initFieldCnt, 
                                       autoFieldCnt, 
                                       autoV, 
-                                      guard) {
+                                      guard,
+                                      propertiesList) {
 
 
         // Defaults
@@ -142,7 +145,6 @@
         guard = guard || DEFAULT_GUARD;
 
 
-
         // RawConstructor creates a new struct type inheriting from
         // the parent, with no guard checks.
         var RawConstructor = function (name, args) {
@@ -202,19 +204,62 @@
             function (x, i) { return x._fields[i + this.firstField]; },
 
             // mutator
-            function (x, i, v) { x._fields[i + this.firstField] = v; });
+            function (x, i, v) { x._fields[i + this.firstField] = v; },
+
+            // structure properties list
+            propertiesList);
         return newType;
     };
 
 
 
 
+    var StructTypeProperty = function(name, guards, supers) {
+        this.name = name;
+        this.guards = guards;
+        this.supers = supers;
+    };
 
 
 
+    // supportsStructureTypeProperty: StructType StructureTypeProperty -> boolean
+    // Produces true if the structure type provides a binding for the
+    // given structure property.
+    var supportsStructureTypeProperty = function(structType, property) {
+        var propertiesList = structType.propertiesList;
+        while (propertiesList !== baselib.lists.EMPTY) {
+            if (propertiesList.first.first === property) {
+                return true;
+            }
+            propertiesList = propertiesList.rest;
+        }
+        return false;
+    };
+
+
+    // lookupStructureTypeProperty: StructType StructureTypeProperty -> any
+    // Returns the binding associated to this particular structure type propery.
+    var lookupStructureTypeProperty = function(structType, property) {
+        var propertiesList = structType.propertiesList;
+        while (propertiesList !== baselib.lists.EMPTY) {
+            if (propertiesList.first.first === property) {
+                return propertiesList.first.rest;
+            }
+            propertiesList = propertiesList.rest;
+        }
+        return undefined;
+    };
+
+
+    // A structure type property for noting if an exception supports
+    var propExnSrcloc = new StructTypeProperty("prop:exn:srcloc");
+
+
+
+    var isStruct = baselib.makeClassPredicate(Struct);
+    var isStructType = baselib.makeClassPredicate(StructType);
+    var isStructTypeProperty = baselib.makeClassPredicate(StructTypeProperty);
 
-    var isStruct = function (x) { return x instanceof Struct; };
-    var isStructType = function (x) { return x instanceof StructType; };
 
 
     //////////////////////////////////////////////////////////////////////
@@ -223,7 +268,14 @@
     exports.StructType = StructType;
     exports.Struct = Struct;
     exports.makeStructureType = makeStructureType;
+
+    exports.StructTypeProperty = StructTypeProperty;
+    exports.supportsStructureTypeProperty = supportsStructureTypeProperty;
+    exports.lookupStructureTypeProperty = lookupStructureTypeProperty;
+
+    exports.propExnSrcloc = propExnSrcloc;
+
     exports.isStruct = isStruct;
     exports.isStructType = isStructType;
-
+    exports.isStructTypeProperty = isStructTypeProperty;
 }(this.plt.baselib, $));