suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Various bug fixes, for dynamic, beginner, and example boxes

Browse Source 
svn: r389
This commit is contained in:
Kathy Gray 2005-07-18 03:40:45 +00:00
parent a1e66bb2f2
commit 4d63cd4701
5 changed files with 145 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/profj/build-info.ss
View File

@ -35,17 +35,25 @@
(htdch-lib? (ormap (lambda (p) (same-base-dir? dir p))
(map (lambda (p) (build-path p "htdch"))
(current-library-collection-paths))))
(scheme-lib? (ormap (lambda (p) (same-base-dir? dir p))
(current-library-collection-paths)))
(access (lambda (name)
(cond
(profj-lib? `(lib ,name "profj" "libs" ,@path))
(htdch-lib? `(lib ,name "htdch" ,@path))
(htdch-lib?
`(lib ,name "htdch" ,@(if scheme? (cdddr path) path)))
(scheme-lib? `(lib ,name ,@(cddr path)))
((and local? (not (to-file))) name)
(else `(file ,(path->string (build-path dir name)))))))
(make-name (lambda ()
(let ((n (if scheme? (java-name->scheme name) name)))
(if (or (not local?) profj-lib? htdch-lib? (to-file))
(if (or (not local?) profj-lib? htdch-lib? scheme-lib? (to-file))
(string-append n ".ss")
(string->symbol n))))))
#;(when (or htdch-lib? (equal? name "Image"))
(printf "build-require : class ~a path ~a ~a~n" name path (access (make-name))))
#;(printf "build-req of ~a profj-lib? ~a htdch-lib? ~a scheme-lib? ~a ~n"
(make-name) profj-lib? htdch-lib? scheme-lib?)
(if scheme?
(list (syn `(prefix ,(string->symbol
(apply string-append
@ -306,7 +314,8 @@
;(printf "~n~nadd-my-package package ~a~n" package)
;(printf "add-my-package: dir ~a class ~a~n" dir classes)
(for-each (lambda (c)
(import-class c package dir loc type-recs level #f #t)
(import-class c package
(make-dir-path (build-path 'same) #f) loc type-recs level #f #t)
(send type-recs add-to-env c package loc))
(filter (lambda (c) (not (contained-in? defs c))) classes))
(send type-recs add-package-contents package classes)))
@ -373,10 +382,16 @@
(equal? (filename-extension f) #".scm")))
(directory-list (dir-path-path dir)))
(filter (lambda (c-name) (not (equal? c-name "")))
(map (lambda (fn) (substring fn 0 (- (string-length fn) 5)))
(map path->string
(filter (lambda (f) (equal? (filename-extension f) #"java"))
(directory-list (dir-path-path dir))))))))
(map (lambda (fn)
(let ((str (path->string fn)))
(substring str 0 (- (string-length str)
(add1 (bytes-length (filename-extension fn)))))))
(filter (lambda (f)
(let ((ext (filename-extension f)))
(or (equal? ext #"java")
(equal? ext #"djava")
(equal? ext #"ajava"))))
(directory-list (dir-path-path dir)))))))
;load-lang: type-records -> void (adds lang to type-recs)
(define (load-lang type-recs)

24
collects/profj/check.ss
View File

@ -1910,13 +1910,17 @@
((scheme-record? record)
(module-has-binding? record name-string
(lambda () (no-method-error 'class 'not-found
(string->symbol name-string)
(make-ref-type name (list "scheme"))
(string->symbol
(scheme-record-name record))
name
src)))
(send type-recs add-req (make-req (scheme-record-name record)
(cons "scheme" (scheme-record-path record))))
(cond
((name? name) (set-id-string! (name-id name) (java-name->scheme name-string)))
((id? name) (set-id-string! name (java-name->scheme name-string))))
(list (make-method-contract (java-name->scheme name-string) #f #f)))))
(list (make-method-contract (java-name->scheme name-string) #f #f
(scheme-record-name record))))))
;Teaching languages
(if (and (= (length (access-name expr)) 1)
(with-handlers ((exn:fail:syntax? (lambda (exn) #f)))
@ -1977,7 +1981,7 @@
(get-method-records name-string
(send type-recs get-class-record object-type)))
((dynamic-val? call-exp)
(let ((m-contract (make-method-contract name-string #f #f)))
(let ((m-contract (make-method-contract name-string #f #f #f)))
(set-dynamic-val-type! call-exp (make-unknown-ref m-contract))
(set! exp-type call-exp)
(list m-contract)))
@ -1999,7 +2003,7 @@
((and (null? rec) (dynamic?) (lookup-var-in-env name-string env)) =>
(lambda (var-type)
(if (eq? 'dynamic (var-type-type var-type))
(list (make-method-contract (string-append name-string "~f") #f #f))
(list (make-method-contract (string-append name-string "~f") #f #f #f))
null)))
((null? rec) null)
(else (get-method-records name-string rec)))))))))))
@ -2205,8 +2209,14 @@
(not (package-members? c-class (cons (ref-type-class/iface type)
(ref-type-path type)) type-recs))))
(class-access-error 'pro level type src))
(when (and (not (memq 'private mods)) (not (memq 'protected mods)) (not (memq 'public mods))
(not (package-members? c-class (cons (ref-type-class/iface type) (ref-type-path type)) type-recs)))
(when (and (not (or (memq 'private mods) (memq 'protected mods) (memq 'public mods)))
(not (package-members? c-class
(cons (ref-type-class/iface type)
(if (null? (ref-type-path type))
(send type-recs lookup-path (ref-type-class/iface type)
(lambda () null))
(ref-type-path type)))
type-recs)))
(class-access-error 'pac level type src))
((if (class-alloc? exp) set-class-alloc-ctor-record! set-inner-alloc-ctor-record!)exp const)
(make-type/env type (cadr args/env)))))

11
collects/profj/to-scheme.ss
View File

@ -2292,7 +2292,12 @@
(mangle-method-name (method-record-name method-record)
(method-record-atypes method-record))))
(m-name (cond
((method-contract? method-record) (java-name->scheme (method-contract-name method-record)))
((method-contract? method-record)
(if (method-contract-prefix method-record)
(build-static-name
(java-name->scheme (method-contract-name method-record))
(method-contract-prefix method-record))
(java-name->scheme (method-contract-name method-record))))
(static?
(build-static-name temp (car (method-record-class method-record))))
(else temp)))
@ -2300,7 +2305,7 @@
(build-generic-name (car (method-record-class method-record)) m-name))))
(cond
((special-name? expr)
(let* ((over? (overridden? (string->symbol m-name)))
(let* ((over? (and (overridden? (string->symbol m-name)) (equal? "super" (special-name-name expr))))
(name (translate-id m-name (id-src method-name)))
(new-exp (cond
(static? (create-syntax #f `(,name ,@translated-args) (build-src src)))
@ -2317,7 +2322,7 @@
((method-contract? method-record)
(make-syntax #f (convert-assert-value
(create-syntax #f `((c:contract ,(type->contract method-record #t)
,(build-identifier (java-name->scheme (method-contract-name method-record)))
,(build-identifier m-name #;(java-name->scheme (method-contract-name method-record)))
(quote ,(string->symbol (class-name))) '|infered contract|)
,@translated-args) (build-src src))
(method-contract-return method-record))

97
collects/profj/tool.ss
View File

@ -376,7 +376,7 @@
(val-editor (caddr example))
(val (parse-expression (open-input-text-editor val-editor) val-editor level)))
(compile-interactions-ast
(make-var-init (make-var-decl name null type #f) val #f #f)
(make-var-init (make-var-decl name null type #f #f) val #f #f)
val-editor level type-recs)))
contents)
(process-extras (cdr extras) type-recs))))
@ -457,6 +457,7 @@
(let ([obj-path ((current-module-name-resolver) '(lib "Object.ss" "profj" "libs" "java" "lang") #f #f)]
[string-path ((current-module-name-resolver) '(lib "String.ss" "profj" "libs" "java" "lang") #f #f)]
[class-path ((current-module-name-resolver) '(lib "class.ss") #f #f)]
[mred-path ((current-module-name-resolver) '(lib "mred.ss" "mred") #f #f)]
[n (current-namespace)])
(read-case-sensitive #t)
(run-in-user-thread
@ -500,24 +501,45 @@
(namespace-attach-module n obj-path)
(namespace-attach-module n string-path)
(namespace-attach-module n class-path)
(namespace-attach-module n mred-path)
(namespace-require obj-path)
(namespace-require string-path)
(namespace-require class-path)
(namespace-require mred-path)
(namespace-require '(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java")))
(namespace-require '(prefix c: (lib "contract.ss"))))))))
(namespace-require '(prefix c: (lib "contract.ss")))
)))))
(define/public (render-value value settings port); port-write)
#;(define/public (render-value value settings port); port-write)
(let ((print-full? (profj-settings-print-full? settings))
(style (profj-settings-print-style settings)))
(if (is-a? value String)
(display (format-java value print-full? style null #t 0) port)
#;(begin
(write-special (format "~v" (send value get-mzscheme-string)) port)
(void))
(let ((out (format-java value print-full? style null #f 0)))
(if (< 25 (string-length out))
(display (format-java value print-full? style null #t 0) port)
(display out port))))))
(write-special
(if (is-a? value String)
(format-java value print-full? style null #t 0)
(let ((out (format-java value print-full? style null #f 0)))
(if (< 25 (string-length out))
(format-java value print-full? style null #t 0)
out))) port)
(void)))
(define/public (render-value value settings port)
(let* ((print-full? (profj-settings-print-full? settings))
(style (profj-settings-print-style settings))
(formatted (format-java-list value print-full? style null #f 0)))
(when (< 24 (total-length formatted))
(set! formatted (format-java-list value print-full? style null #t 0)))
(let loop ((out formatted))
(unless (null? out)
(write-special (car out) port)
(loop (cdr out))))))
(define/private (total-length lst)
(cond
((null? lst) 0)
((string? (car lst)) (+ (string-length (car lst))
(total-length (cdr lst))))
(else (add1 (total-length (cdr lst))))))
(define/public (render-value/format value settings port width)
(render-value value settings port)(newline port))
@ -843,6 +865,57 @@
(else (send value my-name))))
(else (format "~a" value))))
(define (format-java-list value full-print? style already-printed newline? num-tabs)
(cond
((null? value) '("null"))
((number? value) (list (format "~a" value)))
((char? value) (list (format "'~a'" value)))
((boolean? value) (list (if value "true" "false")))
((is-java-array? value)
(if full-print?
(array->string value (send value length) -1 #t style already-printed newline? num-tabs)
(array->string value 3 (- (send value length) 3) #f style already-printed newline? num-tabs)))
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
((string? value) (list (format "~v" value)))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(case style
((type) (list (send value my-name)))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3))
(fields null))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(append fields
(cons
(format "~a~a = "
(if newline? (if (eq? fields null)
(format "~n~a" (get-n-spaces new-tabs))
(get-n-spaces new-tabs)) "")
(car current))
(append
(if (memq (cadr current) already-printed)
(format-java-list (cadr current) full-print? 'type already-printed #f 0)
(format-java-list (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (string-length (car current)) 3)
num-tabs)))
(list (format "~a~a"
(if next "," "")
(if newline? (format "~n") " ")))))))
(loop next))))
(cons st
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name)))))
(else (list value))))
;array->string: java-value int int bool symbol (list value) -> string
(define (array->string value stop restart full-print? style already-printed nl? nt)
(letrec ((len (send value length))

16
collects/profj/types.ss
View File

@ -253,8 +253,8 @@
;;(make-unknown-ref (U method-contract field-contract))
(define-struct unknown-ref (access))
;;(make-method-contract string type (list type))
(define-struct method-contract (name return args))
;;(make-method-contract string type (list type) (U #f string))
(define-struct method-contract (name return args prefix))
;;(make-field-contract string type)
(define-struct field-contract (name type))
@ -585,7 +585,17 @@
(define (module-has-binding? mod-ref variable fail)
(let ((var (string->symbol (java-name->scheme variable))))
(or (memq var (scheme-record-provides mod-ref))
(let ((old-namespace (current-namespace)))
(let ((mod-syntax (datum->syntax-object #f
`(module m mzscheme
(require ,(generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))
,var)
#f)))
(with-handlers ((exn? (lambda (e) (fail))))
(expand mod-syntax))
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref))))
#;(let ((old-namespace (current-namespace)))
(current-namespace (make-namespace))
(namespace-require (generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
(scheme-record-path mod-ref)))