240 lines
9.9 KiB
Racket
240 lines
9.9 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "il-structs.rkt"
|
|
"lexical-structs.rkt"
|
|
"assemble-helpers.rkt"
|
|
racket/string
|
|
racket/list)
|
|
|
|
(provide open-code-kernel-primitive-procedure)
|
|
|
|
|
|
|
|
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
|
|
(define (open-code-kernel-primitive-procedure op)
|
|
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
|
|
[rand-knowledge : (Listof CompileTimeEnvironmentEntry)
|
|
(CallKernelPrimitiveProcedure-operands-knowledge op)]
|
|
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
|
|
(case operator
|
|
|
|
[(+)
|
|
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge)])
|
|
(cond [(empty? rand-vals)
|
|
"0"]
|
|
[else
|
|
(string-append "(" (string-join checked-rands " + ") ")")]))]
|
|
|
|
[(-)
|
|
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge)])
|
|
(cond [(empty? rand-vals)
|
|
(error '- "Expects at least 1 argument, given 0")]
|
|
[(empty? (rest rand-vals))
|
|
(format "(-(~a))" (first rand-vals))]
|
|
[else
|
|
(string-append "(" (string-join checked-rands "-") ")")]))]
|
|
|
|
[(*)
|
|
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge)])
|
|
(cond [(empty? rand-vals)
|
|
"1"]
|
|
[else
|
|
(string-append "(" (string-join checked-rands "*") ")")]))]
|
|
|
|
[(/)
|
|
(let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge)])
|
|
(cond [(empty? rand-vals)
|
|
(error '/ "Expects at least 1 argument, given 0")]
|
|
[else
|
|
(string-append "(" (string-join checked-rands "/") ")")]))]
|
|
|
|
[(add1)
|
|
(unless (= 1 (length rand-vals))
|
|
(error 'add1 "Expected one argument"))
|
|
(format "(~a + 1)"
|
|
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
|
|
|
|
[(sub1)
|
|
(unless (= 1 (length rand-vals))
|
|
(error 'sub1 "Expected one argument"))
|
|
(format "(~a - 1)"
|
|
(maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))]
|
|
|
|
[(<)
|
|
(unless (> (length rand-vals) 0)
|
|
(error '< "Expected at least one argument"))
|
|
(assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge))]
|
|
[(<=)
|
|
(unless (> (length rand-vals) 0)
|
|
(error '<= "Expected at least one argument"))
|
|
(assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge))]
|
|
|
|
[(=)
|
|
(unless (> (length rand-vals) 0)
|
|
(error '= "Expected at least one argument"))
|
|
(assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge))]
|
|
|
|
[(>)
|
|
(unless (> (length rand-vals) 0)
|
|
(error '> "Expected at least one argument"))
|
|
(assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge))]
|
|
|
|
[(>=)
|
|
(unless (> (length rand-vals) 0)
|
|
(error '>= "Expected at least one argument"))
|
|
(assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals))
|
|
rand-vals
|
|
rand-knowledge))]
|
|
|
|
[(cons)
|
|
(unless (= (length rand-vals) 2)
|
|
(error 'cons "Expected two arguments"))
|
|
(format "[~a, ~a]" (first rand-vals) (second rand-vals))]
|
|
|
|
[(car)
|
|
(unless (= (length rand-vals) 1)
|
|
(error 'car "Expected one argument"))
|
|
(format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
|
|
(first rand-knowledge)))]
|
|
|
|
[(cdr)
|
|
(unless (= (length rand-vals) 1)
|
|
(error 'cdr "Expected one argument"))
|
|
(format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals)
|
|
(first rand-knowledge)))]
|
|
|
|
[(list)
|
|
(let loop ([rand-vals rand-vals])
|
|
(cond
|
|
[(empty? rand-vals)
|
|
"Primitives.null"]
|
|
[else
|
|
(format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))]
|
|
|
|
[(null?)
|
|
(unless (= (length rand-vals) 1)
|
|
(error 'null? "Expected one argument"))
|
|
(format "(~a === Primitives.null)"
|
|
(first rand-vals))]
|
|
[(not)
|
|
(unless (= (length rand-vals) 1)
|
|
(error 'not? "Expected one argument"))
|
|
(format "(!~a)" (first rand-vals))]
|
|
|
|
[(eq?)
|
|
(unless (= (length rand-vals) 2)
|
|
(error 'eq? "Expected 2 arguments"))
|
|
(format "(~a === ~a)" (first rand-vals) (second rand-vals))])))
|
|
|
|
|
|
(: assemble-chain (String (Listof String) -> String))
|
|
(define (assemble-chain rator rands)
|
|
(string-append "("
|
|
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
|
|
(cond
|
|
[(empty? rands)
|
|
'()]
|
|
[(empty? (rest rands))
|
|
'()]
|
|
[else
|
|
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
|
|
(loop (rest rands)))]))
|
|
"&&")
|
|
")"))
|
|
|
|
|
|
|
|
(define-type OperandDomain (U 'number
|
|
'string
|
|
'box
|
|
'list
|
|
'pair))
|
|
|
|
|
|
(: assemble-domain-check (OperandDomain String Natural -> String))
|
|
(define (assemble-domain-check domain operand-string pos)
|
|
(let ([test-string
|
|
(case domain
|
|
[(number)
|
|
(format "(typeof(~a) === 'number')"
|
|
operand-string)]
|
|
[(string)
|
|
(format "(typeof(~a) === 'string')"
|
|
operand-string)]
|
|
[(list)
|
|
(format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))"
|
|
operand-string operand-string operand-string)]
|
|
[(pair)
|
|
(format "(typeof(~a) === 'object' && (~a).length === 2)"
|
|
operand-string operand-string)])])
|
|
(format "((~a) ? (~a) : raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))"
|
|
test-string
|
|
operand-string
|
|
(symbol->string domain)
|
|
pos
|
|
operand-string)))
|
|
|
|
(: maybe-typecheck-operands ((Listof OperandDomain)
|
|
(Listof String)
|
|
(Listof CompileTimeEnvironmentEntry) -> (Listof String)))
|
|
(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge)
|
|
(map (lambda: ([rand : String]
|
|
[expected-domain : OperandDomain]
|
|
[knowledge : CompileTimeEnvironmentEntry]
|
|
[position : Natural])
|
|
(maybe-typecheck-operand expected-domain position rand knowledge))
|
|
rand-vals
|
|
expected-domains
|
|
rand-knowledge
|
|
(build-list (length rand-vals)
|
|
(lambda: ([i : Natural]) i))))
|
|
|
|
|
|
(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String))
|
|
;; Adds typechecks if we can't prove that the operand is of the required type.
|
|
(define (maybe-typecheck-operand domain-type position operand-string knowledge)
|
|
(cond
|
|
[(redundant-check? domain-type knowledge)
|
|
operand-string]
|
|
[else
|
|
(assemble-domain-check domain-type operand-string position)]))
|
|
|
|
|
|
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
|
|
;; Produces true if we know the knowledge implies the domain-type.
|
|
(define (redundant-check? domain-type knowledge)
|
|
(cond [(Const? knowledge)
|
|
(case domain-type
|
|
[(number)
|
|
(number? (Const-const knowledge))]
|
|
[(string)
|
|
(string? (Const-const knowledge))]
|
|
[(box)
|
|
(box? (Const-const knowledge))]
|
|
[(list)
|
|
(list? (Const-const knowledge))]
|
|
[(pair)
|
|
(pair? (Const-const knowledge))])]
|
|
[else
|
|
#f]))
|
|
|
|
|
|
(: repeat (All (A) (A Natural -> (Listof A))))
|
|
(define (repeat x n)
|
|
(build-list n (lambda (i) x))) |