trying to export out an unsafe set of primitives

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

@@ -133,7 +133,15 @@
     var checkString = makeCheckArgumentType(
         plt.baselib.strings.isString,
         'string');
-    
+
+    var checkMutableString = makeCheckArgumentType(
+        plt.baselib.strings.isMutableString,
+        'mutable string');
+
+    var checkChar = makeCheckArgumentType(
+        plt.baselib.chars.isChar,
+        'character');
+
     var checkProcedure = makeCheckArgumentType(
         plt.baselib.functions.isProcedure,
         'procedure');
@@ -224,6 +232,8 @@
 
     exports.checkOutputPort = checkOutputPort;
     exports.checkString = checkString;
+    exports.checkMutableString = checkMutableString;
+    exports.checkChar = checkChar;
     exports.checkSymbol = checkSymbol;
     exports.checkProcedure = checkProcedure;
     exports.checkNumber = checkNumber;

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

@@ -17,10 +17,9 @@
     };
 
 
-
-
-
-    // Now using mutable strings
+    // chars: arrayof string
+    // Precondition: each string must only be 1 character long or bad things
+    // happen.
     var Str = function(chars) {
 	this.chars = chars;
 	this.length = chars.length;
@@ -130,43 +129,15 @@
     };
 
 
-    /*
-// Strings
-// For the moment, we just reuse Javascript strings.
-String = String;
-String.makeInstance = function(s) {
-    return s.valueOf();
-};
-    
-    
-// WARNING
-// WARNING: we are extending the built-in Javascript string class here!
-// WARNING
-String.prototype.equals = function(other, aUnionFind){
-    return this == other;
-};
-    
-var _quoteReplacingRegexp = new RegExp("[\"\\\\]", "g");
-String.prototype.toWrittenString = function(cache) {
-    return '"' + this.replace(_quoteReplacingRegexp,
-			      function(match, submatch, index) {
-				  return "\\" + match;
-			      }) + '"';
-};
 
-String.prototype.toDisplayedString = function(cache) {
-    return this;
-};
-*/
-
-
-    //////////////////////////////////////////////////////////////////////
+    var isMutableString = baselib.makeClassPredicate(Str);
 
 
 
     exports.Str = Str;
     exports.escapeString = escapeString;
     exports.isString = isString;
-
+    exports.isMutableString = isMutableString;
+    exports.makeMutableString = Str.makeInstance;
 
 })(this['plt'].baselib);

js-assembler/runtime-src/runtime.js

@@ -109,8 +109,10 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
 
     var checkOutputPort = plt.baselib.check.checkOutputPort;
     var checkString = plt.baselib.check.checkString;
+    var checkMutableString = plt.baselib.check.checkMutableString;
     var checkSymbol = plt.baselib.check.checkSymbol;
     var checkByte = plt.baselib.check.checkByte;
+    var checkChar = plt.baselib.check.checkChar;
     var checkProcedure = plt.baselib.check.checkProcedure;
     var checkNumber = plt.baselib.check.checkNumber;
     var checkReal = plt.baselib.check.checkReal;
@@ -1020,6 +1022,37 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
         });
 
 
+
+    installPrimitiveProcedure(
+        'make-string',
+        makeList(1, 2),
+        function(MACHINE) {
+	    var value = "\0";
+	    var length = plt.baselib.numbers.toFixnum(
+                checkNatural(MACHINE, 'make-string', 0));
+	    if (MACHINE.argcount == 2) {
+	        value = checkChar(MACHINE, 'make-string', 1).val;
+	    }
+	    var arr = [];
+	    for(var i = 0; i < length; i++) {
+	        arr[i] = value;
+	    }
+            return plt.baselib.strings.makeMutableString(arr);
+        });
+
+
+    installPrimitiveProcedure(
+        'string-set!',
+        3,
+        function(MACHINE) {
+            var str = checkMutableString(MACHINE, 'string-set!', 0);
+            var k = checkNatural(MACHINE, 'string-set!', 1);
+            var ch = checkChar(MACHINE, 'string-set!', 2);
+            
+        });
+
+
+
     installPrimitiveProcedure(
         'make-vector',
         makeList(1, 2),
@@ -1204,6 +1237,9 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
         });
 
 
+    // This definition of apply will take precedence over the
+    // implementation of apply in the boostrapped-primitives.rkt,
+    // since it provides nicer error handling.
     installPrimitiveClosure(
         'apply',
         plt.baselib.arity.makeArityAtLeast(2),
@@ -1229,6 +1265,14 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
         });
 
 
+    // FIXME: The definition of call-with-values is in
+    // bootstrapped-primitives.rkt.  We may want to replace it with an
+    // explicitly defined one here.
+
+
+
+
+
     installPrimitiveProcedure(
         'procedure?',
         1,
@@ -1245,6 +1289,13 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
             return plt.baselib.arity.isArityMatching(proc.arity, argcount);
         });
 
+    installPrimitiveProcedure(
+        'procedure-arity',
+        1,
+        function(MACHINE) {
+            var proc = checkProcedure(MACHINE, 'procedure-arity-includes?', 0);
+            return proc.arity;
+        });
 
 
     installPrimitiveProcedure(
@@ -1480,6 +1531,14 @@ if(this['plt'] === undefined) { this['plt'] = {}; }
         });
 
 
+    installPrimitiveProcedure(
+        'exact-nonnegative-integer?',
+        1,
+        function(MACHINE) {
+            return plt.baselib.numbers.isNatural(MACHINE.env[MACHINE.env.length - 1]);
+        });
+
+
 
     installPrimitiveProcedure(
         'imag-part',

lang/base.rkt

@@ -1,3 +1,5 @@
 #lang s-exp "kernel.rkt"
-(provide (all-from-out "kernel.rkt"))
-(require racket/private/modbeg)
+(provide (all-from-out "kernel.rkt")
+         (all-from-out "private/list.rkt"))
+(require racket/private/modbeg
+         "private/list.rkt")

lang/kernel.rkt

@@ -175,14 +175,14 @@
 ;;  struct-predicate-procedure?
 ;;  struct-accessor-procedure?
 ;;  struct-mutator-procedure?
-;;  procedure-arity
-;;  procedure-arity-includes?
+
 ;;  make-arity-at-least
 ;;  arity-at-least?
 ;;  arity-at-least-value
-apply
 
-;;  call-with-values
+ apply
+ call-with-values
+
 ;;  compose
 ;;  current-inexact-milliseconds
 ;;  current-seconds
@@ -253,6 +253,7 @@ raise-mismatch-error
   number->string
   string->number
   procedure?
+  procedure-arity
   procedure-arity-includes?
   pair?
   list?
@@ -274,6 +275,7 @@ vector?
 ;;  rational?
 integer?
 exact?
+exact-nonnegative-integer?
 ;;  inexact?
 ;;  odd?
 ;;  even?
@@ -333,7 +335,7 @@ memq
 ;;  hash-remove!
 ;;  hash-map
 ;;  hash-for-each
-;;  make-string
+  make-string
 ;;  string
   string-length
 ;;  string-ref
@@ -359,7 +361,7 @@ symbol->string
   fprintf
 ;;  build-string
 ;;  string->immutable-string
-;;  string-set!
+  string-set!
 ;;  string-fill!
 ;;  make-bytes
 ;;  bytes

lang/private/list.rkt

@@ -1,7 +1,12 @@
 #lang s-exp "../kernel.rkt"
 
-;; This is taken from collects/racket/private/list.rkt.  The hope is that, eventually,
+;; dyoo: This is taken from collects/racket/private/list.rkt.  The hope is that, eventually,
 ;; once I can support #%kernel, I won't need to do this fork to get at these...
+;;
+;; The major changes I made were: comment out sort and the compose/compose1 functions.
+;; We don't have have support for keywords, and I will need to look at the implementation of
+;; raw-sort in a moment to see if it's fine.
+
 
 (provide foldl
          foldr
@@ -29,9 +34,12 @@
          build-string
          build-list
 
-         compose
-         compose1)
+         #;compose
+         #;compose1
+         )
 
+(require (only-in "../unsafe/ops.rkt" unsafe-car unsafe-cdr))
+         
 ;;(#%require (rename "sort.rkt" raw-sort sort)
 ;;           (for-syntax "stxcase-scheme.rkt")
 ;;           (only '#%unsafe unsafe-car unsafe-cdr))
@@ -305,7 +313,7 @@
           [else (cons (fcn j)
                       (recr (add1 j) (sub1 i)))])))
 
-(define-values [compose1 compose]
+#;(define-values [compose1 compose]
   (let ()
     (define-syntax-rule (app1 E1 E2) (E1 E2))
     (define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))

lang/unsafe/js-impl.js

@@ -0,0 +1,17 @@
+
+EXPORTS['unsafe-car'] =
+    plt.baselib.functions.makePrimitiveProcedure(
+        'unsafe-car',
+        1,
+        function(MACHINE) {
+            return MACHINE.env[MACHINE.env.length - 1].first;
+        });
+
+
+EXPORTS['unsafe-cdr'] = 
+    plt.baselib.functions.makePrimitiveProcedure(
+        'unsafe-cdr',
+        1,
+        function(MACHINE) {
+            return MACHINE.env[MACHINE.env.length - 1].rest;
+        });

lang/unsafe/ops.rkt

@@ -0,0 +1,7 @@
+#lang s-exp "../js/js.rkt"
+
+(declare-implementation
+ #:racket "racket-impl.rkt"
+ #:javascript ("js-impl.js")
+ #:provided-values (unsafe-car
+                    unsafe-cdr))

lang/unsafe/racket-impl.rkt

@@ -0,0 +1,4 @@
+#lang racket
+
+(require (only-in '#%unsafe unsafe-car unsafe-cdr))
+(provide unsafe-car unsafe-cdr)