fixing compile-time error on using kernel primitives: turned into runtime errors as appropriate

compiler/analyzer-structs.rkt

@@ -1,7 +1,8 @@
 #lang typed/racket/base
 
 
-(require "expression-structs.rkt"
+(require "arity-structs.rkt"
+         "expression-structs.rkt"
          "lexical-structs.rkt"
          "kernel-primitives.rkt"
 	 "il-structs.rkt")

compiler/arity-structs.rkt

@@ -0,0 +1,12 @@
+#lang typed/racket/base
+
+(provide (all-defined-out))
+
+;; Arity
+(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
+(define-type AtomicArity (U Natural ArityAtLeast))
+(define-struct: ArityAtLeast ([value : Natural])
+  #:transparent)
+(define-predicate AtomicArity? AtomicArity)
+(define-predicate listof-atomic-arity? (Listof AtomicArity))
+

compiler/bootstrapped-primitives.rkt

@@ -1,5 +1,6 @@
 #lang typed/racket/base
-(require "expression-structs.rkt"
+(require "arity-structs.rkt"
+         "expression-structs.rkt"
          "lexical-structs.rkt"
          "il-structs.rkt"
          "compiler.rkt"

compiler/compiler.rkt

@@ -1,6 +1,7 @@
 #lang typed/racket/base
 
-(require "expression-structs.rkt"
+(require "arity-structs.rkt"
+         "expression-structs.rkt"
          "lexical-structs.rkt"
          "il-structs.rkt"
          "compiler-structs.rkt"
@@ -1028,135 +1029,166 @@
 ;;
 ;; We have to be sensitive to mutation.
 (define (compile-kernel-primitive-application kernel-op exp cenv target linkage)
-  (let ([singular-context-check (emit-singular-context linkage)])
+  (let ([singular-context-check (emit-singular-context linkage)]
+        [n (length (App-operands exp))])
+
+    (define expected-operand-types
+      (kernel-primitive-expected-operand-types kernel-op n))
+
+    (: make-runtime-arity-mismatch-code (Arity -> InstructionSequence))
+    (define (make-runtime-arity-mismatch-code expected-arity)
+      ;; We compile the code to generate a runtime arity error here.
+      (end-with-linkage
+       linkage cenv
+       (append-instruction-sequences
+        (make-PushEnvironment n #f)
+        (apply append-instruction-sequences
+               (map (lambda: ([operand : Expression]
+                              [target : Target])
+                      (compile operand
+                               (extend-compile-time-environment/scratch-space 
+                                cenv 
+                                (length (App-operands exp)))
+                               target
+                               next-linkage/expects-single))
+                    (App-operands exp)
+                    (build-list (length (App-operands exp))
+                                (lambda: ([i : Natural])
+                                  (make-EnvLexicalReference i #f)))))
+        (make-AssignImmediateStatement 'proc (make-PrimitiveKernelValue kernel-op))
+        (make-AssignImmediateStatement 'argcount
+                                       (make-Const (length (App-operands exp))))
+        (make-PerformStatement (make-RaiseArityMismatchError! 
+                                (make-Reg 'proc)
+                                expected-arity
+                                (make-Const n))))))
+
     (cond
-      ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs),
+      [(IncorrectArity? expected-operand-types)
-      ;; then application requires no stack space at all, and application is especially simple.
+       (make-runtime-arity-mismatch-code (IncorrectArity-expected expected-operand-types))]
-      [(andmap (lambda (op) 
-                 ;; TODO: as long as the operand contains no applications?
-                 (or (Constant? op)
-                     (ToplevelRef? op)
-                     (LocalRef? op)))
-               (App-operands exp))
-       (let* ([n (length (App-operands exp))]
 
-              [operand-knowledge
+      [(not (= n (length expected-operand-types)))
-               (map (lambda: ([arg : Expression])
+       (make-runtime-arity-mismatch-code (length expected-operand-types))]
-                      (extract-static-knowledge 
-                       arg 
-                       (extend-compile-time-environment/scratch-space 
-                        cenv n)))
-                    (App-operands exp))]
-              
-              [typechecks?
-               (map (lambda: ([dom : OperandDomain]
-                              [known : CompileTimeEnvironmentEntry])
-                      (not (redundant-check? dom known)))
-                    (kernel-primitive-expected-operand-types kernel-op n)
-                    operand-knowledge)]
-              
-              [expected-operand-types
-               (kernel-primitive-expected-operand-types kernel-op n)]
-              [operand-poss
-               (simple-operands->opargs (map (lambda: ([op : Expression])
-                                               (adjust-expression-depth op n n))
-                                             (App-operands exp)))])
-         (end-with-linkage
-          linkage cenv
-          (append-instruction-sequences
-           (make-AssignPrimOpStatement target
-                                       (make-CallKernelPrimitiveProcedure 
-                                        kernel-op 
-                                        operand-poss
-                                        expected-operand-types
-                                        typechecks?))
-           singular-context-check)))]
       
       [else
-       ;; Otherwise, we can split the operands into two categories: constants, and the rest.
+       (cond
-       (let*-values ([(n) 
+         ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs),
-                      (length (App-operands exp))]
+         ;; then application requires no stack space at all, and application is especially simple.
-                     
+         [(andmap (lambda (op) 
-                     [(expected-operand-types)
+                    ;; TODO: as long as the operand contains no applications?
-                      (kernel-primitive-expected-operand-types kernel-op n)]
+                    (or (Constant? op)
-                     
+                        (ToplevelRef? op)
-                     [(constant-operands rest-operands)
+                        (LocalRef? op)))
-                      (split-operands-by-constants 
+                  (App-operands exp))
+          (let* ([operand-knowledge
+                  (map (lambda: ([arg : Expression])
+                         (extract-static-knowledge 
+                          arg 
+                          (extend-compile-time-environment/scratch-space 
+                           cenv n)))
                        (App-operands exp))]
                  
-                     ;; here, we rewrite the stack references so they assume no scratch space
+                 [typechecks?
-                     ;; used by the constant operands.
+                  (map (lambda: ([dom : OperandDomain]
-                     [(extended-cenv constant-operands rest-operands)
+                                 [known : CompileTimeEnvironmentEntry])
-                      (values (extend-compile-time-environment/scratch-space 
+                         (not (redundant-check? dom known)))
-                               cenv 
+                       expected-operand-types
-                               (length rest-operands))
+                       operand-knowledge)]
 
-                              (map (lambda: ([constant-operand : Expression])
+                 [operand-poss
-                                     (ensure-simple-expression
+                  (simple-operands->opargs (map (lambda: ([op : Expression])
-                                      (adjust-expression-depth constant-operand
+                                                  (adjust-expression-depth op n n))
-                                                               (length constant-operands)
+                                                (App-operands exp)))])
-                                                               n)))
+            (end-with-linkage
-                                   constant-operands)
+             linkage cenv
+             (append-instruction-sequences
+              (make-AssignPrimOpStatement target
+                                          (make-CallKernelPrimitiveProcedure 
+                                           kernel-op 
+                                           operand-poss
+                                           expected-operand-types
+                                           typechecks?))
+              singular-context-check)))]
          
-                              (map (lambda: ([rest-operand : Expression])
+         [else
-                                     (adjust-expression-depth rest-operand
+          ;; Otherwise, we can split the operands into two categories: constants, and the rest.
-                                                              (length constant-operands)
+          (let*-values ([(constant-operands rest-operands)
-                                                              n))
+                         (split-operands-by-constants 
-                                   rest-operands))]
+                          (App-operands exp))]
                         
-                     [(operand-knowledge)
+                        ;; here, we rewrite the stack references so they assume no scratch space
-                      (append (map (lambda: ([arg : Expression])
+                        ;; used by the constant operands.
-                                     (extract-static-knowledge arg extended-cenv))
+                        [(extended-cenv constant-operands rest-operands)
-                                   constant-operands)
+                         (values (extend-compile-time-environment/scratch-space 
-                              (map (lambda: ([arg : Expression])
+                                  cenv 
-                                     (extract-static-knowledge arg extended-cenv))
+                                  (length rest-operands))
-                                   rest-operands))]
                                  
-                     [(typechecks?)
+                                 (map (lambda: ([constant-operand : Expression])
-                      (map (lambda: ([dom : OperandDomain]
+                                        (ensure-simple-expression
-                                     [known : CompileTimeEnvironmentEntry])
+                                         (adjust-expression-depth constant-operand
-                             (not (redundant-check? dom known)))
+                                                                  (length constant-operands)
-                           (kernel-primitive-expected-operand-types kernel-op n)
+                                                                  n)))
-                           operand-knowledge)]
+                                      constant-operands)
                                  
-                     [(stack-pushing-code) 
+                                 (map (lambda: ([rest-operand : Expression])
-                      (make-PushEnvironment (length rest-operands)
+                                        (adjust-expression-depth rest-operand
-                                            #f)]
+                                                                 (length constant-operands)
-                     [(stack-popping-code) 
+                                                                 n))
-                      (make-PopEnvironment (make-Const (length rest-operands))
+                                      rest-operands))]
-                                           (make-Const 0))]
                         
-                     [(constant-operand-poss)
+                        [(operand-knowledge)
-                      (simple-operands->opargs constant-operands)]
+                         (append (map (lambda: ([arg : Expression])
+                                        (extract-static-knowledge arg extended-cenv))
+                                      constant-operands)
+                                 (map (lambda: ([arg : Expression])
+                                        (extract-static-knowledge arg extended-cenv))
+                                      rest-operands))]
                         
-                     [(rest-operand-poss)
+                        [(typechecks?)
-                      (build-list (length rest-operands)
+                         (map (lambda: ([dom : OperandDomain]
-                                  (lambda: ([i : Natural])
+                                        [known : CompileTimeEnvironmentEntry])
-                                    (make-EnvLexicalReference i #f)))]
+                                (not (redundant-check? dom known)))
-                     [(rest-operand-code)
+                              expected-operand-types
-                      (apply append-instruction-sequences
+                              operand-knowledge)]
-                             (map (lambda: ([operand : Expression]
-                                            [target : Target])
-                                    (compile operand 
-                                             extended-cenv 
-                                             target 
-                                             next-linkage/expects-single))
-                                  rest-operands
-                                  rest-operand-poss))])
                         
-         (end-with-linkage
+                        [(stack-pushing-code) 
-          linkage cenv
+                         (make-PushEnvironment (length rest-operands)
-          (append-instruction-sequences
+                                               #f)]
-           stack-pushing-code
+                        [(stack-popping-code) 
-           rest-operand-code
+                         (make-PopEnvironment (make-Const (length rest-operands))
-           (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands))
+                                              (make-Const 0))]
-                                       (make-CallKernelPrimitiveProcedure 
+                        
-                                        kernel-op 
+                        [(constant-operand-poss)
-                                        (append constant-operand-poss rest-operand-poss)
+                         (simple-operands->opargs constant-operands)]
-                                        expected-operand-types
+                        
-                                        typechecks?))
+                        [(rest-operand-poss)
-           stack-popping-code
+                         (build-list (length rest-operands)
-           singular-context-check)))])))
+                                     (lambda: ([i : Natural])
+                                       (make-EnvLexicalReference i #f)))]
+                        [(rest-operand-code)
+                         (apply append-instruction-sequences
+                                (map (lambda: ([operand : Expression]
+                                               [target : Target])
+                                       (compile operand 
+                                                extended-cenv 
+                                                target 
+                                                next-linkage/expects-single))
+                                     rest-operands
+                                     rest-operand-poss))])
+            
+            (end-with-linkage
+             linkage cenv
+             (append-instruction-sequences
+              stack-pushing-code
+              rest-operand-code
+              (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands))
+                                          (make-CallKernelPrimitiveProcedure 
+                                           kernel-op 
+                                           (append constant-operand-poss rest-operand-poss)
+                                           expected-operand-types
+                                           typechecks?))
+              stack-popping-code
+              singular-context-check)))])])))
 
 
 

compiler/il-structs.rkt

@@ -3,7 +3,8 @@
 
 (require "expression-structs.rkt"
          "lexical-structs.rkt"
-         "kernel-primitives.rkt")
+         "kernel-primitives.rkt"
+         "arity-structs.rkt")
 
 
 
@@ -493,24 +494,4 @@
 
 
 
-
-
-
-
-
-
-
-
-
-;; Arity
-(define-type Arity (U AtomicArity (Listof (U AtomicArity))))
-(define-type AtomicArity (U Natural ArityAtLeast))
-(define-struct: ArityAtLeast ([value : Natural])
-  #:transparent)
-(define-predicate AtomicArity? AtomicArity)
-(define-predicate listof-atomic-arity? (Listof AtomicArity))
-
-
-
-
 (define-predicate OpArg? OpArg)

compiler/kernel-primitives.rkt

@@ -2,7 +2,7 @@
 
 (provide (all-defined-out))
 
-
+(require "arity-structs.rkt")
 (define-type OperandDomain (U 'number
                               'string
                               'box
@@ -30,6 +30,7 @@
 				    'cadr
 				    'caddr
                                     'list
+                                    'list?
                                     'list*
                                     'list->vector
                                     'vector->list
@@ -88,6 +89,8 @@
                                            'car
                                            'cdr
                                            'list
+                                           'list?
+                                           'pair?
                                            'null?
                                            'not
                                            'eq?))
@@ -95,9 +98,11 @@
 
 (define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
 
+(define-struct: IncorrectArity ([expected : Arity]))
 
 
-(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (Listof OperandDomain)))
+(: kernel-primitive-expected-operand-types (KernelPrimitiveName/Inline Natural -> (U (Listof OperandDomain)
+                                                                                     IncorrectArity)))
 ;; Given a primitive and the number of arguments, produces the list of expected domains.
 ;; TODO: do something more polymorphic.
 (define (kernel-primitive-expected-operand-types prim arity)
@@ -106,72 +111,85 @@
      (build-list arity (lambda (i) 'number))]
 
     [(eq? prim '-)
-     (unless (> arity 0)
+     (cond [(> arity 0)
-       (error '- "expects at least one argument, given ~a" arity))
+            (build-list arity (lambda (i) 'number))]
-     (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 1))])]
 
     [(eq? prim '*)
      (build-list arity (lambda (i) 'number))]
 
     [(eq? prim '/)
-     (unless (> arity 0)
+     (cond [(> arity 0)
-       (error '/ "expects at least one argument, given ~a" arity))
+            (build-list arity (lambda (i) 'number))]
-     (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 1))])]
 
     [(eq? prim 'add1)
-     (unless (= arity 1)
+     (cond [(= arity 1)
-       (error 'add1 "expects exactly one argument, given ~a" arity))
+            (list 'number)]
-     (list 'number)]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 1))])]
     
     [(eq? prim 'sub1)
-     (unless (= arity 1)
+     (cond [(= arity 1)
-       (error 'sub1 "expects exactly one argument, given ~a" arity))
+            (list 'number)]
-     (list 'number)]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 1))])]
                            
     [(eq? prim '<)
-     (build-list arity (lambda (i) 'number))]
+     (cond [(>= arity 2)
+            (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 2))])]
     
     [(eq? prim '<=)
-     (build-list arity (lambda (i) 'number))]
+     (cond [(>= arity 2)
+            (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 2))])]
     
     [(eq? prim '=)
-     (build-list arity (lambda (i) 'number))]
+     (cond [(>= arity 2)
+            (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 2))])]
     
     [(eq? prim '>)
-     (build-list arity (lambda (i) 'number))]
+     (cond [(>= arity 2)
+            (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 2))])]
     
     [(eq? prim '>=)
-     (build-list arity (lambda (i) 'number))]
+     (cond [(>= arity 2)
+            (build-list arity (lambda (i) 'number))]
+           [else
+            (make-IncorrectArity (make-ArityAtLeast 2))])]
 
     [(eq? prim 'cons)
-     (unless (= arity 2)
-       (error 'cons "expects exactly two arguments, given ~a" arity))
      (list 'any 'any)]
 
     [(eq? prim 'car)
-     (unless (= arity 1)
-       (error 'car "expects exactly one argument, given ~a" arity))
      (list 'pair)]
     
     [(eq? prim 'cdr)
-     (unless (= arity 1)
-       (error 'cdr "expects exactly one argument, given ~a" arity))
      (list 'pair)]
     
     [(eq? prim 'list)
      (build-list arity (lambda (i) 'any))]
 
+    [(eq? prim 'list?)
+     (list 'any)]
+
+    [(eq? prim 'pair?)
+     (list 'any)]
+
     [(eq? prim 'null?)
-     (unless (= arity 1)
-       (error 'null? "expects exactly one argument, given ~a" arity))
      (list 'any)]
 
     [(eq? prim 'not)
-     (unless (= arity 1)
-       (error 'not "expects exactly one argument, given ~a" arity))
      (list 'any)]
 
     [(eq? prim 'eq?)
-     (unless (= arity 2)
-       (error 'eq? "expects exactly two arguments, given ~a" arity))
      (list 'any 'any)]))

js-assembler/assemble-helpers.rkt

@@ -3,6 +3,7 @@
 (require "../compiler/il-structs.rkt"
          "../compiler/expression-structs.rkt"
          "../compiler/lexical-structs.rkt"
+         "../compiler/arity-structs.rkt"
          racket/list
          racket/string)
 

js-assembler/assemble-open-coded.rkt

@@ -84,6 +84,14 @@
            (let loop ([checked-operands checked-operands])
              (assemble-listof-assembled-values checked-operands))]
 
+          [(list?)
+           (format "RUNTIME.isList(~a)"
+                   (first checked-operands))]
+          
+          [(pair?)
+           (format "RUNTIME.isPair(~a)"
+                   (first checked-operands))]
+          
           [(null?)
            (format "(~a === RUNTIME.NULL)" (first checked-operands))]
 

simulator/simulator-primitives.rkt

@@ -2,6 +2,7 @@
 (require "simulator-structs.rkt"
          "simulator-helpers.rkt"
          "../compiler/il-structs.rkt"
+         "../compiler/arity-structs.rkt"
          racket/math
          racket/list
          (for-syntax racket/base))

simulator/simulator-structs.rkt

@@ -2,7 +2,8 @@
 
 (provide (all-defined-out))
 
-(require "../compiler/il-structs.rkt"
+(require "../compiler/arity-structs.rkt"
+         "../compiler/il-structs.rkt"
          "../compiler/expression-structs.rkt"
          "../compiler/lexical-structs.rkt")
 

simulator/simulator.rkt

@@ -9,6 +9,7 @@
          "../compiler/expression-structs.rkt"
          "../compiler/il-structs.rkt"
          "../compiler/lexical-structs.rkt"
+         "../compiler/arity-structs.rkt"
          "../compiler/bootstrapped-primitives.rkt"
          "../compiler/kernel-primitives.rkt"
          racket/list

tests/test-assemble.rkt

@@ -5,6 +5,7 @@
          "../js-assembler/package.rkt"
          "../compiler/lexical-structs.rkt"
          "../compiler/il-structs.rkt"
+         "../compiler/arity-structs.rkt"
          racket/port
          racket/promise
          racket/runtime-path)

tests/test-simulator.rkt

@@ -2,6 +2,7 @@
 
 (require "../compiler/il-structs.rkt"
          "../compiler/lexical-structs.rkt"
+         "../compiler/arity-structs.rkt"
          "../simulator/simulator-structs.rkt"
          "../simulator/simulator-primitives.rkt"
          "../simulator/simulator.rkt")