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

...

Browse Source 
original commit: 274b1b35fc518f8cd2827a18c06fe2dff34539e6
This commit is contained in:
Robby Findler 1998-11-18 00:36:26 +00:00
parent 79a27d18b1
commit ecf32583b5
2 changed files with 14 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/tests/framework/framework-test-engine.ss
View File

@ -3,12 +3,9 @@
(parameterize ([current-namespace (make-namespace)])
(require-library "pconvert.ss")
(global-defined-value 'print-convert))])
(lambda ()
(let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))]
[(continue) (make-semaphore 0)]
[(error) #f]
[(answer) (void)])
[(continue) (make-semaphore 0)])
(let loop ()
(let ([sexp (read in)])
(if (eof-object? sexp)
@ -17,17 +14,12 @@
(close-output-port out)
(exit))
(begin
(queue-callback (lambda ()
(set! error #f)
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(set! error exn))])
(set! answer (eval sexp)))
(semaphore-post continue)))
(semaphore-wait continue)
(write
(if error
(list 'error (exn-message error))
(list 'normal (print-convert answer)))
(with-handlers ([(lambda (x) #t)
(lambda (exn)
(list 'error (if (exn? exn)
(exn-message exn)
(format "~s" exn))))])
(list 'normal (print-convert (eval sexp))))
out)
(loop)))))))))

29
collects/tests/framework/main.ss
View File

@ -1,29 +1,10 @@
(require-library "launcher.ss" "launcher")
(require-library "function.ss")
(require-library "macro.ss")
(require-library "pretty.ss")
;; old, hopefully unnecessary
'(case (system-type)
[(macos)
(when running?
(let ([tmp-file (build-path (find-system-path 'temp-dir)
"frameworkempty.ss")])
(call-with-output-file tmp-file
(lambda (port)
(newline port))
'truncate)
(send-event "MrEd" "aevt" "quit")
(let loop ()
(sleep 1)
(with-handlers ([(lambda (x) #t) void])
(printf "looping~n")
(send-event "MrEd" "aevt" "odoc" (vector 'file tmp-file))
(loop)))))
(printf "macos: mred no longer running~n")])
(unless (file-exists? "receive-sexps-port.ss")
(call-with-output-file "receive-sexps-port.ss"
(unless (file-exists? (build-path (current-load-relative-directory) "receive-sexps-port.ss"))
(call-with-output-file (build-path (current-load-relative-directory) "receive-sexps-port.ss")
(lambda (port)
(write 6012 port))))
@ -80,6 +61,9 @@
(or (not (char-ready? in-port))
(not (eof-object? (peek-char in-port)))))
(restart-mred))
(printf "send-sexp-to-mred.sending:~n")
(pretty-print sexp)
(newline)
(write sexp out-port)
(newline out-port)
(let ([answer
@ -96,6 +80,7 @@
(loop))
null))))))])
(read in-port))])
(printf "send-sexp-to-mred.received result~n")
(unless (or (eof-object? answer)
(and (list? answer)
(= 2 (length answer))))