diff --git a/compiler.rkt b/compiler.rkt index 8d1970a..18fab20 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -12,12 +12,25 @@ (provide (rename-out [-compile compile]) compile-general-procedure-call + current-warn-unimplemented-kernel-primitive append-instruction-sequences) +(: default-warn-unimplemented-kernel-primitive (Symbol -> Void)) +(define (default-warn-unimplemented-kernel-primitive id) + (printf "WARNING: Primitive Kernel Value ~s has not been implemented\n" + id)) + + +(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void))) +(define current-warn-unimplemented-kernel-primitive (make-parameter default-warn-unimplemented-kernel-primitive)) + + + + (: -compile (Expression Target Linkage -> (Listof Statement))) ;; Generates the instruction-sequence stream. ;; Note: the toplevel generates the lambda body streams at the head, and then the @@ -2016,8 +2029,7 @@ (define (compile-primitive-kernel-value exp cenv target linkage) (let ([id (PrimitiveKernelValue-id exp)]) (cond - [(KernelPrimitiveName? id) - + [(KernelPrimitiveName? id) (let ([singular-context-check (emit-singular-context linkage)]) ;; Compiles constant values. (end-with-linkage linkage @@ -2027,9 +2039,10 @@ `(,(make-AssignImmediateStatement target exp) singular-context-check)))))] [else - (error 'unimplemented-kernel-primitive - "Primitive Kernel Value ~s has not been implemented" - id)]))) + ((current-warn-unimplemented-kernel-primitive) id) + (make-instruction-sequence + `(,(make-PerformStatement (make-RaiseUnimplementedPrimitiveError! id))))]))) + diff --git a/il-structs.rkt b/il-structs.rkt index bb8305c..7279a85 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -388,6 +388,11 @@ #:transparent) +;; Raise a runtime error if we hit a use of an unimplemented kernel primitive. +(define-struct: RaiseUnimplementedPrimitiveError! ([name : Symbol]) + #:transparent) + + ;; Changes over the control located at the given argument from the structure in env[1] @@ -426,6 +431,7 @@ RaiseContextExpectedValuesError! RaiseArityMismatchError! RaiseOperatorApplicationError! + RaiseUnimplementedPrimitiveError! RestoreEnvironment! RestoreControl! diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index b707de9..aadb184 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -124,6 +124,12 @@ [(RaiseOperatorApplicationError!? op) (format "RUNTIME.raiseOperatorApplicationError(MACHINE, ~a);" (assemble-oparg (RaiseOperatorApplicationError!-operator op)))] + + + [(RaiseUnimplementedPrimitiveError!? op) + (format "RUNTIME.raiseUnimplementedPrimitiveError(MACHINE, ~s);" + (symbol->string (RaiseUnimplementedPrimitiveError!-name op)))] + [(InstallModuleEntry!? op) (format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s, ~a);" diff --git a/js-assembler/mini-runtime.js b/js-assembler/mini-runtime.js index c36a68e..cac6885 100644 --- a/js-assembler/mini-runtime.js +++ b/js-assembler/mini-runtime.js @@ -303,6 +303,27 @@ MACHINE.argcount + " values")); }; + var raiseArityMismatchError = function(MACHINE, expected, received) { + raise(MACHINE, + new Error("expected " + expected + + " values, received " + + received + " values")); + }; + + var raiseOperatorApplicationError = function(MACHINE, operator) { + raise(MACHINE, + new Error("not a procedure: " + expected + + operator)); + }; + + var raiseUnimplementedPrimitiveError = function(MACHINE, name) { + raise(MACHINE, + new Error("unimplemented kernel procedure: " + name)) + }; + + + + // captureControl implements the continuation-capturing part of // call/cc. It grabs the control frames up to (but not including) the @@ -1199,6 +1220,9 @@ exports['testArity'] = testArity; exports['raise'] = raise; exports['raiseContextExpectedValuesError'] = raiseContextExpectedValuesError; + exports['raiseArityMismatchError'] = raiseArityMismatchError; + exports['raiseOperatorApplicationError'] = raiseOperatorApplicationError; + exports['raiseUnimplementedPrimitiveError'] = raiseUnimplementedPrimitiveError; exports['captureControl'] = captureControl; diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt index 57afb36..c2aecb0 100644 --- a/kernel-primitives.rkt +++ b/kernel-primitives.rkt @@ -30,6 +30,7 @@ 'cadr 'caddr 'list + 'list* 'list->vector 'vector->list 'vector @@ -64,6 +65,16 @@ 'map 'for-each 'current-print + + + ;; These are necessary to get racket/base compiled + ;; and running + 'raise-type-error + 'hash-map + 'abort-current-continuation + 'raise + 'list? + 'keyword