You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
213 lines
7.3 KiB
Scheme
213 lines
7.3 KiB
Scheme
27 years ago
|
;; toplevelenv.ss
|
||
|
|
;; Handles the default top level environment
|
||
|
|
;;
|
||
|
|
;; ======================================================================
|
||
|
|
;; Primitive environments: symbol -> priminfo
|
||
|
|
;; First a helper fn
|
||
|
|
|
||
|
|
(define-structure (priminfo sym type domain-filters predicate-fn))
|
||
|
|
|
||
|
|
;; filter-domains is a list of filters for various args,
|
||
|
|
;; if no error raised
|
||
|
|
|
||
|
|
;; inj-predicate is a fn : list-AVS x list-AVS x AVS x bool -> AVS
|
||
|
|
;; used for (if (pred ... x ...) ...)
|
||
|
|
|
||
|
|
(define (primitive->priminfo name type . attrs)
|
||
|
|
(let ([type (expand-type type)])
|
||
|
|
(make-priminfo
|
||
|
|
name
|
||
|
|
type
|
||
|
|
|
||
|
|
;; Calculate filter-domains
|
||
|
|
(match type
|
||
|
|
[(domain '->* _)
|
||
|
|
;; Now walk domain and args
|
||
|
|
(recur loop ([domain domain])
|
||
|
|
(match domain
|
||
|
|
[('cons domain domain-rest)
|
||
|
|
(cons
|
||
|
|
(let ([templates (con-exp->templates domain)])
|
||
|
|
(if templates
|
||
|
|
(make-filter #t templates)
|
||
|
|
#f))
|
||
|
|
(loop domain-rest))]
|
||
|
|
[_ '()]))]
|
||
|
|
[_ '()])
|
||
|
|
|
||
|
|
;; Calculate predicate-fn
|
||
|
|
(foldl
|
||
|
|
(lambda (attr predicate-fn)
|
||
|
|
(let*
|
||
|
|
([mk-predicate-fn
|
||
|
|
(lambda (filter-then filter-else)
|
||
|
|
(lambda (b a AVS sign)
|
||
|
|
(let ([filter (if sign filter-then filter-else)])
|
||
|
|
(if filter
|
||
|
|
(let ([nu-AVS (mk-AVS-tmp 'filter)])
|
||
|
|
(new-con! AVS
|
||
|
|
(create-con-filter filter
|
||
|
|
nu-AVS))
|
||
|
|
nu-AVS)
|
||
|
|
AVS))))]
|
||
|
|
[get-templates
|
||
|
|
(lambda (C*) (map lookup-template C*))]
|
||
|
|
[nu-fn
|
||
|
|
(match attr
|
||
|
|
[('predicate-fn exp) exp]
|
||
|
|
[('predicate . C*)
|
||
|
|
(let ([templates (get-templates C*)])
|
||
|
|
(mk-predicate-fn (make-filter #t templates)
|
||
|
|
(make-filter #f templates)))]
|
||
|
|
[('predicate* true-info false-info)
|
||
|
|
(apply
|
||
|
|
mk-predicate-fn
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
['_ #f]
|
||
|
|
[(bool . C*)
|
||
|
|
(let ([templates (get-templates C*)])
|
||
|
|
(make-filter bool templates))]
|
||
|
|
[_ (error 'predicate* "Bad syntax")])
|
||
|
|
(list true-info false-info)))]
|
||
|
|
[_ #f])])
|
||
|
|
(if nu-fn
|
||
|
|
;; compose
|
||
|
|
(lambda (b a AVS sign)
|
||
|
|
(nu-fn b a
|
||
|
|
(predicate-fn b a AVS sign)
|
||
|
|
sign))
|
||
|
|
predicate-fn)))
|
||
|
|
(lambda (b a AVS bool) AVS)
|
||
|
|
attrs))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
;; Now the default environment
|
||
|
|
|
||
|
|
(define default-primitive-env (void))
|
||
|
|
;; type: symbol -> priminfo
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define output-type-expander (void))
|
||
|
|
(define (init-output-type-expander!)
|
||
|
|
(set! output-type-expander (lambda (x) x)))
|
||
|
|
|
||
|
|
(define (install-output-type-expander! expander)
|
||
|
|
(let ([old-expander output-type-expander])
|
||
|
|
(set! output-type-expander
|
||
|
|
(lambda (type)
|
||
|
|
(old-expander (recur loop ([type type])
|
||
|
|
(let ([t (expander type)])
|
||
|
|
(if (eq? t type) type (loop t)))))))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
;; For input-type-expander, recursion is done in expand-type
|
||
|
|
|
||
|
|
(define default-input-type-expander (void))
|
||
|
|
(define input-type-expander (void))
|
||
|
|
|
||
|
|
(define (init-input-type-expander!)
|
||
|
|
(set! input-type-expander default-input-type-expander))
|
||
|
|
|
||
|
|
(define (init-empty-input-type-expander!)
|
||
|
|
(set! input-type-expander (lambda (x) x)))
|
||
|
|
|
||
|
|
(define (capture-input-type-expander!)
|
||
|
|
(set! default-input-type-expander input-type-expander))
|
||
|
|
|
||
|
|
(define (install-input-type-expander! expander)
|
||
|
|
(let ([old-expander input-type-expander])
|
||
|
|
(set! input-type-expander
|
||
|
|
(lambda (type)
|
||
|
|
;;(pretty-print `(input-type-expander ,type))
|
||
|
|
(old-expander (expander type))))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (extend-env-w/-define-structure env tag . args)
|
||
|
|
;; env: sym -> priminfo
|
||
|
|
(let ([add!
|
||
|
|
(lambda (name type . attrs)
|
||
|
|
(set! env
|
||
|
|
(extend-env env name
|
||
|
|
(apply primitive->priminfo name type attrs))))]
|
||
|
|
[type (symbol-append 'structure: tag)]
|
||
|
|
[gen-args (map (lambda (_) (gensym)) args)]
|
||
|
|
[gen-arg (gensym)])
|
||
|
|
(apply add-constructor! type (map (lambda (a) #t) args))
|
||
|
|
(add! (symbol-append 'make- tag) `(,@gen-args -> (,type ,@gen-args)))
|
||
|
|
(add! (symbol-append tag '?) `(_ -> bool) `(predicate ,type))
|
||
|
|
(for-each-with-n
|
||
|
|
(lambda (arg n)
|
||
|
|
(let ([type-ref
|
||
|
|
`((,type ,@(map (lambda (a)
|
||
|
|
(if (eq? a arg) gen-arg '_))
|
||
|
|
args))
|
||
|
|
-> ,gen-arg)]
|
||
|
|
[type-bang
|
||
|
|
`((,type ,@(map (lambda (a)
|
||
|
|
(if (eq? a arg) `(! ,gen-arg) '_))
|
||
|
|
args))
|
||
|
|
,gen-arg
|
||
|
|
-> void)])
|
||
|
|
(add! (symbol-append tag '- arg) type-ref)
|
||
|
|
(add! (symbol-append tag '- (add1 n)) type-ref)
|
||
|
|
(add! (symbol-append 'set- tag '- arg '!) type-bang)
|
||
|
|
(add! (symbol-append 'set- tag '- (add1 n) '!) type-bang)))
|
||
|
|
args)
|
||
|
|
env))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (add-default-primitive! name type . attrs)
|
||
|
|
;; working w/ default primitive env => use default constructor env
|
||
|
|
(init-current-constructor-env!)
|
||
|
|
(set! default-primitive-env
|
||
|
|
(extend-env default-primitive-env
|
||
|
|
name
|
||
|
|
(apply primitive->priminfo name type attrs))))
|
||
|
|
|
||
|
|
(define (add-default-primitives! l)
|
||
|
|
(for-each
|
||
|
|
(lambda (args) (apply add-default-primitive! args))
|
||
|
|
l))
|
||
|
|
|
||
|
|
(define
|
||
|
|
select-language
|
||
|
|
(make-parameter-list
|
||
|
|
'none
|
||
|
|
'((DrScheme "DrScheme")
|
||
|
|
(MzScheme "MzScheme")
|
||
|
|
(R4RS "R4RS")
|
||
|
|
(Chez "Chez Scheme")
|
||
|
|
(Rice "Rice Scheme")
|
||
|
|
(none "None"))
|
||
|
|
(lambda (scheme)
|
||
|
|
(unless (eq? scheme 'none)
|
||
|
|
(init-default-constructor-env!)
|
||
|
|
(init-empty-input-type-expander!)
|
||
|
|
(init-output-type-expander!)
|
||
|
|
(set! default-primitive-env empty-env)
|
||
|
|
(init-R4RS!)
|
||
|
|
(case scheme
|
||
|
|
[MzScheme (init-MzScheme-on-R4RS!)]
|
||
|
|
[DrScheme (init-MzScheme-on-R4RS!)
|
||
|
|
(init-DrScheme-on-MzScheme!)]
|
||
|
|
[R4RS (void)]
|
||
|
|
[Chez (init-Chez-on-R4RS!)]
|
||
|
|
[Rice (init-Chez-on-R4RS!)
|
||
|
|
(init-Rice-on-Chez!)]
|
||
|
|
[none (void)])
|
||
|
|
(when (st:numops) (init-smart-numops!))
|
||
|
|
;; Load .spideyrc file and .spidey-system-rc files
|
||
|
|
(when (file-exists? "~/.spideyrc") (load "~/.spideyrc"))
|
||
|
|
(let ([systemrc (string-append "~/.spidey-"
|
||
|
|
(symbol->string scheme)
|
||
|
|
"-rc")])
|
||
|
|
(when (file-exists? systemrc) (load systemrc)))
|
||
|
|
(capture-input-type-expander!)))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|