190 lines
6.7 KiB
Racket
190 lines
6.7 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "assemble-helpers.rkt"
|
|
"../compiler/il-structs.rkt"
|
|
"../compiler/lexical-structs.rkt"
|
|
"../compiler/kernel-primitives.rkt"
|
|
"assemble-structs.rkt"
|
|
racket/string
|
|
racket/list
|
|
typed/rackunit)
|
|
|
|
(provide open-code-kernel-primitive-procedure)
|
|
|
|
|
|
|
|
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String))
|
|
(define (open-code-kernel-primitive-procedure op blockht)
|
|
(let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)]
|
|
[operands : (Listof String) (map (lambda: ([op : OpArg])
|
|
(assemble-oparg op blockht))
|
|
(CallKernelPrimitiveProcedure-operands op))]
|
|
[checked-operands : (Listof String)
|
|
(map (lambda: ([dom : OperandDomain]
|
|
[pos : Natural]
|
|
[rand : String]
|
|
[typecheck? : Boolean])
|
|
(maybe-typecheck-operand operator dom pos rand typecheck?))
|
|
(CallKernelPrimitiveProcedure-expected-operand-types op)
|
|
(build-list (length operands) (lambda: ([i : Natural]) i))
|
|
operands
|
|
(CallKernelPrimitiveProcedure-typechecks? op))])
|
|
(case operator
|
|
[(+)
|
|
(cond [(empty? checked-operands)
|
|
(assemble-numeric-constant 0)]
|
|
[else
|
|
(assemble-binop-chain "plt.baselib.numbers.add" checked-operands)])]
|
|
|
|
[(-)
|
|
(cond [(empty? (rest checked-operands))
|
|
(assemble-binop-chain "plt.baselib.numbers.subtract" (cons "0" checked-operands))]
|
|
[else
|
|
(assemble-binop-chain "plt.baselib.numbers.subtract" checked-operands)])]
|
|
|
|
[(*)
|
|
(cond [(empty? checked-operands)
|
|
(assemble-numeric-constant 1)]
|
|
[else
|
|
(assemble-binop-chain "plt.baselib.numbers.multiply" checked-operands)])]
|
|
|
|
[(/)
|
|
(assemble-binop-chain "plt.baselib.numbers.divide" checked-operands)]
|
|
|
|
[(add1)
|
|
(assemble-binop-chain "plt.baselib.numbers.add" (cons "1" checked-operands))]
|
|
|
|
[(sub1)
|
|
(assemble-binop-chain "plt.baselib.numbers.subtract" (append checked-operands (list "1")))]
|
|
|
|
[(<)
|
|
(assemble-boolean-chain "plt.baselib.numbers.lessThan" checked-operands)]
|
|
|
|
[(<=)
|
|
(assemble-boolean-chain "plt.baselib.numbers.lessThanOrEqual" checked-operands)]
|
|
|
|
[(=)
|
|
(assemble-boolean-chain "plt.baselib.numbers.equals" checked-operands)]
|
|
|
|
[(>)
|
|
(assemble-boolean-chain "plt.baselib.numbers.greaterThan" checked-operands)]
|
|
|
|
[(>=)
|
|
(assemble-boolean-chain "plt.baselib.numbers.greaterThanOrEqual" checked-operands)]
|
|
|
|
[(cons)
|
|
(format "RT.makePair(~a,~a)"
|
|
(first checked-operands)
|
|
(second checked-operands))]
|
|
|
|
[(car)
|
|
(format "(~a).first" (first checked-operands))]
|
|
|
|
[(caar)
|
|
(format "(~a).first.first" (first checked-operands))]
|
|
|
|
[(cdr)
|
|
(format "(~a).rest" (first checked-operands))]
|
|
|
|
[(list)
|
|
(let loop ([checked-operands checked-operands])
|
|
(assemble-listof-assembled-values checked-operands))]
|
|
|
|
[(list?)
|
|
(format "RT.isList(~a)"
|
|
(first checked-operands))]
|
|
|
|
[(pair?)
|
|
(format "RT.isPair(~a)"
|
|
(first checked-operands))]
|
|
|
|
[(null?)
|
|
(format "(~a===RT.NULL)" (first checked-operands))]
|
|
|
|
[(not)
|
|
(format "(~a===false)" (first checked-operands))]
|
|
|
|
[(eq?)
|
|
(format "(~a===~a)" (first checked-operands) (second checked-operands))])))
|
|
|
|
|
|
|
|
(: assemble-binop-chain (String (Listof String) -> String))
|
|
(define (assemble-binop-chain rator rands)
|
|
(cond
|
|
[(empty? rands)
|
|
""]
|
|
[(empty? (rest rands))
|
|
(first rands)]
|
|
[else
|
|
(assemble-binop-chain
|
|
rator
|
|
(cons (string-append rator "(" (first rands) ", " (second rands) ")")
|
|
(rest (rest rands))))]))
|
|
|
|
(check-equal? (assemble-binop-chain "plt.baselib.numbers.add" '("3" "4" "5"))
|
|
"plt.baselib.numbers.add(plt.baselib.numbers.add(3, 4), 5)")
|
|
(check-equal? (assemble-binop-chain "plt.baselib.numbers.subtract" '("0" "42"))
|
|
"plt.baselib.numbers.subtract(0, 42)")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(: assemble-boolean-chain (String (Listof String) -> String))
|
|
(define (assemble-boolean-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))" rator (first rands) (second rands))
|
|
(loop (rest rands)))]))
|
|
"&&")
|
|
")"))
|
|
|
|
|
|
|
|
|
|
|
|
(: assemble-domain-check (Symbol OperandDomain String Natural -> String))
|
|
(define (assemble-domain-check caller domain operand-string pos)
|
|
(cond
|
|
[(eq? domain 'any)
|
|
operand-string]
|
|
[else
|
|
(let: ([predicate : String
|
|
(case domain
|
|
[(number)
|
|
(format "RT.isNumber")]
|
|
[(string)
|
|
(format "RT.isString")]
|
|
[(list)
|
|
(format "RT.isList")]
|
|
[(pair)
|
|
(format "RT.isPair")]
|
|
[(caarpair)
|
|
(format "RT.isCaarPair")]
|
|
[(box)
|
|
(format "RT.isBox")])])
|
|
(format "RT.testArgument(M,~s,~a,~a,~a,~s)"
|
|
(symbol->string domain)
|
|
predicate
|
|
operand-string
|
|
pos
|
|
(symbol->string caller)))]))
|
|
|
|
|
|
(: maybe-typecheck-operand (Symbol OperandDomain Natural String Boolean -> String))
|
|
;; Adds typechecks if we can't prove that the operand is of the required type.
|
|
(define (maybe-typecheck-operand caller domain-type position operand-string typecheck?)
|
|
(cond
|
|
[typecheck?
|
|
(assemble-domain-check caller domain-type operand-string position)]
|
|
[else
|
|
operand-string]))
|