diff --git a/.gitignore b/.gitignore index d23927a..d5e03b2 100644 --- a/.gitignore +++ b/.gitignore @@ -19,5 +19,6 @@ test-r7rs.scm test-r7rs *.html *.rkt +example.scm +example.sps example - diff --git a/Makefile b/Makefile index 9355dea..b1aa1c8 100644 --- a/Makefile +++ b/Makefile @@ -1,9 +1,9 @@ .SILENT: build install test-r6rs test-r6rs-docker test-r7rs test-r7rs-docker clean -.PHONY: test-r6rs test-r7rs +.PHONY: test-r6rs test-r7rs example.scm example.sps SCHEME=chibi LIBRARY=system EXAMPLE=editor -EXAMPLE_FILE=retropikzel/${LIBRARY}/examples/${EXAMPLE}.scm +EXAMPLE_FILE=retropikzel/${LIBRARY}/examples/${EXAMPLE} AUTHOR=Retropikzel LIBRARY_FILE=retropikzel/${LIBRARY}.sld @@ -42,8 +42,11 @@ test-r7rs-docker: docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet . docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} SNOW_CHIBI_ARGS=--always-yes build install test-r7rs" -example-r7rs: ${EXAMPLE_FILE} - COMPILE_R7RS=${SCHEME} compile-scheme -I . -o example ${EXAMPLE_FILE} +example.scm: ${EXAMPLE_FILE}.scm + cp ${EXAMPLE_FILE}.scm example.scm + +example-r7rs: example.scm + COMPILE_R7RS=${SCHEME} compile-scheme -I . -o example example.scm ./example test-r6rs: @@ -58,5 +61,13 @@ test-r6rs-docker: docker build --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=foreign-c-library-test-${SCHEME} --quiet . docker run -t foreign-c-library-test-${SCHEME} sh -c "make SCHEME=${SCHEME} LIBRARY=${LIBRARY} test-r6rs" +example.sps: ${EXAMPLE_FILE}.sps + cp ${EXAMPLE_FILE}.scm example.sps + +example-r6rs: example.sps + akku install akku-r7rs "(foreign c)" + COMPILE_R7RS=${SCHEME} compile-scheme -I .akku/lib -o example example.sps + ./example + clean: git clean -X -f diff --git a/retropikzel/pstk.scm b/retropikzel/pstk.scm index f281045..7f534a2 100644 --- a/retropikzel/pstk.scm +++ b/retropikzel/pstk.scm @@ -41,12 +41,7 @@ (define *wish-debug-input* (if (get-environment-variable "PSTK_DEBUG") #t #f)) (define *wish-debug-output* (if (get-environment-variable "PSTK_DEBUG") #t #f)) -(define *use-keywords?* - (cond-expand (chicken #t) - (else (or (not (symbol? 'text:)) - (not (symbol? ':text)) - (string=? "text" (symbol->string 'text:)) - (string=? "text" (symbol->string ':text)))))) +(define *use-keywords?* #t) (define (keyword? x) #f) ;; TODO: handle keywords? (define (keyword->string x) x) diff --git a/retropikzel/pstk.sld b/retropikzel/pstk.sld index 0866946..d9f8171 100644 --- a/retropikzel/pstk.sld +++ b/retropikzel/pstk.sld @@ -105,6 +105,7 @@ (scheme read) (scheme file) (scheme write) + (scheme process-context) (foreign c) (retropikzel named-pipes)) (export tk-eval diff --git a/retropikzel/pstk/VERSION b/retropikzel/pstk/VERSION index ee90284..90a27f9 100644 --- a/retropikzel/pstk/VERSION +++ b/retropikzel/pstk/VERSION @@ -1 +1 @@ -1.0.4 +1.0.5 diff --git a/retropikzel/pstk/examples/editor.scm b/retropikzel/pstk/examples/editor.scm index 7eb7ccc..b3d2cc5 100644 --- a/retropikzel/pstk/examples/editor.scm +++ b/retropikzel/pstk/examples/editor.scm @@ -39,7 +39,7 @@ (display k) (newline) (display "Text: ") - (write (text 'get 1.0 'end)) + (write (text 'get `(1.0 end))) (newline) #f) %k)) diff --git a/retropikzel/pstk/examples/editor.sps b/retropikzel/pstk/examples/editor.sps new file mode 100644 index 0000000..f2a8739 --- /dev/null +++ b/retropikzel/pstk/examples/editor.sps @@ -0,0 +1,46 @@ +(import (rnrs) + (retropikzel pstk)) + +(define tk (tk-start)) +(define text (tk 'create-widget 'text)) +(define open-file #f) + +(define (new-button-proc a) + (let ((dir (tk/choose-directory 'initialdir: "/tmp" + 'mustexist: #t))) + (display "Directory: ") + (write dir) + (newline))) +(define new-button + (tk 'create-widget 'button 'text: "New" 'command: `(,new-button-proc 10))) + +(define (open-button-proc) + (tk/message-box 'message: + "Warning! This editor is an example. Do not open any important files with it.") + (set! open-file (tk/get-open-file 'initialdir: "/tmp"))) +(define open-button + (tk 'create-widget 'button 'text: "Open" 'command: open-button-proc)) + +(define (save-button-proc) + (display "Saving file: ") + (write open-file) + (newline)) +(define save-button + (tk 'create-widget 'button 'text: "Save" 'command: save-button-proc)) + +;(tk/pack text new-button open-button save-button 'padx: 20 'pady: 20) +(tk/pack text 'padx: 20 'pady: 20) + +(tk/bind 'all + "" + `(,(lambda (k) + (display "Key code: ") + (display k) + (newline) + (display "Text: ") + (write (text 'get `(1.0 end))) + (newline) + #f) + %k)) + +(tk-event-loop tk)