Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

352 lines (279 sloc) 11.724 kB
#lang typed/racket/base
(provide (all-defined-out))
(require "arity-structs.rkt"
"lexical-structs.rkt"
"../type-helpers.rkt")
(: kernel-module-name? (ModuleLocator -> Boolean))
;; Produces true if the module is hardcoded.
(define (kernel-module-name? name)
(: kernel-locator? (ModuleLocator -> Boolean))
(define (kernel-locator? locator)
(or (and (eq? (ModuleLocator-name locator) '#%kernel)
(eq? (ModuleLocator-real-path locator) '#%kernel))
(eq? (ModuleLocator-name locator)
'whalesong/lang/kernel.rkt)))
(: paramz-locator? (ModuleLocator -> Boolean))
(define (paramz-locator? locator)
(or (and (eq? (ModuleLocator-name locator) '#%paramz)
(eq? (ModuleLocator-real-path locator) '#%paramz))))
(: kernel-module-locator? (ModuleLocator -> Boolean))
;; Produces true if the given module locator should be treated as a primitive root one
;; that is implemented by us.
(define (kernel-module-locator? locator)
(or (kernel-locator? locator)
(paramz-locator? locator)))
(kernel-module-locator? name))
;; Given a kernel-labeled ModuleVariable, returns the kernel name for it.
(: kernel-module-variable->primitive-name (ModuleVariable -> Symbol))
(define (kernel-module-variable->primitive-name a-modvar)
;; FIXME: remap if the module is something else like whalesong/unsafe/ops
(ModuleVariable-name a-modvar))
(define-type OperandDomain (U 'number
'string
'vector
'box
'list
'pair
'caarpair
'any))
;; The following are primitives that the compiler knows about:
(define-type KernelPrimitiveName (U '+
'-
'*
'/
'zero?
'add1
'sub1
'abs
'<
'<=
'=
'>
'>=
'cons
'car
'cdr
'caar
'cdar
'cadr
'cddr
'caaar
'cdaar
'cadar
'cddar
'caadr
'cdadr
'caddr
'cdddr
'caaaar
'cdaaar
'cadaar
'cddaar
'caadar
'cdadar
'caddar
'cdddar
'caaadr
'cdaadr
'cadadr
'cddadr
'caaddr
'cdaddr
'cadddr
'cddddr
'list
'list?
'list*
'list->vector
'vector->list
'vector
'vector-length
'vector-ref
'vector-set!
'make-vector
'equal?
'member
'memq
'memv
'memf
'append
'reverse
'length
'pair?
'null?
'not
'eq?
'eqv?
'remainder
'display
'newline
'call/cc
'box
'unbox
'set-box!
'string-append
'current-continuation-marks
'continuation-mark-set->list
'values
'call-with-values
'apply
'for-each
'current-print
'make-struct-type
'current-inspector
'make-struct-field-accessor
'make-struct-field-mutator
'gensym
'srcloc
'make-srcloc
'srcloc-source
'srcloc-line
'srcloc-column
'srcloc-position
'srcloc-span
'error
'raise-type-error
'struct:exn:fail
'prop:exn:srclocs
'hash?
'hash-equal?
'hash-eq?
'hash-eqv?
'hash
'hasheqv
'hasheq
'make-hash
'make-hasheqv
'make-hasheq
'make-immutable-hash
'make-immutable-hasheqv
'make-immutable-hasheq
'hash-copy
'hash-ref
'hash-has-key?
'hash-set!
'hash-set
'hash-remove!
'hash-remove
'equal-hash-code
'hash-count
'hash-keys
'hash-values
'string-copy
'unsafe-car
'unsafe-cdr
))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)
;; These are the primitives that we know how to inline.
(define-type KernelPrimitiveName/Inline (U '+
'-
'*
'/
'zero?
'add1
'sub1
'<
'<=
'=
'>
'>=
'cons
'car
'caar
'cdr
'list
'list?
'pair?
'null?
'not
'eq?
'vector-ref
'vector-set!
))
(ensure-type-subsetof KernelPrimitiveName/Inline KernelPrimitiveName)
(define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
(define-struct: IncorrectArity ([expected : Arity]))
(: 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)
(cond
[(eq? prim '+)
(build-list arity (lambda (i) 'number))]
[(eq? prim '-)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '*)
(build-list arity (lambda (i) 'number))]
[(eq? prim '/)
(cond [(> arity 0)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'zero?)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'add1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim 'sub1)
(cond [(= arity 1)
(list 'number)]
[else
(make-IncorrectArity (make-ArityAtLeast 1))])]
[(eq? prim '<)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '<=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim '>=)
(cond [(>= arity 2)
(build-list arity (lambda (i) 'number))]
[else
(make-IncorrectArity (make-ArityAtLeast 2))])]
[(eq? prim 'cons)
(list 'any 'any)]
[(eq? prim 'car)
(list 'pair)]
[(eq? prim 'caar)
(list 'caarpair)]
[(eq? prim 'cdr)
(list 'pair)]
[(eq? prim 'list)
(build-list arity (lambda (i) 'any))]
[(eq? prim 'list?)
(list 'any)]
[(eq? prim 'pair?)
(list 'any)]
[(eq? prim 'null?)
(list 'any)]
[(eq? prim 'not)
(list 'any)]
[(eq? prim 'eq?)
(list 'any 'any)]
[(eq? prim 'vector-ref)
(list 'vector 'number)]
[(eq? prim 'vector-set!)
(list 'vector 'number 'any)]))
Jump to Line
Something went wrong with that request. Please try again.