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.
1483 lines
62 KiB
Scheme
1483 lines
62 KiB
Scheme
27 years ago
|
;; languages.ss - defines analyzed language
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define-struct language-spec
|
||
|
|
(kernel constructor-env initial-env tdef-env))
|
||
|
|
(define language-spec (void))
|
||
|
|
|
||
|
|
(define make-expander-namespace (void))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define
|
||
|
|
st:language
|
||
|
|
(make-parameter-list
|
||
|
|
'none
|
||
|
|
'( (DrScheme "DrScheme")
|
||
|
|
(MzScheme "MzScheme")
|
||
|
|
(MrEd "MrEd")
|
||
|
|
(R4RS "R4RS")
|
||
|
|
(Chez "Chez Scheme")
|
||
|
|
(none "None"))
|
||
|
|
(lambda (scheme)
|
||
|
|
(unless (eq? scheme 'none)
|
||
|
|
(init-default-constructor-env!)
|
||
|
|
(init-input-type-expander!)
|
||
|
|
(init-output-type-expander!)
|
||
|
|
(init-kernel!)
|
||
|
|
(init-common-AV!)
|
||
|
|
(set! make-expander-namespace (lambda () (make-namespace)))
|
||
|
|
(init-expand!)
|
||
|
|
(set! initial-env (make-hash-table))
|
||
|
|
;; ---
|
||
|
|
(init-R4RS!)
|
||
|
|
(case scheme
|
||
|
|
[(MzScheme)
|
||
|
|
(init-MzScheme-on-R4RS!)]
|
||
|
|
[(MrEd) (init-MzScheme-on-R4RS!)
|
||
|
|
(init-mzlib!)
|
||
|
|
(init-MrEd-on-MzScheme!)
|
||
|
|
(set! make-expander-namespace (lambda () (make-namespace 'wx)))]
|
||
|
|
[(DrScheme)
|
||
|
|
(init-MzScheme-on-R4RS!)
|
||
|
|
(init-mzlib!)
|
||
|
|
(init-DrScheme-on-MzScheme!)
|
||
|
|
(set! make-expander-namespace (lambda () (make-namespace 'wx)))
|
||
|
|
]
|
||
|
|
[(R4RS) (void)]
|
||
|
|
[(Chez) (init-Chez-on-R4RS!)]
|
||
|
|
[(none) (void)])
|
||
|
|
(when (st:numops) (init-smart-numops!) (init-vectors-w/-length))
|
||
|
|
|
||
|
|
(when (file-exists? "~/.spideyrc") (language-add-boot-file "~/.spideyrc"))
|
||
|
|
(let ([systemrc (string-append "~/.spidey-"
|
||
|
|
(symbol->string scheme)
|
||
|
|
"-rc")])
|
||
|
|
(when (file-exists? systemrc) (language-add-boot-file systemrc)))
|
||
|
|
|
||
|
|
;;
|
||
|
|
;(printf "Saving language spec ... ")
|
||
|
|
(set! language-spec
|
||
|
|
(make-language-spec
|
||
|
|
(prompt-kernel-state)
|
||
|
|
constructor-env
|
||
|
|
initial-env
|
||
|
|
global-tdef-env))
|
||
|
|
;(printf "done~n")
|
||
|
|
))))
|
||
|
|
|
||
|
|
;(trace st:language)
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (initialize-language!)
|
||
|
|
(mrspidey:progress "Initializing language" '...)
|
||
|
|
(match language-spec
|
||
|
|
[($ language-spec k c i t)
|
||
|
|
(pretty-debug '(initialize-language!))
|
||
|
|
(unprompt-kernel-state! k)
|
||
|
|
(set-constructor-env! c)
|
||
|
|
(set! initial-env i)
|
||
|
|
(init-global-tenv! '() t '())
|
||
|
|
])
|
||
|
|
(mrspidey:progress "Initializing language" 'done))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define st:numops ;; Default false
|
||
|
|
(let ([value #f])
|
||
|
|
(match-lambda*
|
||
|
|
[() value]
|
||
|
|
[('?) `( (#f "Inaccurate" "")
|
||
|
|
(#t "Accurate" ""))]
|
||
|
|
[(nu)
|
||
|
|
(unless (boolean? nu) (error 'st:numops "Bad parameter"))
|
||
|
|
(unless (eq? value nu)
|
||
|
|
(set! value nu)
|
||
|
|
(when value (st:constants #t))
|
||
|
|
;; Reprocess the language
|
||
|
|
(st:language (st:language)))
|
||
|
|
value])))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define initial-env '())
|
||
|
|
|
||
|
|
(define (extend-initial-env! sym ftype)
|
||
|
|
(assert (and (symbol? sym) (FlowType? ftype)) 'extend-initial-env)
|
||
|
|
(hash-table-put! initial-env sym ftype)
|
||
|
|
(hash-table-put! initial-env (symbol-append '#% sym) ftype))
|
||
|
|
|
||
|
|
(define list-primitives '())
|
||
|
|
|
||
|
|
(define (add-default-primitive! name type . attrs)
|
||
|
|
(set! list-primitives (cons (list name type) list-primitives))
|
||
|
|
;; working w/ default primitive env => use default constructor env
|
||
|
|
(let* ([def (apply primitive->atprim name type attrs)]
|
||
|
|
[ftype (create-fo-FlowType def)])
|
||
|
|
(extend-initial-env! name ftype)))
|
||
|
|
|
||
|
|
(define (show-primitives)
|
||
|
|
(let ([l (quicksort list-primitives
|
||
|
|
(lambda (a b)
|
||
|
|
(string<? (symbol->string (car a)) (symbol->string (car b)))))]
|
||
|
|
[file "~/Spidey/doc/prims.tex"])
|
||
|
|
(when (file-exists? file) (delete-file file))
|
||
|
|
(with-output-to-file file
|
||
|
|
(lambda ()
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(name type)
|
||
|
|
(printf "\\scheme|~s| \\> ~n" name)
|
||
|
|
(printf "\\begin{schemedisplay}~n")
|
||
|
|
(parameterize ([pretty-print-columns 60])
|
||
|
|
(pretty-print type))
|
||
|
|
(printf "\\end{schemedisplay}~n")
|
||
|
|
(printf "\\\\~n")])
|
||
|
|
l)))))
|
||
|
|
|
||
|
|
(define (add-default-primitives! l)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(name 'GLOBAL-TYPE-VARIABLE)
|
||
|
|
'(add-default-tdef! name)]
|
||
|
|
[args (apply add-default-primitive! args)])
|
||
|
|
l))
|
||
|
|
|
||
|
|
(define (add-default-tdef! name) (add-global-tdef! name))
|
||
|
|
|
||
|
|
; (let ([Tvar (mk-Tvar (symbol-append 'default-tdef: name))])
|
||
|
|
; (set! default-tdef-env
|
||
|
|
; (cons (cons name Tvar) default-tdef-env))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (get-default-bindings free-names)
|
||
|
|
(recur loop ([env atenv:empty][free-names free-names])
|
||
|
|
(match free-names
|
||
|
|
[() env]
|
||
|
|
[(name . rest)
|
||
|
|
(let ([sym (zodiac:binding-var name)])
|
||
|
|
(match (hash-table-get initial-env sym (lambda () #f))
|
||
|
|
[#f
|
||
|
|
(mrspidey:warning (format "Free variable ~s" sym))
|
||
|
|
(loop env rest)]
|
||
|
|
[ftype (loop (atenv:extend env name ftype) rest)]))])))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (language-add-boot-file filename)
|
||
|
|
(let*-vals
|
||
|
|
( [filename (normalize-path filename)]
|
||
|
|
[boot-defs (zodiac:read* (open-code-file filename) filename)]
|
||
|
|
[(defs free-names) (my-scheme-expand-program boot-defs)]
|
||
|
|
[env (get-default-bindings free-names)]
|
||
|
|
[(env refs result) (top-level-traverse-defs defs env)])
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ zodiac:define-values-form _ _ _ _ refs)
|
||
|
|
(for-each
|
||
|
|
(lambda (ref)
|
||
|
|
(let ([var (zodiac:varref-binding ref)])
|
||
|
|
(pretty-debug `(Defining ,(zodiac:binding-var var)))
|
||
|
|
(extend-initial-env!
|
||
|
|
(zodiac:binding-var var)
|
||
|
|
(atenv:lookup env var))))
|
||
|
|
refs)]
|
||
|
|
[_ (void)])
|
||
|
|
defs)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (init-R4RS!)
|
||
|
|
;; Also extends it with void
|
||
|
|
|
||
|
|
(add-constructor! 'vec #t)
|
||
|
|
(add-constructor! 'iport)
|
||
|
|
(add-constructor! 'oport)
|
||
|
|
(add-constructor! 'eof )
|
||
|
|
(add-constructor! 'box #t)
|
||
|
|
|
||
|
|
;; for demos
|
||
|
|
(add-constructor! 'pair #t #t)
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
;; for demos
|
||
|
|
(nil nil)
|
||
|
|
(pair (forall (a b) (a b -> (pair a b))))
|
||
|
|
(left (forall (a) ((pair a _) -> a)))
|
||
|
|
(right (forall (a) ((pair _ a) -> a)))
|
||
|
|
|
||
|
|
;;(nil nil)
|
||
|
|
|
||
|
|
;; booleans
|
||
|
|
(not (_ -> bool) (predicate* (#t false) (#f false)))
|
||
|
|
|
||
|
|
;; equivalence predicates
|
||
|
|
(eqv? (_ _ -> bool))
|
||
|
|
(eq? (_ _ -> bool))
|
||
|
|
(equal? (_ _ -> bool))
|
||
|
|
|
||
|
|
;; pairs and lists
|
||
|
|
(cons (forall (a b) (a b -> (cons a b))))
|
||
|
|
(car (forall (a) ((cons a _) -> a)))
|
||
|
|
(cdr (forall (a) ((cons _ a) -> a)))
|
||
|
|
(caar (forall (a) ((cons (cons a _) _) -> a)))
|
||
|
|
(cadr (forall (a) ((cons _ (cons a _)) -> a)))
|
||
|
|
(cdar (forall (a) ((cons (cons _ a) _) -> a)))
|
||
|
|
(cddr (forall (a) ((cons _ (cons _ a)) -> a)))
|
||
|
|
(caaar (forall (a) ((cons (cons (cons a _) _) _) -> a)))
|
||
|
|
(caadr (forall (a) ((cons _ (cons (cons a _) _)) -> a)))
|
||
|
|
(cadar (forall (a) ((cons (cons _ (cons a _)) _) -> a)))
|
||
|
|
(caddr (forall (a) ((cons _ (cons _ (cons a _))) -> a)))
|
||
|
|
(cdaar (forall (a) ((cons (cons (cons _ a) _) _) -> a)))
|
||
|
|
(cdadr (forall (a) ((cons _ (cons (cons _ a) _)) -> a)))
|
||
|
|
(cddar (forall (a) ((cons (cons _ (cons _ a)) _) -> a)))
|
||
|
|
(cdddr (forall (a) ((cons _ (cons _ (cons _ a))) -> a)))
|
||
|
|
(caaaar (forall (a) ((cons (cons (cons (cons a _) _) _) _) -> a)))
|
||
|
|
(caaadr (forall (a) ((cons _ (cons (cons (cons a _) _) _)) -> a)))
|
||
|
|
(caadar (forall (a) ((cons (cons _ (cons (cons a _) _)) _) -> a)))
|
||
|
|
(caaddr (forall (a) ((cons _ (cons _ (cons (cons a _) _))) -> a)))
|
||
|
|
(cadaar (forall (a) ((cons (cons (cons _ (cons a _)) _) _) -> a)))
|
||
|
|
(cadadr (forall (a) ((cons _ (cons (cons _ (cons a _)) _)) -> a)))
|
||
|
|
(caddar (forall (a) ((cons (cons _ (cons _ (cons a _))) _) -> a)))
|
||
|
|
(cadddr (forall (a) ((cons _ (cons _ (cons _ (cons a _)))) -> a)))
|
||
|
|
(cdaaar (forall (a) ((cons (cons (cons (cons _ a) _) _) _) -> a)))
|
||
|
|
(cdaadr (forall (a) ((cons _ (cons (cons (cons _ a) _) _)) -> a)))
|
||
|
|
(cdadar (forall (a) ((cons (cons _ (cons (cons _ a) _)) _) -> a)))
|
||
|
|
(cdaddr (forall (a) ((cons _ (cons _ (cons (cons _ a) _))) -> a)))
|
||
|
|
(cddaar (forall (a) ((cons (cons (cons _ (cons _ a)) _) _) -> a)))
|
||
|
|
(cddadr (forall (a) ((cons _ (cons (cons _ (cons _ a)) _)) -> a)))
|
||
|
|
(cdddar (forall (a) ((cons (cons _ (cons _ (cons _ a))) _) -> a)))
|
||
|
|
(cddddr (forall (a) ((cons _ (cons _ (cons _ (cons _ a)))) -> a)))
|
||
|
|
|
||
|
|
(set-car! (forall (a) ((cons (! a) _) a -> void)))
|
||
|
|
(set-cdr! (forall (b) ((cons _ (! b)) b -> void)))
|
||
|
|
(list (case->
|
||
|
|
(forall (a b c d e) (a b c d e -> (list a b c d e)))
|
||
|
|
(forall (a b c d) (a b c d -> (list a b c d)))
|
||
|
|
(forall (a b c) (a b c -> (list a b c)))
|
||
|
|
(forall (a b) (a b -> (list a b)))
|
||
|
|
(forall (a) (a -> (list a)))
|
||
|
|
(forall (a) (a *-> a))))
|
||
|
|
(length ((listof _) -> num))
|
||
|
|
(append (case->
|
||
|
|
(forall (l) (l -> l))
|
||
|
|
(forall (a l)
|
||
|
|
((listof a) l ->
|
||
|
|
(MU out (union (cons a out) l))))
|
||
|
|
(forall (inlist a)
|
||
|
|
((arglistof (union inlist (listof a)))
|
||
|
|
*->
|
||
|
|
(MU out (union (cons a out) inlist))))))
|
||
|
|
(reverse (forall (a) ((listof a) -> (listof a))))
|
||
|
|
(list-tail (forall (a tail)
|
||
|
|
((MU l (union nil (cons a (union l tail))))
|
||
|
|
num
|
||
|
|
-> (cons a tail))))
|
||
|
|
(list-ref (forall (a) ((listof a) num -> a)))
|
||
|
|
(memq (forall (a tail)
|
||
|
|
(a (MU l (union nil (cons a l) tail))
|
||
|
|
-> (union false (cons a tail)))))
|
||
|
|
(memv (forall (a tail)
|
||
|
|
(a (MU l (union nil (cons a l) tail))
|
||
|
|
-> (union false (cons a tail)))))
|
||
|
|
(member (forall (a tail)
|
||
|
|
(a (MU l (union nil (cons a l) tail))
|
||
|
|
-> (union false (cons a tail)))))
|
||
|
|
(assq (forall (a c)
|
||
|
|
(a (listof (cons a c)) ->
|
||
|
|
(union false (cons a c)))))
|
||
|
|
(assv (forall (a c)
|
||
|
|
(a (listof (cons a c)) ->
|
||
|
|
(union false (cons a c)))))
|
||
|
|
(assoc (forall (a c)
|
||
|
|
(a (listof (cons a c)) ->
|
||
|
|
(union false (cons a c)))))
|
||
|
|
|
||
|
|
;; symbols
|
||
|
|
(symbol->string (sym -> str))
|
||
|
|
(string->symbol (str -> sym))
|
||
|
|
|
||
|
|
;; numbers
|
||
|
|
(complex? (_ -> bool) (predicate* (#t num) _))
|
||
|
|
(real? (_ -> bool) (predicate* (#t num) _))
|
||
|
|
(rational? (_ -> bool) (predicate* (#t num) _))
|
||
|
|
(integer? (_ -> bool) (predicate* (#t num) _))
|
||
|
|
(exact? (num -> bool))
|
||
|
|
(inexact? (num -> bool))
|
||
|
|
(= ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(< ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(> ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(<= ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(>= ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(zero? (num -> bool))
|
||
|
|
(positive? (num -> bool))
|
||
|
|
(negative? (num -> bool))
|
||
|
|
(odd? (num -> bool))
|
||
|
|
(even? (num -> bool))
|
||
|
|
(max ((arg num (arglistof num)) *-> num) )
|
||
|
|
(min ((arg num (arglistof num)) *-> num) )
|
||
|
|
(+ ((arglistof num) *-> num) )
|
||
|
|
(* ((arglistof num) *-> num) )
|
||
|
|
(- ((arg num (arglistof num)) *-> num) )
|
||
|
|
(/ ((arg num (arglistof num)) *-> num) )
|
||
|
|
(abs (num -> num))
|
||
|
|
(quotient (num num -> num))
|
||
|
|
(remainder (num num -> num))
|
||
|
|
(modulo (num num -> num))
|
||
|
|
(gcd ((arglistof num) *-> num) )
|
||
|
|
(lcm ((arglistof num) *-> num) )
|
||
|
|
(numerator (num -> num) )
|
||
|
|
(denominator (num -> num) )
|
||
|
|
(floor (num -> num) )
|
||
|
|
(ceiling (num -> num) )
|
||
|
|
(truncate (num -> num) )
|
||
|
|
(round (num -> num) )
|
||
|
|
(rationalize (num num -> num) )
|
||
|
|
(exp (num -> num) )
|
||
|
|
(log (num -> num) )
|
||
|
|
(sin (num -> num) )
|
||
|
|
(cos (num -> num) )
|
||
|
|
(tan (num -> num) )
|
||
|
|
(asin (num -> num) )
|
||
|
|
(acos (num -> num) )
|
||
|
|
(atan (num optional num -> num) )
|
||
|
|
(sqrt (num -> num) )
|
||
|
|
(expt (num num -> num) )
|
||
|
|
(make-rectangular (num num -> num) )
|
||
|
|
(make-polar (num num -> num) )
|
||
|
|
(real-part (num -> num) )
|
||
|
|
(imag-part (num -> num) )
|
||
|
|
(magnitude (num -> num) )
|
||
|
|
(angle (num -> num) )
|
||
|
|
(exact->inexact (num -> num) )
|
||
|
|
(inexact->exact (num -> num) )
|
||
|
|
(number->string (num optional num -> str) )
|
||
|
|
(string->number (str optional num -> num) )
|
||
|
|
|
||
|
|
;; characters
|
||
|
|
(char=? (char char -> bool) )
|
||
|
|
(char<? (char char -> bool) )
|
||
|
|
(char>? (char char -> bool) )
|
||
|
|
(char<=? (char char -> bool) )
|
||
|
|
(char>=? (char char -> bool) )
|
||
|
|
(char-ci=? (char char -> bool) )
|
||
|
|
(char-ci<? (char char -> bool) )
|
||
|
|
(char-ci>? (char char -> bool) )
|
||
|
|
(char-ci<=? (char char -> bool) )
|
||
|
|
(char-ci>=? (char char -> bool) )
|
||
|
|
(char-alphabetic? (char -> bool) )
|
||
|
|
(char-numeric? (char -> bool) )
|
||
|
|
(char-whitespace? (char -> bool) )
|
||
|
|
(char-upper-case? (char -> bool) )
|
||
|
|
(char-lower-case? (char -> bool) )
|
||
|
|
(char->integer (char -> num) )
|
||
|
|
(integer->char (num -> char) )
|
||
|
|
(char-upcase (char -> char) )
|
||
|
|
(char-downcase (char -> char) )
|
||
|
|
|
||
|
|
;; strings
|
||
|
|
(make-string (num optional char -> str) )
|
||
|
|
(string ((arglistof char) *-> str) )
|
||
|
|
(string-length (str -> num) )
|
||
|
|
(string-ref (str num -> char) )
|
||
|
|
(string-set! (str num char -> void) )
|
||
|
|
(string=? (str str -> bool) )
|
||
|
|
(string<? (str str -> bool) )
|
||
|
|
(string>? (str str -> bool) )
|
||
|
|
(string<=? (str str -> bool) )
|
||
|
|
(string>=? (str str -> bool) )
|
||
|
|
(string-ci=? (str str -> bool) )
|
||
|
|
(string-ci<? (str str -> bool) )
|
||
|
|
(string-ci>? (str str -> bool) )
|
||
|
|
(string-ci<=? (str str -> bool) )
|
||
|
|
(string-ci>=? (str str -> bool) )
|
||
|
|
(substring (str num num -> str) )
|
||
|
|
(string-append ((arglistof str) *-> str) )
|
||
|
|
(string->list (str -> (listof char)) )
|
||
|
|
(list->string ((listof char) -> str) )
|
||
|
|
(string-copy (str -> str) )
|
||
|
|
(string-fill! (str char -> void) )
|
||
|
|
|
||
|
|
;; vectors
|
||
|
|
;; make-vector -- different semantics
|
||
|
|
(make-vector (case->
|
||
|
|
(num -> (vec num))
|
||
|
|
(forall (a) (num a -> (vec a)))
|
||
|
|
(forall (a) (num optional a -> (vec (union a num))))))
|
||
|
|
(vector (forall (a) ((arglistof a) *-> (vec a))))
|
||
|
|
(vector-length (forall (a) ((vec a) -> num)))
|
||
|
|
(vector-ref (forall (a) ((vec a) num -> a)))
|
||
|
|
(vector-set! (forall (a) ((vec (! a)) num a -> void)))
|
||
|
|
(vector->list (forall (a) ((vec a) -> (listof a))))
|
||
|
|
(list->vector (forall (a) ((listof a) -> (vec a))))
|
||
|
|
(vector-fill! (forall (a) ((vec (! a)) a -> void)))
|
||
|
|
|
||
|
|
;; control features
|
||
|
|
(apply (case->
|
||
|
|
(forall (l r) ((l *->* r) l ->* r))
|
||
|
|
(forall (a l r) ((a l *->* r) a l ->* r))
|
||
|
|
(forall (a b l r) ((a b l *->* r) a b l ->* r))
|
||
|
|
(forall (a b c l r) ((a b c l *->* r) a b c l ->* r))
|
||
|
|
(forall (a b c d l r) ((a b c d l *->* r) a b c d l ->* r))
|
||
|
|
(forall (x r)
|
||
|
|
(((MU l (union (cons x l) x)) *->* r)
|
||
|
|
x
|
||
|
|
(arglistof x)
|
||
|
|
*->* r))))
|
||
|
|
(map (case->
|
||
|
|
(forall (a r)
|
||
|
|
((a -> r) (listof a)
|
||
|
|
-> (listof r)))
|
||
|
|
(forall (a b r)
|
||
|
|
((a b -> r) (listof a) (listof b)
|
||
|
|
-> (listof r)))
|
||
|
|
(forall (a b c r)
|
||
|
|
((a b c -> r) (listof a) (listof b) (listof c)
|
||
|
|
-> (listof r)))
|
||
|
|
(forall (x r)
|
||
|
|
(((arglistof x) *-> r) (listof x) (arglistof (listof x))
|
||
|
|
*-> (listof r)))))
|
||
|
|
|
||
|
|
(for-each (case->
|
||
|
|
(forall (a)
|
||
|
|
((a -> _) (listof a)
|
||
|
|
-> void))
|
||
|
|
(forall (a b)
|
||
|
|
((a b -> _) (listof a) (listof b)
|
||
|
|
-> void))
|
||
|
|
(forall (a b c)
|
||
|
|
((a b c -> _) (listof a) (listof b) (listof c)
|
||
|
|
-> void))
|
||
|
|
(forall (x)
|
||
|
|
(((arglistof x) *-> _) (listof x) (arglistof (listof x))
|
||
|
|
*-> void))))
|
||
|
|
|
||
|
|
(force (forall (a) ((promise a) -> a)))
|
||
|
|
(make-promise ((-> a) -> (promise a)))
|
||
|
|
(promise? (_ -> bool) (predicate promise))
|
||
|
|
(call-with-current-continuation
|
||
|
|
(forall (a) (((a *-> empty) ->* (mvalues a)) ->* (mvalues a))))
|
||
|
|
(eval (sexp -> sexp));; --- Not quite right!!!
|
||
|
|
|
||
|
|
;; input and output
|
||
|
|
(call-with-input-file (forall (a) (str (iport -> a) -> a)))
|
||
|
|
(call-with-output-file (forall (a) (str (oport -> a) -> a)))
|
||
|
|
(current-input-port (-> iport) )
|
||
|
|
(current-output-port (-> oport) )
|
||
|
|
(with-input-from-file (forall (a) (str (-> a) -> a)))
|
||
|
|
(with-output-to-file (forall (a) (str (-> a) -> a)))
|
||
|
|
(open-input-file (str -> iport) )
|
||
|
|
(open-output-file (str -> oport) )
|
||
|
|
(close-input-port (iport -> void) )
|
||
|
|
(close-output-port (oport -> void) )
|
||
|
|
|
||
|
|
(read (optional iport -> (union eof sexp)))
|
||
|
|
(read-char (optional iport -> (union char eof)))
|
||
|
|
(peek-char (optional iport -> (union char eof)))
|
||
|
|
(char-ready? (optional iport -> bool))
|
||
|
|
(write (optional oport -> void))
|
||
|
|
(display (_ optional oport -> void))
|
||
|
|
(newline (optional oport -> void))
|
||
|
|
(write-char (char optional oport -> void))
|
||
|
|
|
||
|
|
;; system interface
|
||
|
|
(load (str -> void) )
|
||
|
|
(transcript-on (str -> void) )
|
||
|
|
(transcript-off (-> void) )
|
||
|
|
|
||
|
|
;; predicates
|
||
|
|
(number? (_ -> bool) (predicate num))
|
||
|
|
(null? (_ -> bool) (predicate nil))
|
||
|
|
(char? (_ -> bool) (predicate char))
|
||
|
|
(symbol? (_ -> bool) (predicate sym))
|
||
|
|
(string? (_ -> bool) (predicate str))
|
||
|
|
(vector? (_ -> bool) (predicate vec))
|
||
|
|
(cvector? (_ -> bool) (predicate vec))
|
||
|
|
(pair? (_ -> bool) (predicate cons))
|
||
|
|
(procedure? (_ -> bool) (predicate lambda))
|
||
|
|
(eof-object? (_ -> bool) (predicate eof))
|
||
|
|
(input-port? (_ -> bool) (predicate iport))
|
||
|
|
(output-port? (_ -> bool) (predicate oport))
|
||
|
|
(boolean? (_ -> bool) (predicate true false))
|
||
|
|
(list? (_ -> bool) (predicate* (#t nil cons) (#f nil)))
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (language-add-boxes-etc!)
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
(read (optional iport -> (union eof sexp)))
|
||
|
|
(box? (_ -> bool) (predicate box))
|
||
|
|
(box (forall (a) (a -> (box a))))
|
||
|
|
(unbox (forall (a) ((box a) -> a)))
|
||
|
|
(set-box! (forall (a) ((box (! a)) a -> void)))
|
||
|
|
(void (-> void))
|
||
|
|
|
||
|
|
(add1 (num -> num) )
|
||
|
|
(sub1 (num -> num) )
|
||
|
|
(ormap (case->
|
||
|
|
(forall (a r)
|
||
|
|
((a -> r) (listof a) -> (union false r)))
|
||
|
|
(forall (a b r)
|
||
|
|
((a b -> r) (listof a) (listof b)
|
||
|
|
-> (union false r)))
|
||
|
|
(forall (a b c r)
|
||
|
|
((a b c -> r) (listof a) (listof b) (listof c)
|
||
|
|
-> (union false r)))
|
||
|
|
(forall (x r)
|
||
|
|
(((arglistof x) *-> r) (arglistof (listof x))
|
||
|
|
*-> (union false r)))))
|
||
|
|
(andmap (case->
|
||
|
|
(forall (a r)
|
||
|
|
((a -> r) (listof a) -> (union true r)))
|
||
|
|
(forall (a b r)
|
||
|
|
((a b -> r) (listof a) (listof b)
|
||
|
|
-> (union true r)))
|
||
|
|
(forall (a b c r)
|
||
|
|
((a b c -> r) (listof a) (listof b) (listof c)
|
||
|
|
-> (union true r)))
|
||
|
|
(forall (x r)
|
||
|
|
(((arglistof x) *-> r) (arglistof (listof x))
|
||
|
|
*-> (union true r)))))
|
||
|
|
|
||
|
|
(append! (forall (p)
|
||
|
|
((arglistof
|
||
|
|
(MU q (union (cons _ q) (cons _ p) (cons _ (! p)))))
|
||
|
|
*->
|
||
|
|
p)))
|
||
|
|
(exit (optional num -> empty))
|
||
|
|
(format (str _ *-> str))
|
||
|
|
(fprintf (oport str (arglistof _) *-> void))
|
||
|
|
(getenv (str -> (union str false)))
|
||
|
|
(list* (forall (l a)
|
||
|
|
((arglistof (union l (listof a)))
|
||
|
|
*-> (MU o (union l (cons a o))))))
|
||
|
|
(printf (str _ *-> void))
|
||
|
|
(putenv (str str -> bool))
|
||
|
|
(random (num -> num))
|
||
|
|
(random-seed (num -> void))
|
||
|
|
(reverse!
|
||
|
|
(forall
|
||
|
|
(l p a)
|
||
|
|
((arglistof (MU l (union p (cons a l) (cons _ (! p))))) *-> p)))
|
||
|
|
|
||
|
|
(pretty-print (_ optional oport -> void) )
|
||
|
|
(gensym (optional (union sym str) -> sym))
|
||
|
|
(sort (forall (a) ((a a -> _) (listof a) -> (listof a))))
|
||
|
|
|
||
|
|
(string->uninterned-symbol (str -> sym))
|
||
|
|
|
||
|
|
(remove (forall (a)
|
||
|
|
(a (listof a) optional (a a -> bool)
|
||
|
|
-> (listof a))))
|
||
|
|
(remq (forall (a) (a (listof a) -> (listof a))))
|
||
|
|
(remv (forall (a) (a (listof a) -> (listof a))))
|
||
|
|
|
||
|
|
(dynamic-wind (forall (b) ((-> _) (-> b) (-> _) -> b)))
|
||
|
|
(call/cc (forall (a) (((a *-> empty) ->* (mvalues a)) ->* (mvalues a))))
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (init-Chez-on-R4RS!)
|
||
|
|
|
||
|
|
(language-add-boxes-etc!)
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
(void (-> void) )
|
||
|
|
|
||
|
|
;; Standard Chez Scheme primitives.
|
||
|
|
(make-list (forall (a) (num a -> (listof a))))
|
||
|
|
(error (_ str _ *-> empty))
|
||
|
|
(expand-once (sexp -> sexp) )
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define this-directory (current-load-relative-directory))
|
||
|
|
|
||
|
|
(define (init-MzScheme-on-R4RS!)
|
||
|
|
|
||
|
|
;; Syntactic forms unimplemented
|
||
|
|
;; define-struct
|
||
|
|
;; objects
|
||
|
|
;; let/cc, let/rc
|
||
|
|
;; eval, comple
|
||
|
|
;; begin0
|
||
|
|
;; fluid-let
|
||
|
|
;; letrec*
|
||
|
|
;; make-global-value-list
|
||
|
|
;; time, unless
|
||
|
|
|
||
|
|
(language-add-boxes-etc!)
|
||
|
|
|
||
|
|
;; Could make weight a field of thread
|
||
|
|
(add-constructor! 'thread)
|
||
|
|
(add-constructor! 'hash-table #t #t)
|
||
|
|
(add-constructor! 'weak-box #f)
|
||
|
|
(add-constructor! 'regexp)
|
||
|
|
(add-constructor! 'arity-at-least #f)
|
||
|
|
(add-constructor! 'parameterization)
|
||
|
|
(add-constructor! 'semaphore)
|
||
|
|
(add-constructor! 'type-symbol)
|
||
|
|
(add-constructor! 'namespace)
|
||
|
|
(add-constructor! 'custodian)
|
||
|
|
(add-constructor! 'will-executor)
|
||
|
|
(add-constructor! 'tcp-listener)
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
;; MzSchemes f*cked up void :-)
|
||
|
|
(void (_ *-> void))
|
||
|
|
|
||
|
|
(eof eof)
|
||
|
|
|
||
|
|
;; Organization follows MzScheme Reference Manual
|
||
|
|
;; --- Programming Constructs
|
||
|
|
|
||
|
|
;; Void and Undefined
|
||
|
|
(void? (_ -> bool) (predicate void))
|
||
|
|
|
||
|
|
;; Number extensions
|
||
|
|
(bitwise-ior (num (arglistof num) *-> num))
|
||
|
|
(bitwise-and (num (arglistof num) *-> num))
|
||
|
|
(bitwise-xor (num (arglistof num) *-> num))
|
||
|
|
(bitwise-not (num (arglistof num) *-> num))
|
||
|
|
(arithmetic-shift (num num -> num))
|
||
|
|
|
||
|
|
;; --- Semaphores
|
||
|
|
|
||
|
|
(make-semaphore (num -> semaphore))
|
||
|
|
(semaphore? (semaphore -> bool) (predicate semaphore))
|
||
|
|
(semaphore-post (semaphore -> void))
|
||
|
|
(semaphore-wait (semaphore -> void))
|
||
|
|
(semaphore-try-wait (semaphore -> bool))
|
||
|
|
(semaphore-callback (semaphore (-> _) -> bool))
|
||
|
|
(input-port-post-semaphore (iport semaphore -> void))
|
||
|
|
|
||
|
|
;; --- Ports
|
||
|
|
;; Current ports
|
||
|
|
(current-input-port (optional iport -> iport))
|
||
|
|
(current-output-port (optional oport -> oport))
|
||
|
|
(current-error-port (optional oport -> oport))
|
||
|
|
|
||
|
|
(thread-input-port (-> iport))
|
||
|
|
(thread-output-port (-> oport))
|
||
|
|
(thread-error-port (-> iport))
|
||
|
|
|
||
|
|
(open-input-file (str optional sym -> iport))
|
||
|
|
(open-output-file (str optional sym optional sym -> oport))
|
||
|
|
|
||
|
|
(call-with-input-file
|
||
|
|
(forall (a) (str (iport -> a) optional sym -> a)))
|
||
|
|
(call-with-output-file
|
||
|
|
(forall (a) (str (oport -> a) optional sym optional sym -> a)))
|
||
|
|
(with-input-from-file
|
||
|
|
(forall (a) (str (-> a) optional sym -> a)))
|
||
|
|
(with-output-to-file
|
||
|
|
(forall (a) (str (-> a) optional sym optional sym -> a)))
|
||
|
|
|
||
|
|
;; String ports
|
||
|
|
(open-input-string (str -> iport))
|
||
|
|
(open-output-string (-> oport))
|
||
|
|
(get-output-string (oport -> str))
|
||
|
|
|
||
|
|
;; File ports
|
||
|
|
(flush-output (optional oport -> void))
|
||
|
|
(file-position ((union iport oport) optional num -> num))
|
||
|
|
|
||
|
|
;; Custom ports
|
||
|
|
(make-input-port ((-> char) (-> bool) (-> void) -> iport))
|
||
|
|
(make-output-port ((str -> void) (-> void) -> oport))
|
||
|
|
|
||
|
|
;; ---- Filesystem Utilities
|
||
|
|
;; Files
|
||
|
|
(file-exists? (str -> bool))
|
||
|
|
(delete-file (str -> bool))
|
||
|
|
(rename-file (str str -> bool))
|
||
|
|
(file-modify-seconds (str -> num))
|
||
|
|
(file-or-directory-permissions (str -> (listof sym)))
|
||
|
|
|
||
|
|
;; Hash Tables - fields are key and value
|
||
|
|
(make-hash-table (optional sym -> (hash-table empty empty)))
|
||
|
|
(make-hash-table-weak (optional sym -> (hash-table empty empty)))
|
||
|
|
(hash-table? (_ -> bool) (predicate hash-table))
|
||
|
|
(hash-table-put!
|
||
|
|
(forall (k v) ((hash-table (! k) (! v)) k v -> void)))
|
||
|
|
(hash-table-get
|
||
|
|
(forall (k v r) ((hash-table k v) _ optional (-> r) -> (union v r))))
|
||
|
|
(hash-table-remove!
|
||
|
|
(forall (k v) ((hash-table _ _) _ -> void)))
|
||
|
|
(hash-table-map
|
||
|
|
(forall (k v w) ((hash-table k v) (k v -> w) -> (listof w))))
|
||
|
|
(hash-table-for-each
|
||
|
|
(forall (k v) ((hash-table k v) (k v -> _) -> void)))
|
||
|
|
|
||
|
|
;; Weak boxes
|
||
|
|
(make-weak-box (forall (v) (v -> (weak-box (union v false)))))
|
||
|
|
(weak-box? (_ -> bool) (predicate weak-box))
|
||
|
|
(weak-box-value (forall (v) ((weak-box v) -> v)))
|
||
|
|
|
||
|
|
;; Regular expressions
|
||
|
|
(regexp (str -> regexp))
|
||
|
|
(regexp? (_ -> bool) (predicate regexp))
|
||
|
|
(regexp-match ((union str regexp) str
|
||
|
|
-> (union false (listof str))))
|
||
|
|
(regexp-match-positions
|
||
|
|
((union str regexp) str -> (union false (listof (cons num num)))))
|
||
|
|
(regexp-replace ((union str regexp) str str -> str))
|
||
|
|
(regexp-replace* ((union str regexp) str str -> str))
|
||
|
|
|
||
|
|
;; Global type variables don't work, so analysis of
|
||
|
|
;; exception handling is unsound here
|
||
|
|
|
||
|
|
;; Exceptions
|
||
|
|
;; (global:CEH GLOBAL-TYPE-VARIABLE)
|
||
|
|
;; (global:raised-values GLOBAL-TYPE-VARIABLE);
|
||
|
|
;;
|
||
|
|
;; (raise (global:raised-values -> empty))
|
||
|
|
;; (current-exception-handler
|
||
|
|
;; (optional (intersect global:CEH
|
||
|
|
;; (global:raised-values -> _))
|
||
|
|
;; -> global:CEH))
|
||
|
|
|
||
|
|
(raise (_ -> empty))
|
||
|
|
(current-exception-handler (optional (empty -> _) -> empty))
|
||
|
|
|
||
|
|
(make-exn:else (_ *-> empty))
|
||
|
|
|
||
|
|
;; Flow control
|
||
|
|
(call-with-escaping-continuation
|
||
|
|
(forall (a) (((a *-> empty) ->* (mvalues a)) ->* (mvalues a))))
|
||
|
|
|
||
|
|
(call/ec (forall (a) (((a *-> empty) ->* (mvalues a)) ->* (mvalues a))))
|
||
|
|
|
||
|
|
(values (forall (a) (a *->* (mvalues a))))
|
||
|
|
(call-with-values (forall (x r) ((list (nil *->* (mvalues x))
|
||
|
|
(x *->* (mvalues r)))
|
||
|
|
*->* (mvalues r))))
|
||
|
|
|
||
|
|
;; --------------------
|
||
|
|
|
||
|
|
;; Arity
|
||
|
|
(arity ((empty *-> _) ->
|
||
|
|
(rec ([r (union num (arity-at-least num))])
|
||
|
|
(union r (listof r)))))
|
||
|
|
(arity-at-least? (_ -> bool) (predicate arity-at-least))
|
||
|
|
(arity-at-least-value (forall (v) ((arity-at-least v) -> v)))
|
||
|
|
|
||
|
|
;; Global and Constant Names
|
||
|
|
(defined? (sym -> bool))
|
||
|
|
|
||
|
|
;; Evaluation Handler - no can type :-
|
||
|
|
|
||
|
|
;; Handlers
|
||
|
|
(current-print (optional (empty -> void) -> (_ -> void)))
|
||
|
|
(current-prompt-read
|
||
|
|
(optional (-> (union eof sexp)) -> (-> (union eof sexp))))
|
||
|
|
(error ((union sym str) (arglistof _) *-> empty))
|
||
|
|
|
||
|
|
;; ### problems with types for handlers
|
||
|
|
|
||
|
|
(error-display-handler (optional (empty -> void) -> (_ -> void)))
|
||
|
|
(error-escape-handler (optional (-> _) -> (-> empty)))
|
||
|
|
(exit-handler (optional (num -> _) -> (num -> empty)))
|
||
|
|
|
||
|
|
;; User Breaks
|
||
|
|
(user-break-poll-handler (optional (-> bool) -> (-> bool)))
|
||
|
|
(break-enabled (optional _ -> bool))
|
||
|
|
(dynamic-enable-break (forall (v) ((-> v) -> v)))
|
||
|
|
|
||
|
|
;; Compilation
|
||
|
|
(compile-file ((union str iport) (union str oport) _ -> void))
|
||
|
|
|
||
|
|
;; Dynamic extensions
|
||
|
|
(load-extension (str -> void))
|
||
|
|
|
||
|
|
;; Operating System Processes
|
||
|
|
(system (str -> bool))
|
||
|
|
(sytem* (str (arglistof str) *-> bool))
|
||
|
|
(process (str ->
|
||
|
|
(cons iport
|
||
|
|
(cons oport
|
||
|
|
(cons num (cons iport nil))))))
|
||
|
|
(process* (str (arglistof str) *->
|
||
|
|
(cons iport
|
||
|
|
(cons oport
|
||
|
|
(cons num (cons iport nil))))))
|
||
|
|
|
||
|
|
;; Misc
|
||
|
|
(banner (-> str))
|
||
|
|
(gensym (optional (union str sym) -> sym))
|
||
|
|
(load/cd (str -> void))
|
||
|
|
(load-with-cd (str -> void))
|
||
|
|
(promise? (_ -> bool) (predicate promise))
|
||
|
|
(read-eval-print-loop (-> void))
|
||
|
|
(read-line (optional iport -> (union str eof)))
|
||
|
|
(system-type (-> sym))
|
||
|
|
(version (-> str))
|
||
|
|
|
||
|
|
;; Signature stuff
|
||
|
|
(#%unit-with-signature-unit empty)
|
||
|
|
(#%make-unit-with-signature empty)
|
||
|
|
(#%verify-linkage-signature-match empty)
|
||
|
|
|
||
|
|
;; --------------------------------------------------------------------
|
||
|
|
;; the following is structured after the MzScheme ref manual 5.9.97
|
||
|
|
|
||
|
|
;; ------ basic data extensions
|
||
|
|
;; ---- procedures
|
||
|
|
;; -- primitives
|
||
|
|
(primitive? (_ -> bool) (predicate* (#t lambda) _))
|
||
|
|
(primitive-name ((empty *->* _) -> sym))
|
||
|
|
(primitive-result-arity? ((empty *->* _) -> num))
|
||
|
|
(primitive-result-arity? ((empty *->* _) -> bool))
|
||
|
|
|
||
|
|
;; ------ structures
|
||
|
|
;; ---- structure utilities
|
||
|
|
(struct? (_ -> bool) (predicate structure:))
|
||
|
|
(struct-length (structure: -> num))
|
||
|
|
(struct-type? (-> bool))
|
||
|
|
(struct-constructor-procedure? (-> bool))
|
||
|
|
(struct-predicate-procedure? (-> bool))
|
||
|
|
(struct-selector-procedure? (-> bool))
|
||
|
|
(struct-setter-procedure? (-> bool))
|
||
|
|
|
||
|
|
;; ------ classes and objects
|
||
|
|
;; ---- object utilities
|
||
|
|
|
||
|
|
(object? (_ -> bool))
|
||
|
|
(class? (_ -> bool) (predicate internal-class))
|
||
|
|
(is-a? (_ _ -> bool))
|
||
|
|
(make-object
|
||
|
|
(forall (args u o f v)
|
||
|
|
( (internal-class u o (args *->* _) (! u) (! o) o (! o) (! o) v)
|
||
|
|
args
|
||
|
|
*->
|
||
|
|
(union o v))))
|
||
|
|
(ivar-in-class? (_ _ -> bool))
|
||
|
|
(uq-ivar (forall (i) ((all-ivars i) _ -> i)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;; ------ units
|
||
|
|
(unit/sig->unit (forall (a) (a -> a)))
|
||
|
|
(unit? (_ -> bool))
|
||
|
|
|
||
|
|
;; ------ threads and namespaces
|
||
|
|
;; ---- threads
|
||
|
|
(thread ((-> _) -> thread))
|
||
|
|
;; -- thread utilities
|
||
|
|
(current-thread (-> thread))
|
||
|
|
(thread? (_ -> bool) (predicate thread))
|
||
|
|
(sleep (num -> void))
|
||
|
|
(thread-running? (thread -> bool))
|
||
|
|
(thread-wait (thread -> void))
|
||
|
|
(kill-thread (thread -> void))
|
||
|
|
(break-thread (thread -> void))
|
||
|
|
(thread-weight (case->
|
||
|
|
(thread -> num)
|
||
|
|
(thread num -> void)))
|
||
|
|
;; ---- semaphores
|
||
|
|
(make-semaphore (optional num -> semaphore))
|
||
|
|
(semaphore? (_ -> bool) (predicate semaphore))
|
||
|
|
(semaphore-post (semaphore -> void))
|
||
|
|
(semaphore-wait (semaphore -> void))
|
||
|
|
(semaphore-try-wait? (semaphore -> bool))
|
||
|
|
(semaphore-wait/enable-break (semaphore -> void))
|
||
|
|
(semaphore-callback (semaphore (-> _) -> void))
|
||
|
|
(input-port-post-semaphore (iport semaphore -> void))
|
||
|
|
|
||
|
|
;; ---- parameterization
|
||
|
|
;; -- built-in parameters
|
||
|
|
;; loading
|
||
|
|
(current-load-relative-directory (union str false))
|
||
|
|
;; -- exceptions
|
||
|
|
(debug-info-handler (-> (-> void)))
|
||
|
|
;; libraries
|
||
|
|
(current-library-collections-paths
|
||
|
|
(case->
|
||
|
|
((listof str) -> void)
|
||
|
|
(-> (listof str))))
|
||
|
|
(require-library-use-compiled (case-> (bool -> void) (-> bool)))
|
||
|
|
;; parsing
|
||
|
|
(read-case-sensitive (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-square-bracket-as-paren (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-curly-brace-as-paren (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-accept-box (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-accept-type-symbol (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-accept-compiled (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-accept-bar-quote (case-> (-> bool) (bool -> void)))
|
||
|
|
(read-accept-graph (case-> (-> bool) (bool -> void)))
|
||
|
|
;; printing
|
||
|
|
(print-graph (case-> (-> bool) (bool -> void)))
|
||
|
|
(print-struct (case-> (-> bool) (bool -> void)))
|
||
|
|
(print-box (case-> (-> bool) (bool -> void)))
|
||
|
|
|
||
|
|
;; -- parameter utilities
|
||
|
|
;; We should arguably have a separate type for parameter procedures
|
||
|
|
(make-parameter (forall (x i)
|
||
|
|
(x optional (i -> x)
|
||
|
|
-> (optional i -> (union x void)))))
|
||
|
|
(parameter? (_ -> bool))
|
||
|
|
(parameter-procedure=? (_ _ -> bool))
|
||
|
|
|
||
|
|
;; -- parameterization utilities
|
||
|
|
(make-parameterization (parameterization -> parameterization))
|
||
|
|
(current-parameterization
|
||
|
|
(case->
|
||
|
|
(parameterization -> void)
|
||
|
|
(-> parameterization)))
|
||
|
|
(parameterization? (-> bool) (predicate parameterization))
|
||
|
|
(in-parameterization (forall (param)
|
||
|
|
(parameterization
|
||
|
|
param
|
||
|
|
optional _
|
||
|
|
-> param)))
|
||
|
|
(with-parameterization (parameterization (-> result) -> result))
|
||
|
|
(with-new-parameterization ((-> result) -> result))
|
||
|
|
(parameterization-branch-handler (-> parameterization))
|
||
|
|
|
||
|
|
;; ---- custodians
|
||
|
|
(make-custodian (custodian -> custodian))
|
||
|
|
(custodian-shutdown-all (custodian -> void))
|
||
|
|
(custodian? (_ -> bool) (predicate custodian))
|
||
|
|
(current-custodian (case->
|
||
|
|
(-> custodian)
|
||
|
|
(custodian -> void)))
|
||
|
|
|
||
|
|
;; ---- namespaces
|
||
|
|
(make-namespace ((listof sym) *-> namespace))
|
||
|
|
(namespace? (_ -> bool) (predicate namespace))
|
||
|
|
(current-namespace (case->
|
||
|
|
(-> namespace)
|
||
|
|
(namespace -> void)))
|
||
|
|
|
||
|
|
;; ------ System utilities
|
||
|
|
;; ---- ports
|
||
|
|
;; ---- filesystem utilities
|
||
|
|
;; -- pathnames
|
||
|
|
(build-path (str (arglistof (union str sym)) *-> str))
|
||
|
|
(absolute-path? (str -> bool))
|
||
|
|
(relative-path? (str -> bool))
|
||
|
|
(complete-path? (str -> bool))
|
||
|
|
(path->complete-path (str -> str))
|
||
|
|
(resolve-path (str -> str))
|
||
|
|
(expand-path (str -> str))
|
||
|
|
(normal-case-path (str -> str))
|
||
|
|
|
||
|
|
(split-path (str -> (union str sym false)
|
||
|
|
(union str sym)
|
||
|
|
bool))
|
||
|
|
(find-executable-path (str str -> str))
|
||
|
|
;; -- directories
|
||
|
|
(current-directory (case->
|
||
|
|
(str -> void)
|
||
|
|
(-> str)))
|
||
|
|
(current-drive (-> (union bool str)))
|
||
|
|
(directory-exists? (str -> bool))
|
||
|
|
(make-directory (str -> bool))
|
||
|
|
(delete-directory (str -> bool))
|
||
|
|
(directory-list (optional str -> (listof str)))
|
||
|
|
(filesystem-root-list (-> (listof str)))
|
||
|
|
|
||
|
|
;; ---- networking
|
||
|
|
(tcp-listen (num optional num -> tcp-listener))
|
||
|
|
(tcp-connect (str num ->* (mvalues (list iport oport))))
|
||
|
|
(tcp-accept (tcp-listener ->* (mvalues (list iport oport))))
|
||
|
|
(tcp-accept-ready? (tcp-listener -> bool))
|
||
|
|
(tcp-close (tcp-listener -> void))
|
||
|
|
(tcp-listener? (_ -> bool) (predicate tcp-listener))
|
||
|
|
(tcp-port-send-waiting? (oport -> bool))
|
||
|
|
|
||
|
|
;; ---- time
|
||
|
|
;; -- real time
|
||
|
|
(current-seconds (-> num))
|
||
|
|
;(seconds->date (num -> (structure:date num num num num
|
||
|
|
; num num num num bool)))
|
||
|
|
;; -- machine time
|
||
|
|
(current-milliseconds(-> num))
|
||
|
|
(current-process-milliseconds(-> num))
|
||
|
|
(current-gc-milliseconds(-> num))
|
||
|
|
;; -- timing execution
|
||
|
|
(time-apply (forall (a) ((-> a) -> (list a num num))))
|
||
|
|
|
||
|
|
;; ---- operating system processes
|
||
|
|
(system (str -> bool))
|
||
|
|
(system* (str (listof str) *-> bool))
|
||
|
|
(execute (str -> void))
|
||
|
|
(execute* (str (listof str) *-> void))
|
||
|
|
(process (str -> (list iport oport num iport (sym -> sym))))
|
||
|
|
(process* (str (listof str)
|
||
|
|
*-> (list iport oport num iport (sym -> sym))))
|
||
|
|
|
||
|
|
|
||
|
|
;; ------ memory management
|
||
|
|
;; ---- will executors
|
||
|
|
(make-will-executor (-> will-executor))
|
||
|
|
(will-executor? (_ -> bool) (predicate will-executor))
|
||
|
|
(register-will (forall (a)
|
||
|
|
(a (a ->* _) optional will-executor
|
||
|
|
-> void)))
|
||
|
|
(will-executor-try (will-executor -> void))
|
||
|
|
(current-will-executor
|
||
|
|
(case-> (will-executor -> void) (-> will-executor)))
|
||
|
|
|
||
|
|
;; ---- garbage collection
|
||
|
|
(collect-garbage (-> void))
|
||
|
|
(dump-memory-stats (-> void))
|
||
|
|
|
||
|
|
;; ------ macros
|
||
|
|
;; ---- expanding macros
|
||
|
|
(syntax? (_ -> bool))
|
||
|
|
(macro? (_ -> bool))
|
||
|
|
(id-macro? (_ -> bool))
|
||
|
|
|
||
|
|
;; ------ support facilities
|
||
|
|
;; ---- input parsing
|
||
|
|
(type-symbol? (_ -> bool) (predicate type-symbol))
|
||
|
|
(string->type-symbol (str -> type-symbol))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;; --------------------------------------------------------------------
|
||
|
|
(print (_ optional oport -> void))
|
||
|
|
(make-pipe (->* (mvalues (list iport oport))))
|
||
|
|
|
||
|
|
;; --------------------------------------------------------------------
|
||
|
|
;; MzScheme stand-alone definitions
|
||
|
|
(program str)
|
||
|
|
(argv (vec str))
|
||
|
|
|
||
|
|
))
|
||
|
|
|
||
|
|
|
||
|
|
'(language-add-boot-file
|
||
|
|
(build-path
|
||
|
|
(or this-directory
|
||
|
|
(build-path
|
||
|
|
(collection-path "mrspidey") ; MATTHEW: got rid of plt-home
|
||
|
|
"Sba"))
|
||
|
|
"exn-hierarchy.ss"))
|
||
|
|
)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (init-MrEd-on-MzScheme!)
|
||
|
|
(language-add-boot-file "~/Spidey/wx/all.sig")
|
||
|
|
)
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (init-mzlib!)
|
||
|
|
|
||
|
|
(constructor-alias! 'null 'nil)
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
'(
|
||
|
|
(require-library (str -> void))
|
||
|
|
(=? ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(<? ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(>? ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(<=? ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(>=? ((arg num (arg num (arglistof num))) *-> bool) )
|
||
|
|
(1+ (num -> num))
|
||
|
|
(1- (num -> num))
|
||
|
|
|
||
|
|
(null nil)
|
||
|
|
(cons? (_ -> bool) (predicate cons))
|
||
|
|
(gentemp (-> sym) )
|
||
|
|
(bound? (sym -> bool))
|
||
|
|
(flush-output-port (optional oport -> void))
|
||
|
|
(real-time (-> num))
|
||
|
|
|
||
|
|
;; --- file.ss
|
||
|
|
(build-absolute-path (str (arglistof (union str sym)) -> str))
|
||
|
|
(build-relative-path (str (arglistof (union str sym)) -> str))
|
||
|
|
(explode-path (str -> (listof str)))
|
||
|
|
(filename-extension (str -> str))
|
||
|
|
(find-relative-path (str str -> str))
|
||
|
|
(normalize-path (str optional str -> str))
|
||
|
|
|
||
|
|
;; --- function.ss
|
||
|
|
(first (forall (a) ((cons a _) -> a)))
|
||
|
|
(second (forall (a) ((cons _ (cons a _)) -> a)))
|
||
|
|
(third (forall (a) ((cons _ (cons _ (cons a _))) -> a)))
|
||
|
|
(fourth (forall (a) ((cons _ (cons _ (cons _ (cons a _)))) -> a)))
|
||
|
|
(fifth (forall (a) ((cons _ (cons _ (cons _ (cons _ (cons a _))))) -> a)))
|
||
|
|
(sixth (forall (a) ((cons _ (cons _ (cons _ (cons _ (cons _ (cons a _)))))) -> a)))
|
||
|
|
(seventh (forall (a) ((cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons a _))))))) -> a)))
|
||
|
|
(eighth (forall (a) ((cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons a _)))))))) -> a)))
|
||
|
|
|
||
|
|
(build-list (forall (a) (num (num -> a) -> (listof a))))
|
||
|
|
(build-string (num (num -> char) -> str))
|
||
|
|
(build-vector (forall (a) (num (num -> a) -> (vec a))))
|
||
|
|
(cons? (_ -> bool) (predicate cons))
|
||
|
|
(compose (forall (x y z) ((x ->* y) (y *->* z) -> (x ->* z))))
|
||
|
|
|
||
|
|
(dynamic-disable-break (forall (v) ((-> v) -> v)))
|
||
|
|
(dynamic-wind/protect-break
|
||
|
|
(forall (v) ((-> _) (-> v) (-> _) -> v)))
|
||
|
|
|
||
|
|
(foldl (case->
|
||
|
|
(forall (a z) ((a z -> z) z (listof a) -> z))
|
||
|
|
(forall (a b z)
|
||
|
|
((a b z -> z) z (listof a) (listof b) -> z))
|
||
|
|
(forall
|
||
|
|
(a b c z)
|
||
|
|
((a b c z -> z) z (listof a) (listof b) (listof c) -> z))
|
||
|
|
(forall
|
||
|
|
(x z)
|
||
|
|
(((arglistof x) *-> z) z (listof (arglistof x)) *-> z))))
|
||
|
|
(foldr (case->
|
||
|
|
(forall (a z) ((a z -> z) z (listof a) -> z))
|
||
|
|
(forall (a b z)
|
||
|
|
((a b z -> z) z (listof a) (listof b) -> z))
|
||
|
|
(forall
|
||
|
|
(a b c z)
|
||
|
|
((a b c z -> z) z (listof a) (listof b) (listof c) -> z))
|
||
|
|
(forall
|
||
|
|
(x z)
|
||
|
|
(((arglistof x) *-> z) z (listof (arglistof x)) *-> z))))
|
||
|
|
(ignore-errors (forall (x) ((-> x) -> (union x void))))
|
||
|
|
(last-pair (forall (p l)
|
||
|
|
( (MU l (union p (cons _ l))) -> p)))
|
||
|
|
(loop-until (forall (x)
|
||
|
|
(x (x -> _) (x -> x) (x -> _) -> void)))
|
||
|
|
|
||
|
|
(identity (forall (x) (x -> x)))
|
||
|
|
(quicksort (forall (a) ((listof a) (a a -> _) -> (listof a))))
|
||
|
|
|
||
|
|
;; --- pretty.ss
|
||
|
|
(pretty-print (_ optional oport
|
||
|
|
optional num
|
||
|
|
optional bool
|
||
|
|
optional bool
|
||
|
|
optional num
|
||
|
|
-> void))
|
||
|
|
(pretty-print-columns (optional num -> (union num void)))
|
||
|
|
(pretty-print-depth (optional num -> (union num void)))
|
||
|
|
;; NOT pretty-print-handler
|
||
|
|
|
||
|
|
;; --- strings.ss
|
||
|
|
;; NOT eval-string
|
||
|
|
(expr->string (_ -> str))
|
||
|
|
(newline-string (-> str))
|
||
|
|
(read-string (str -> sexp))
|
||
|
|
(read-string-all (str -> (listof sexp)))
|
||
|
|
;;(regexp-match ((union str regexp) str -> bool))
|
||
|
|
(string-lowercase! (str -> str))
|
||
|
|
(string-uppercase! (str -> str))
|
||
|
|
|
||
|
|
(match:error (_ optional _ -> empty))
|
||
|
|
; (match:andmap (case->
|
||
|
|
; (forall (a r)
|
||
|
|
; ((a -> r) (listof a) -> (union true r)))
|
||
|
|
; (forall (a b r)
|
||
|
|
; ((a b -> r) (listof a) (listof b)
|
||
|
|
; -> (union true r)))
|
||
|
|
; (forall (a b c r)
|
||
|
|
; ((a b c -> r) (listof a) (listof b) (listof c)
|
||
|
|
; -> (union true r)))
|
||
|
|
; (forall (x r)
|
||
|
|
; (((arglistof x) *-> r) (arglistof (listof x))
|
||
|
|
; *-> (union true r)))))
|
||
|
|
;
|
||
|
|
)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (init-zmath!)
|
||
|
|
;; --- zmath.ss
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
(conjugate (num -> num))
|
||
|
|
(cosh (num -> num))
|
||
|
|
(make-rectangular (num num -> num) )
|
||
|
|
(sinh (num -> num))
|
||
|
|
(zabs (num -> num))
|
||
|
|
(zacos (num -> num))
|
||
|
|
(zasin (num -> num))
|
||
|
|
(zatan (num -> num))
|
||
|
|
(zcos (num -> num))
|
||
|
|
(zexp (num -> num))
|
||
|
|
(zlog (num -> num))
|
||
|
|
(zsin (num -> num))
|
||
|
|
(zsqrt (num -> num))
|
||
|
|
(ztan (num -> num))
|
||
|
|
(pi 3.14159)
|
||
|
|
(e 2.71828)
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (init-DrScheme-on-MzScheme!)
|
||
|
|
|
||
|
|
(add-constructor! '2vec #t)
|
||
|
|
(add-constructor! 'viewport)
|
||
|
|
(add-constructor! 'posn #t #t)
|
||
|
|
(add-constructor! 'rgb #t #t #t)
|
||
|
|
(add-constructor! 'mouse-click)
|
||
|
|
|
||
|
|
(add-constructor! 'module #f)
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
(match:error (_ -> empty))
|
||
|
|
|
||
|
|
(make-rs:module (forall (x) (x -> (module x))))
|
||
|
|
|
||
|
|
;; Can't do anything smarter, even though b must be a list
|
||
|
|
;; Need to implement *
|
||
|
|
;(cons (forall (a b) (a (union b nil (cons _ _))-> (cons a b))))
|
||
|
|
;(set-cdr! (forall (b) ((cons _ (! b)) b -> void)))
|
||
|
|
(atom? (_ -> bool)
|
||
|
|
(predicate* (#f cons) (#t cons)))
|
||
|
|
(build-list (forall (a) (num (num -> a) -> (listof a))))
|
||
|
|
(build-string (num (num -> char) -> str))
|
||
|
|
|
||
|
|
;; Vectors
|
||
|
|
(build-vector (forall (a) (num (num -> a) -> (vec a))))
|
||
|
|
(tabulate (forall (a) (num (num -> a) -> (vec a))))
|
||
|
|
(foreach! (forall
|
||
|
|
(v a b)
|
||
|
|
((union v (vec a) (vec (! b))) (a num -> b) -> v)))
|
||
|
|
(2vector (forall (a) ((listof (listof a)) -> (2vec a))))
|
||
|
|
(2make-vector (num num -> (2vec void)))
|
||
|
|
(2vector-init (forall (a) (num num (num num -> a) -> (2vec a))))
|
||
|
|
(2vector-ref (forall (a) ((2vec a) num num -> a)))
|
||
|
|
(2vector-set! (forall (a) ((2vec (! a)) num num a -> void)))
|
||
|
|
(2foreach! (forall
|
||
|
|
(v a b)
|
||
|
|
((union v (2vec a) (2vec (! b))) (a num num -> b) -> v)))
|
||
|
|
(2vector-print (forall (a) ((2vec a) ((vec a) -> void) -> void)))
|
||
|
|
|
||
|
|
;; --------------------
|
||
|
|
;; SIXlib
|
||
|
|
(open-viewport (str num optional num optional num -> viewport))
|
||
|
|
(open-pixmap (str num optional num optional num -> viewport))
|
||
|
|
(close-viewport (viewport -> void))
|
||
|
|
|
||
|
|
(make-posn (forall (x y)
|
||
|
|
((union num x) (union num y) -> (posn x y))))
|
||
|
|
(posn-x (forall (x) ((posn x _) -> x)))
|
||
|
|
(posn-y (forall (y) ((posn _ y) -> y)))
|
||
|
|
(posn? ((union (posn _ _) _) -> bool) (predicate posn))
|
||
|
|
|
||
|
|
(get-pixel (viewport -> ((posn _ _) -> num)))
|
||
|
|
|
||
|
|
(make-rgb (forall (r g b)
|
||
|
|
((union num r) (union num g) (union num b)
|
||
|
|
-> (rgb r g b))))
|
||
|
|
(rgb-red (forall (r) ((rgb r _ _) -> r)))
|
||
|
|
(rgb-green (forall (g) ((rgb _ g _) -> g)))
|
||
|
|
(rgb-blue (forall (b) ((rgb _ _ b) -> b)))
|
||
|
|
(rgb? ((union (rgb _ _ _) _) -> bool)
|
||
|
|
(predicate rgb))
|
||
|
|
(change-color (num (rgb _ _ _) -> void))
|
||
|
|
(default-display-is-color? (-> bool))
|
||
|
|
|
||
|
|
;; --- Drawing ops
|
||
|
|
(draw-viewport (viewport -> (optional num -> void)))
|
||
|
|
(draw-pixel (viewport -> ((posn _ _) optional num -> void)))
|
||
|
|
(draw-line (viewport ->
|
||
|
|
((posn _ _) (posn _ _) optional num -> void)))
|
||
|
|
(draw-string (viewport -> ((posn _ _) str optional num -> void)))
|
||
|
|
(draw-pixmap (viewport -> (str (posn _ _) -> void)))
|
||
|
|
|
||
|
|
(clear-viewport (viewport -> (-> void)))
|
||
|
|
(clear-pixel (viewport -> ((posn _ _) -> void)))
|
||
|
|
(clear-line (viewport -> ((posn _ _) (posn _ _) -> void)))
|
||
|
|
(clear-string (viewport -> ((posn _ _) str -> void)))
|
||
|
|
(clear-pixmap (viewport -> (str (posn _ _) -> void)))
|
||
|
|
|
||
|
|
(flip-viewport (viewport -> (-> void)))
|
||
|
|
(flip-pixel (viewport -> ((posn _ _) -> void)))
|
||
|
|
(flip-line (viewport -> ((posn _ _) (posn _ _) -> void)))
|
||
|
|
(flip-string (viewport -> ((posn _ _) str -> void)))
|
||
|
|
(flip-pixmap (viewport -> (str (posn _ _) -> void)))
|
||
|
|
|
||
|
|
;; --- Mouse ops
|
||
|
|
(get-mouse-click (viewport -> mouse-click))
|
||
|
|
(ready-mouse-click (viewport -> (union false mouse-click)))
|
||
|
|
(ready-mouse-release (viewport -> (union false mouse-click)))
|
||
|
|
(query-mouse-posn (viewport -> (union false (posn num num))))
|
||
|
|
(mouse-click-posn (mouse-click -> (posn num num)))
|
||
|
|
(left-mouse-click? (mouse-click -> bool))
|
||
|
|
(middle-mouse-click? (mouse-click -> bool))
|
||
|
|
(right-mouse-click? (mouse-click -> bool))
|
||
|
|
(viewport-flush-input (viewport -> void))
|
||
|
|
|
||
|
|
;; --------------------
|
||
|
|
;; Module values
|
||
|
|
|
||
|
|
;; Miscellaneous
|
||
|
|
(rs:major-version num)
|
||
|
|
(rs:minor-version num)
|
||
|
|
(rs:date str)
|
||
|
|
(rs:banner-lines (str -> void))
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (init-smart-numops!)
|
||
|
|
|
||
|
|
(st:constants #t)
|
||
|
|
|
||
|
|
(add-constructor! 'apply+ #f)
|
||
|
|
(add-constructor! 'apply- #f)
|
||
|
|
(add-constructor! 'apply* #f)
|
||
|
|
(add-constructor! 'apply/ #f)
|
||
|
|
|
||
|
|
;; The following are binary ops
|
||
|
|
;; they return the elements of the first set that satisfy the
|
||
|
|
;; appropriate relation wrt some element of the second set
|
||
|
|
(add-constructor! '= #f #f)
|
||
|
|
(add-constructor! 'not= #f #f)
|
||
|
|
(add-constructor! '< #f #f)
|
||
|
|
(add-constructor! '<= #f #f)
|
||
|
|
(add-constructor! '> #f #f)
|
||
|
|
(add-constructor! '>= #f #f)
|
||
|
|
|
||
|
|
(record-super-constructor! 'num 'apply+)
|
||
|
|
(record-super-constructor! 'num 'apply-)
|
||
|
|
(record-super-constructor! 'num 'apply*)
|
||
|
|
(record-super-constructor! 'num 'apply/)
|
||
|
|
|
||
|
|
(record-super-constructor! 'num '=)
|
||
|
|
(record-super-constructor! 'num 'not=)
|
||
|
|
(record-super-constructor! 'num '<)
|
||
|
|
(record-super-constructor! 'num '<=)
|
||
|
|
(record-super-constructor! 'num '>)
|
||
|
|
(record-super-constructor! 'num '>=)
|
||
|
|
|
||
|
|
(install-output-type-expander!
|
||
|
|
(match-lambda
|
||
|
|
[('apply+ ('list . t*)) `(+ ,@t*)]
|
||
|
|
[('apply* ('list . t*)) `(* ,@t*)]
|
||
|
|
[('apply- ('list . t*)) `(- ,@t*)]
|
||
|
|
[('apply/ ('list . t*)) `(/ ,@t*)]
|
||
|
|
[('+ t 1) `(add1 ,t)]
|
||
|
|
[('- t 1) `(sub1 ,t)]
|
||
|
|
[type type]))
|
||
|
|
|
||
|
|
(let* ([bin-pred
|
||
|
|
(lambda (op) (lambda (x y)
|
||
|
|
'(pretty-debug
|
||
|
|
`(make-constructed-Tvar ,op
|
||
|
|
,(Tvar-name x)
|
||
|
|
,(Tvar-name y)))
|
||
|
|
(make-constructed-Tvar op x y)))]
|
||
|
|
[bin-pred-r
|
||
|
|
(lambda (op) (lambda (x y) ((bin-pred op) y x)))]
|
||
|
|
[comparator-helper-fn
|
||
|
|
(lambda (op reverse-op negation-op negation-reverse-op)
|
||
|
|
;; eg < > >= <=
|
||
|
|
(lambda (before after Tvar bool)
|
||
|
|
'(printf "before ~s after ~s Tvar ~s~n"
|
||
|
|
(map Tvar-name before)
|
||
|
|
(map Tvar-name after)
|
||
|
|
(Tvar-name Tvar))
|
||
|
|
(if bool
|
||
|
|
(foldl (bin-pred-r op)
|
||
|
|
(foldl (bin-pred-r reverse-op) Tvar before)
|
||
|
|
after)
|
||
|
|
(match (list before after)
|
||
|
|
[((arg) ()) ((bin-pred negation-reverse-op) Tvar arg)]
|
||
|
|
[(() (arg)) ((bin-pred negation-op) Tvar arg)]
|
||
|
|
[_ Tvar]))))])
|
||
|
|
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
;; numbers
|
||
|
|
(+ (forall (a) ((union a (arglistof num)) *-> (apply+ a))))
|
||
|
|
(* (forall (a) ((union a (arglistof num)) *-> (apply* a))))
|
||
|
|
(- (forall (a) ((union a (arg num (arglistof num)))
|
||
|
|
*-> (apply- a))))
|
||
|
|
(/ (forall (a)
|
||
|
|
((union a (arg num (arglistof num)))
|
||
|
|
*-> (apply/ a))))
|
||
|
|
(add1 (forall (a) ((union a num) -> (apply+ (list a 1)))))
|
||
|
|
(sub1 (forall (a) ((union a num) -> (apply- (list a 1)))))
|
||
|
|
|
||
|
|
(= ((arg num (arg num (arglistof num))) *-> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(comparator-helper-fn '= '= 'not= 'not=)))
|
||
|
|
(< ((arg num (arg num (arglistof num))) *-> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(comparator-helper-fn '< '> '>= '<=)))
|
||
|
|
(> ((arg num (arg num (arglistof num))) *-> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(comparator-helper-fn '> '< '<= '>=)))
|
||
|
|
(<= ((arg num (arg num (arglistof num))) *-> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(comparator-helper-fn '<= '>= '> '<)))
|
||
|
|
(>= ((arg num (arg num (arglistof num))) *-> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(comparator-helper-fn '>= '<= '< '>)))
|
||
|
|
(zero? (num -> bool)
|
||
|
|
(predicate-fn
|
||
|
|
,(lambda (before after Tvar bool)
|
||
|
|
(let ([Tvar-zero (mk-Tvar 'zero?)])
|
||
|
|
(new-AV! Tvar-zero (traverse-const-exact 0))
|
||
|
|
(if bool
|
||
|
|
Tvar-zero
|
||
|
|
(make-constructed-Tvar 'not= Tvar Tvar-zero))))))
|
||
|
|
|
||
|
|
))))
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (init-vectors-w/-length)
|
||
|
|
|
||
|
|
(add-constructor! 'vect #t #f)
|
||
|
|
(add-default-primitives!
|
||
|
|
`(
|
||
|
|
(make-vector (case->
|
||
|
|
(forall (n) ((union num n) -> (vect void n)))
|
||
|
|
(forall (a n) ((union num n) a -> (vect a n)))
|
||
|
|
(forall (a n) ((union num n) optional a -> (vect (union a void) n)))))
|
||
|
|
(vector (forall (a) ((arglistof a) *-> (vect a num))))
|
||
|
|
(vector-length (forall (a n) ((vect a n) -> n)))
|
||
|
|
(vector-ref (forall (a) ((vect a _) num -> a)))
|
||
|
|
(vector-set! (forall (a) ((vect (! a) _) num a -> void)))
|
||
|
|
(vector->list (forall (a) ((vect a _) -> (listof a))))
|
||
|
|
(list->vector (forall (a) ((listof a) -> (vect a num))))
|
||
|
|
(vector-fill! (forall (a) ((vect (! a) _) a -> void)))
|
||
|
|
(vector? (_ -> bool) (predicate vect))
|
||
|
|
(build-vector (forall (a) ((union num n) (num -> a) -> (vect a n))))
|
||
|
|
(tabulate (forall (a) ((union num n) (num -> a) -> (vect a n))))
|
||
|
|
(foreach! (forall
|
||
|
|
(v a b)
|
||
|
|
((union v (vect a _) (vect (! b) _)) (a num -> b)
|
||
|
|
-> v)))
|
||
|
|
(2vector-print (forall (a) ((2vec a) ((vect a _) -> void) -> void)))
|
||
|
|
|
||
|
|
)))
|