diff options
Diffstat (limited to 'final_project/work')
| -rw-r--r-- | final_project/work/Makefile | 43 | ||||
| -rw-r--r-- | final_project/work/discovery-examples.scm | 58 | ||||
| -rw-r--r-- | final_project/work/generic-string-opers.scm | 46 | ||||
| -rw-r--r-- | final_project/work/ghelper.scm | 6 | ||||
| -rw-r--r-- | final_project/work/hello.scm | 27 | ||||
| -rw-r--r-- | final_project/work/numerolgist.scm | 46 | ||||
| -rw-r--r-- | final_project/work/prhello-const.c | 50 | ||||
| -rw-r--r-- | final_project/work/prhello-shim.c | 829 | ||||
| -rw-r--r-- | final_project/work/prhello-types.bin | bin | 0 -> 5864 bytes | |||
| -rw-r--r-- | final_project/work/prhello.cdecl | 115 | ||||
| -rw-r--r-- | final_project/work/prhello.scm | 77 |
11 files changed, 1271 insertions, 26 deletions
diff --git a/final_project/work/Makefile b/final_project/work/Makefile new file mode 100644 index 0000000..f8e8f97 --- /dev/null +++ b/final_project/work/Makefile @@ -0,0 +1,43 @@ +all: + rm -f prhello-shim.{c,o} prhello-const.{c,o} *.bin *.so + make install-example + mit-scheme --batch-mode --load prhello.scm + +run: + rm -f prhello-shim.{c,o} prhello-const.{c,o} *.bin *.so + make install-example + mit-scheme --load prhello.scm + + +install-example: build-example + sudo cp -a prhello-types.bin /usr/local/lib/mit-scheme/lib/. + sudo cp -a prhello-const.bin /usr/local/lib/mit-scheme/lib/. + sudo cp -a prhello-shim.so /usr/local/lib/mit-scheme/lib/. + +build-example: prhello-shim.so prhello-types.bin prhello-const.bin + +prhello-shim.so: prhello-shim.o + $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-shim.o: prhello-shim.c + $(CC) -I../lib -Wall -fPIC `pkg-config --cflags gtk+-2.0` -o $@ -c $< + +prhello-shim.c prhello-const.c prhello-types.bin: prhello.cdecl + (echo "(load-option 'FFI)"; \ + echo '(C-generate "prhello" "#include <gtk/gtk.h>")') \ + | mit-scheme --batch-mode + +prhello-const.bin: prhello-const.scm + echo '(sf "prhello-const")' | mit-scheme --compiler --batch-mode + +prhello-const.scm: prhello-const + ./prhello-const + +prhello-const: prhello-const.o + @rm -f $@ + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ $^ `pkg-config --libs gtk+-2.0` + +prhello-const.o: prhello-const.c + $(CC) `pkg-config --cflags gtk+-2.0` $(CFLAGS) -o $@ -c $< + + diff --git a/final_project/work/discovery-examples.scm b/final_project/work/discovery-examples.scm index 45ae2ea..e525252 100644 --- a/final_project/work/discovery-examples.scm +++ b/final_project/work/discovery-examples.scm @@ -35,34 +35,26 @@ ;Value: .15384615384615385 (discover:opers-for 6.5) -;Value 57: (#[compound-procedure 38 operator] thingaling) +;Value 52: (inverse #[compound-procedure 49 operator]) (discover:named-opers-for 6.5) -;Value 58: (thingaling) +;Value 53: (inverse) (discover:named-opers-for 1 2) -;Value 81: (plus minus) - -;;; this stuff is just play crap - -(car (hash-table->alist *generic-operator-table*)) - -(caadr (hash-table/get *generic-operator-table* inverse #f)) - -(environment-bound-names (the-environment)) +;Value 54: (plus minus) (environment-lookup (the-environment) 'inverse) - - -(inverse '( (1 2 3) - (0 1 2) - (0 0 1))) +;Value 49: #[compound-procedure 49 operator] (hash-table/get *generic-operator-table* inverse #f) +;Value 59: (1 (#[compound-procedure 57] . #[compound-procedure 60]) (#[compound-procedure 61] . #[compound-procedure 62])) + (hash-table/get *generic-operator-table* minus #f) +;Value 63: (2 (#[compound-procedure 56 any?] (#[compound-procedure 56 any?] . #[arity-dispatched-procedure 28]))) (hash-table-size *generic-operator-table*) -;Value: 92 ;this is for mechanics +;Value: 6 ; for this file +;Value: 92 ; for scmutils ;this prints all keys line by line (for-each @@ -70,7 +62,6 @@ (display x)) (hash-table/key-list *generic-operator-table*)) - (define add1 (make-generic-operator 1 #f 'add1)) (define sub1 (make-generic-operator 1 #f 'sub1)) (define double (make-generic-operator 1 #f 'double)) @@ -84,17 +75,36 @@ (and (number? n) (not (zero? n))))) -(add1 4) -;(sub1 'b) - (discover:apply-all 3) +;Value 89: (1/3 4 9 2 6) (discover:satisfy (lambda (x) (eq? x 9)) (/ 1 2)) +;Value 35: (9) + (discover:satisfy-sequence (lambda (x) (eq? x 9)) (/ 1 2)) +;Value 36: (((9) square double add1) ((9) square add1 inverse)) + (discover:satisfy-sequence (lambda (x) (eq? x 49)) (/ 5 6)) +;Value 37: (((49) square sub1 inverse sub1)) + +(define (prime? n) + (cond ((null? n) #f) + ((not (integer? n)) #f) + ((> 0 n) #f) + (else (let lp ((m 2)) + (cond ((> m (sqrt n)) #t) + ((integer? (/ n m)) #f) + (else (lp (+ m 1)))))))) + +(prime? 47) +; #t + +(discover:satisfy-sequence prime? (/ 5 6)) +;Value 39: (((5) inverse sub1 inverse)) + +(discover:satisfy-sequence prime? 923) +;Value 44: (((1847) add1 double)) -(square (sqrt 2)) -(sqrt 2) -(square 3) +(discover:named-opers) diff --git a/final_project/work/generic-string-opers.scm b/final_project/work/generic-string-opers.scm new file mode 100644 index 0000000..9855793 --- /dev/null +++ b/final_project/work/generic-string-opers.scm @@ -0,0 +1,46 @@ + +; STRING +(define capitalize (make-generic-operator 1 #f 'capitalize)) +(define downcase (make-generic-operator 1 #f 'downcase)) +(define upcase (make-generic-operator 1 #f 'upcase)) +(define string-length (make-generic-operator 1 #f 'length)) +(defhandler capitalize (lambda (x) (string-capitalize x)) string?) +(defhandler downcase (lambda (x) (string-downcase x)) string?) +(defhandler upcase (lambda (x) (string-upcase x)) string?) +(defhandler string-length (lambda (x) (string-length x)) string?) + +; STRING STRING +(define search-forward (make-generic-operator 2 #f 'search-forward)) +(define search-backward (make-generic-operator 2 #f 'search-backward)) +(define search-all (make-generic-operator 2 #f 'search-all)) +(define is-substring (make-generic-operator 2 #f 'substring?)) +(define match (make-generic-operator 2 #f 'match)) +(defhandler match (lambda (x y) (string-match-forward x y)) string? string?) +(defhandler search-forward (lambda (x y) (string-search-forward x y)) string? string?) +(defhandler search-all (lambda (x y) (string-search-all x y)) string? string?) +(defhandler search-backward (lambda (x y) (string-search-backward x y)) string? string?) +(defhandler is-substring (lambda (x y) (substring? x y)) string? string?) + +; NUMBER NUMBER +(define plus (make-generic-operator 2 #f '+)) +(define subtract (make-generic-operator 2 #f '-)) +(define mul (make-generic-operator 2 #f '*)) +(define divide (make-generic-operator 2 #f '/)) +(define are-equal (make-generic-operator 2 #f '=?)) +(defhandler plus (lambda (x y) (+ x y)) number? number?) +(defhandler subtract (lambda (x y) (- x y)) number? number?) +(defhandler mul (lambda (x y) (* x y)) number? number?) +(defhandler divide (lambda (x y) (/ x y)) number? number?) +(defhandler are-equal (lambda (x y) (= x y)) number? number?) + +; LIST +(define length2 (make-generic-operator 1 #f 'length)) +(define reverse1 (make-generic-operator 1 #f 'reverse)) +(define sort1 (make-generic-operator 1 #f 'sort)) +(defhandler length2 (lambda (x) (length x)) list?) +(defhandler reverse1 (lambda (x) (reverse x)) list?) +(defhandler sort1 (lambda (x) (sort x <)) list?) + +; BOOLEAN +(define not1 (make-generic-operator 1 #f 'not)) +(defhandler not1 (lambda (x) (not x)) boolean?) diff --git a/final_project/work/ghelper.scm b/final_project/work/ghelper.scm index 4e39cbe..c74426b 100644 --- a/final_project/work/ghelper.scm +++ b/final_project/work/ghelper.scm @@ -1,4 +1,6 @@ -;;; From 6.945 Staff, with minor edit by bnewbold (May 2009) +;;; From 6.945 Staff, with minor edit by bnewbold (May 2009): +;;; the optional name argument is handled in the style of +;;; the scmutils implementation ;;;; Most General Generic-Operator Dispatch @@ -103,4 +105,4 @@ (begin (if (not (null? tree)) (warn "Replacing top-level handler:" tree handler)) - handler)))))
\ No newline at end of file + handler))))) diff --git a/final_project/work/hello.scm b/final_project/work/hello.scm new file mode 100644 index 0000000..d28154f --- /dev/null +++ b/final_project/work/hello.scm @@ -0,0 +1,27 @@ +(define (hello) + (let ((window (gtk-window-new 'toplevel)) + (button (gtk-button-new)) + (label (gtk-label-new "Hello, World!"))) + (gtk-container-add button label) + (gtk-container-add window button) + (gtk-window-set-title window "Hello") + (gtk-container-set-border-width button 10) + (let ((counter 0)) + (g-signal-connect window (C-callback "delete_event") + (lambda (w e) + (outf-console ";Delete me "(- 2 counter)" times.\n") + (set! counter (1+ counter)) + ;; Three or more is the charm. + (if (> counter 2) 0 1))) + (g-signal-connect button (C-callback "clicked") + (lambda (w) + (if (= counter 1) + (begin + (outf-console "\n;Erroring in "(current-thread)"...\n") + (error "Testing error handling."))) + (let ((text (gtk-label-get-text label))) + (gtk-label-set-text + label (list->string (reverse! (string->list text))))) + unspecific))) + (gtk-widget-show-all window) + window))
\ No newline at end of file diff --git a/final_project/work/numerolgist.scm b/final_project/work/numerolgist.scm new file mode 100644 index 0000000..6553232 --- /dev/null +++ b/final_project/work/numerolgist.scm @@ -0,0 +1,46 @@ + + +; frac objects are like (number 'numerator 'denominator) + +; the classics; just yanked from wikipedia w/o errors or citation +(define cgs-units-constants + (list + (list (* 2.998 (expt 10 10)) 'c) ; speed of light + (list (* 6.626 (expt 10 -27)) 'h) ; plank + (list (* 4.803 (expt 10 -10)) 'e) ; electron charge (esu) +; (list 3.14159268 'pi) ; pi! + )) + +(define (make-ordered-fracs primatives) + (sort (append primatives + (map (lambda (x) + (list (/ 1 (car x)) (quasiquote '(/ 1 ,(cadr x))))) + primatives)) + (lambda (a b) (< (car a) (car b))))) + +(make-ordered-fracs cgs-units-constants) + +(define (good-approximation x primatives eta) + (define (closest-term y ordered) + (cond ((null? ordered) (error "need at least one thing to check!")) + ((null? (cdr ordered)) (car ordered)) + ((< (abs (- y (caar ordered))) + (abs (- y (caar (cdr ordered))))) + (car ordered)) + (else (closest-term y (cdr ordered))))) + (define (iterate-term y ordered eta) + (if (< (abs y) (abs eta)) + (begin + (display y) + (newline) + (display (- y eta)) + '()) + (begin + (display "x: ") (display y) (newline) + (let ((best (closest-term y ordered))) + (cons (cadr best) + (iterate-term (/ y (car best)) ordered eta)))))) + (iterate-term x (make-ordered-fracs primatives) eta)) + +(good-approximation 876259081724391234.0 cgs-units-constants 200.) + diff --git a/final_project/work/prhello-const.c b/final_project/work/prhello-const.c new file mode 100644 index 0000000..4d5f3f5 --- /dev/null +++ b/final_project/work/prhello-const.c @@ -0,0 +1,50 @@ +/* -*-C-*- */ + +/* Prefix */ +#include <gtk/gtk.h> +/* End Prefix */ + +void +grovel_basics (FILE * out) +{ + fprintf (out, " ((sizeof char) . %d)\n", sizeof (char)); + fprintf (out, " ((sizeof uchar) . %d)\n", sizeof (unsigned char)); + fprintf (out, " ((sizeof short) . %d)\n", sizeof (short)); + fprintf (out, " ((sizeof ushort) . %d)\n", sizeof (unsigned short)); + fprintf (out, " ((sizeof int) . %d)\n", sizeof (int)); + fprintf (out, " ((sizeof uint) . %d)\n", sizeof (unsigned int)); + fprintf (out, " ((sizeof long) . %d)\n", sizeof (long)); + fprintf (out, " ((sizeof ulong) . %d)\n", sizeof (unsigned long)); + fprintf (out, " ((sizeof float) . %d)\n", sizeof (float)); + fprintf (out, " ((sizeof double) . %d)\n", sizeof (double)); + fprintf (out, " ((sizeof *) . %d)\n", sizeof (void*)); +} + +void +grovel_enums (FILE * out) +{ + fprintf (out, " (|GTK_WINDOW_POPUP| . %ld)\n", ((long)GTK_WINDOW_POPUP)); + fprintf (out, " (|GTK_WINDOW_TOPLEVEL| . %ld)\n", ((long)GTK_WINDOW_TOPLEVEL)); +} + +int +main (void) +{ + FILE * out = fopen ("prhello-const.scm", "w"); + if (out == NULL) { + perror ("could not open prhello-const.scm"); + return 1; + } + fprintf (out, "'( ;; prhello constants\n"); + fprintf (out, " ( ;; enum member values\n"); + grovel_enums(out); + fprintf (out, " )\n"); + fprintf (out, " ( ;; struct values\n"); + grovel_basics(out); + fprintf (out, " ))\n"); + if (fclose (out)) { + perror ("could not close prhello-const.scm"); + return 1; + } + return 0; +} diff --git a/final_project/work/prhello-shim.c b/final_project/work/prhello-shim.c new file mode 100644 index 0000000..f8b2c7d --- /dev/null +++ b/final_project/work/prhello-shim.c @@ -0,0 +1,829 @@ +/* -*-C-*- */ + +#include <mit-scheme.h> + +/* Prefix */ +#include <gtk/gtk.h> +/* End Prefix */ + +SCM +Scm_continue_gtk_init (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_init); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_init (void) +{ + /* Declare. */ + int * argc; + char * * * argv; + + /* Init. */ + check_number_of_args (3); + argc = (int *) arg_pointer (2); + argv = (char * * *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_init); + gtk_init (argc, argv); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_init); + + callout_continue (&Scm_continue_gtk_init); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + GtkWindowType type; + + /* Init. */ + check_number_of_args (3); + type = arg_long (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_new); + ret0 = gtk_window_new (type); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_window_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_button_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_button_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_button_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + + /* Init. */ + check_number_of_args (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_button_new); + ret0 = gtk_button_new (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_button_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_button_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_new_text (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_new_text); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_new_text (void) +{ + /* Declare. */ + GtkWidget * ret0; + + /* Init. */ + check_number_of_args (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_new_text); + ret0 = gtk_combo_box_new_text (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_new_text); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_combo_box_new_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_append_text (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_append_text); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_append_text (void) +{ + /* Declare. */ + GtkComboBox * combo; + const char * str; + + /* Init. */ + check_number_of_args (3); + combo = (GtkComboBox *) arg_pointer (2); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_append_text); + gtk_combo_box_append_text (combo, str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_append_text); + + callout_continue (&Scm_continue_gtk_combo_box_append_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_combo_box_get_active (void) +{ + /* Declare. */ + char * tos0; + gint ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_combo_box_get_active); + CSTACK_LPOP (gint, ret0, tos0); + + /* Return. */ + ret0s = long_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_combo_box_get_active (void) +{ + /* Declare. */ + gint ret0; + GtkComboBox * combo; + + /* Init. */ + check_number_of_args (2); + combo = (GtkComboBox *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_combo_box_get_active); + ret0 = gtk_combo_box_get_active (combo); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_combo_box_get_active); + CSTACK_PUSH (gint, ret0); + + callout_continue (&Scm_continue_gtk_combo_box_get_active); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + const char * str; + + /* Init. */ + check_number_of_args (3); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_new); + ret0 = gtk_label_new (str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_label_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_hbox_new (void) +{ + /* Declare. */ + char * tos0; + GtkWidget * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_hbox_new); + CSTACK_LPOP (GtkWidget *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_hbox_new (void) +{ + /* Declare. */ + GtkWidget * ret0; + gboolean homogeneous; + gint spacing; + + /* Init. */ + check_number_of_args (4); + homogeneous = arg_long (3); + spacing = arg_long (4); + + /* Call. */ + callout_seal (&Scm_continue_gtk_hbox_new); + ret0 = gtk_hbox_new (homogeneous, spacing); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_hbox_new); + CSTACK_PUSH (GtkWidget *, ret0); + + callout_continue (&Scm_continue_gtk_hbox_new); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_container_add (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_container_add); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_container_add (void) +{ + /* Declare. */ + GtkContainer * container; + GtkWidget * widget; + + /* Init. */ + check_number_of_args (3); + container = (GtkContainer *) arg_pointer (2); + widget = (GtkWidget *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_container_add); + gtk_container_add (container, widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_container_add); + + callout_continue (&Scm_continue_gtk_container_add); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_set_title (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_set_title); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_set_title (void) +{ + /* Declare. */ + GtkWindow * window; + const gchar * title; + + /* Init. */ + check_number_of_args (3); + window = (GtkWindow *) arg_pointer (2); + title = (const gchar *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_set_title); + gtk_window_set_title (window, title); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_set_title); + + callout_continue (&Scm_continue_gtk_window_set_title); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_container_set_border_width (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_container_set_border_width); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_container_set_border_width (void) +{ + /* Declare. */ + GtkContainer * container; + guint border_width; + + /* Init. */ + check_number_of_args (3); + container = (GtkContainer *) arg_pointer (2); + border_width = arg_ulong (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_container_set_border_width); + gtk_container_set_border_width (container, border_width); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_container_set_border_width); + + callout_continue (&Scm_continue_gtk_container_set_border_width); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_window_resize (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_window_resize); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_window_resize (void) +{ + /* Declare. */ + GtkWindow * window; + gint width; + gint height; + + /* Init. */ + check_number_of_args (4); + window = (GtkWindow *) arg_pointer (2); + width = arg_long (3); + height = arg_long (4); + + /* Call. */ + callout_seal (&Scm_continue_gtk_window_resize); + gtk_window_resize (window, width, height); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_window_resize); + + callout_continue (&Scm_continue_gtk_window_resize); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_widget_show_all (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_widget_show_all); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_widget_show_all (void) +{ + /* Declare. */ + GtkWidget * widget; + + /* Init. */ + check_number_of_args (2); + widget = (GtkWidget *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_widget_show_all); + gtk_widget_show_all (widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_widget_show_all); + + callout_continue (&Scm_continue_gtk_widget_show_all); + /* NOTREACHED */ +} + +SCM +Scm_continue_g_signal_connect (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_g_signal_connect); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_g_signal_connect (void) +{ + /* Declare. */ + GtkObject * object; + gchar * name; + GtkSignalFunc CALLBACK; + gpointer ID; + + /* Init. */ + check_number_of_args (5); + object = (GtkObject *) arg_pointer (2); + name = (gchar *) arg_pointer (3); + CALLBACK = (GtkSignalFunc) arg_alien_entry (4); + ID = (gpointer) arg_long (5); + + /* Call. */ + callout_seal (&Scm_continue_g_signal_connect); + g_signal_connect (object, name, CALLBACK, ID); + + /* Save. */ + callout_unseal (&Scm_continue_g_signal_connect); + + callout_continue (&Scm_continue_g_signal_connect); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_widget_destroy (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_widget_destroy); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_widget_destroy (void) +{ + /* Declare. */ + GtkWidget * widget; + + /* Init. */ + check_number_of_args (2); + widget = (GtkWidget *) arg_pointer (2); + + /* Call. */ + callout_seal (&Scm_continue_gtk_widget_destroy); + gtk_widget_destroy (widget); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_widget_destroy); + + callout_continue (&Scm_continue_gtk_widget_destroy); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_get_text (void) +{ + /* Declare. */ + char * tos0; + const gchar * ret0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_get_text); + CSTACK_LPOP (const gchar *, ret0, tos0); + + /* Return. */ + ret0s = pointer_to_scm (ret0); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_get_text (void) +{ + /* Declare. */ + const gchar * ret0; + GtkLabel * label; + + /* Init. */ + check_number_of_args (3); + label = (GtkLabel *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_get_text); + ret0 = gtk_label_get_text (label); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_get_text); + CSTACK_PUSH (const gchar *, ret0); + + callout_continue (&Scm_continue_gtk_label_get_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_label_set_text (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_label_set_text); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_label_set_text (void) +{ + /* Declare. */ + GtkLabel * label; + const char * str; + + /* Init. */ + check_number_of_args (3); + label = (GtkLabel *) arg_pointer (2); + str = (const char *) arg_pointer (3); + + /* Call. */ + callout_seal (&Scm_continue_gtk_label_set_text); + gtk_label_set_text (label, str); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_label_set_text); + + callout_continue (&Scm_continue_gtk_label_set_text); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_main (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_main); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_main (void) +{ + /* Declare. */ + + /* Init. */ + check_number_of_args (1); + + /* Call. */ + callout_seal (&Scm_continue_gtk_main); + gtk_main (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_main); + + callout_continue (&Scm_continue_gtk_main); + /* NOTREACHED */ +} + +SCM +Scm_continue_gtk_main_quit (void) +{ + /* Declare. */ + char * tos0; + SCM ret0s; + + /* Restore. */ + tos0 = callout_lunseal (&Scm_continue_gtk_main_quit); + + /* Return. */ + ret0s = unspecific(); + callout_pop (tos0); + return (ret0s); +} +void +Scm_gtk_main_quit (void) +{ + /* Declare. */ + + /* Init. */ + check_number_of_args (1); + + /* Call. */ + callout_seal (&Scm_continue_gtk_main_quit); + gtk_main_quit (); + + /* Save. */ + callout_unseal (&Scm_continue_gtk_main_quit); + + callout_continue (&Scm_continue_gtk_main_quit); + /* NOTREACHED */ +} + +static void +Scm_kernel_delete_event (void) +{ + /* Declare. */ + GtkWidget * window; + GdkEventAny * event; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_delete_event); + CSTACK_LPOP (GtkWidget *, window, tos0); + CSTACK_LPOP (GdkEventAny *, event, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)event), arglist0); + arglist0 = cons (cons_alien((void*)window), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +gboolean +Scm_delete_event (GtkWidget * window, GdkEventAny * event, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GdkEventAny *, event); + CSTACK_PUSH (GtkWidget *, window); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_delete_event); + return (long_value ()); +} + +static void +Scm_kernel_changed (void) +{ + /* Declare. */ + GtkComboBox * widget; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_changed); + CSTACK_LPOP (GtkComboBox *, widget, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)widget), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +void +Scm_changed (GtkComboBox * widget, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GtkComboBox *, widget); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_changed); + return; +} + +static void +Scm_kernel_clicked (void) +{ + /* Declare. */ + GtkWidget * widget; + gpointer ID; + SCM arglist0; + char * tos0; + + /* Init. */ + tos0 = callback_lunseal (&Scm_kernel_clicked); + CSTACK_LPOP (GtkWidget *, widget, tos0); + CSTACK_LPOP (gpointer, ID, tos0); + + /* Construct. */ + arglist0 = empty_list(); + arglist0 = cons (cons_alien((void*)widget), arglist0); + callback_run_handler ((int)ID, arglist0); + + callback_return (tos0); +} +void +Scm_clicked (GtkWidget * widget, gpointer ID) +{ + CSTACK_PUSH (gpointer, ID); + CSTACK_PUSH (GtkWidget *, widget); + callback_run_kernel ((int)ID, (CallbackKernel)&Scm_kernel_clicked); + return; +} diff --git a/final_project/work/prhello-types.bin b/final_project/work/prhello-types.bin Binary files differnew file mode 100644 index 0000000..4bfc808 --- /dev/null +++ b/final_project/work/prhello-types.bin diff --git a/final_project/work/prhello.cdecl b/final_project/work/prhello.cdecl new file mode 100644 index 0000000..26b8882 --- /dev/null +++ b/final_project/work/prhello.cdecl @@ -0,0 +1,115 @@ + #| -*-Scheme-*- + + C declarations for prhello.scm. |# + + + (typedef gint int) + (typedef guint uint) + (typedef gchar char) + (typedef gboolean gint) + (typedef gpointer (* mumble)) + + (extern void + gtk_init + (argc (* int)) + (argv (* (* (* char))))) + + (extern (* GtkWidget) + gtk_window_new + (type GtkWindowType)) + + (typedef GtkWindowType + (enum + (GTK_WINDOW_TOPLEVEL) + (GTK_WINDOW_POPUP))) + + (extern (* GtkWidget) + gtk_button_new) + + (extern (* GtkWidget) + gtk_combo_box_new_text) + + (extern void + gtk_combo_box_append_text + (combo (* GtkComboBox)) + (str (* (const char)))) + + (extern gint + gtk_combo_box_get_active + (combo (* GtkComboBox))) + + (extern (* GtkWidget) + gtk_label_new + (str (* (const char)))) + + (extern (* GtkWidget) + gtk_hbox_new + (homogeneous gboolean) + (spacing gint)) + + + (extern void + gtk_container_add + (container (* GtkContainer)) + (widget (* GtkWidget))) + + (extern void + gtk_window_set_title + (window (* GtkWindow)) + (title (* (const gchar)))) + + (extern void + gtk_container_set_border_width + (container (* GtkContainer)) + (border_width guint)) + + (extern void + gtk_window_resize + (window (* GtkWindow)) + (width gint) + (height gint)) + + (extern void + gtk_widget_show_all + (widget (* GtkWidget))) + + (extern void + g_signal_connect + (object (* GtkObject)) + (name (* gchar)) + (CALLBACK GtkSignalFunc) + (ID gpointer)) + + (typedef GtkSignalFunc (* mumble)) + + (callback gboolean + delete_event + (window (* GtkWidget)) + (event (* GdkEventAny)) + (ID gpointer)) + + (callback void + changed + (widget (* GtkComboBox)) + (ID gpointer)) + + (callback void + clicked + (widget (* GtkWidget)) + (ID gpointer)) + + (extern void + gtk_widget_destroy + (widget (* GtkWidget))) + + (extern (* (const gchar)) + gtk_label_get_text + (label (* GtkLabel))) + + (extern void + gtk_label_set_text + (label (* GtkLabel)) + (str (* (const char)))) + + (extern void gtk_main) + (extern void gtk_main_quit) diff --git a/final_project/work/prhello.scm b/final_project/work/prhello.scm new file mode 100644 index 0000000..c57f6f9 --- /dev/null +++ b/final_project/work/prhello.scm @@ -0,0 +1,77 @@ + #| -*-Scheme-*- + + $Id: $ + |# + + (declare (usual-integrations)) + + + (load "ghelper.scm") + (load "discovery.scm") + (load-option 'FFI) + (C-include "prhello") +(load "generic-string-opers.scm") + +(define get-vals car) +(define (get-proc-symbols input) (map car (cdr input))) +(define (apply-ith-thunk input i) ((cadr (list-ref (cdr input) i)))) + + +(define (thing-to-string thing) + (let ((buff (open-output-string))) + (display thing buff) + (get-output-string buff))) + +(define (discover-gui . input) + ;(display (discover:named-opers-for 1)) + (C-call "gtk_init" 0 null-alien) + (let* ((discovered-opers (apply discover:thunklist-for input)) + (window (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_window_new" alien + (C-enum "GTK_WINDOW_TOPLEVEL")) + (if (alien-null? alien) (error "Could not create window.")) + alien)) + (hbox (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_hbox_new" alien 0 20) + (if (alien-null? alien) (error "Could not create hbox.")) + alien)) + (combo (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_combo_box_new_text" alien) + (if (alien-null? alien) (error "Could not create combo.")) + alien)) + (labels (map (lambda (val) + (let ((alien (make-alien '|GtkWidget|))) + (C-call "gtk_label_new" alien (thing-to-string val)) + (if (alien-null? alien) (error "Could not create label.")) + alien)) + (get-vals discovered-opers)))) + (for-each (lambda (proc-symbol) + (C-call "gtk_combo_box_append_text" combo (thing-to-string proc-symbol))) + (get-proc-symbols discovered-opers)) + + (for-each (lambda (label) (C-call "gtk_container_add" hbox label)) labels) + (C-call "gtk_container_add" hbox combo) + (C-call "gtk_container_add" window hbox) + (C-call "gtk_window_set_title" window "Generic Operator Discovery") + (C-call "gtk_container_set_border_width" window 10) + (C-call "gtk_window_resize" window 250 20) + (C-call "g_signal_connect" combo "changed" + (C-callback "changed") ;trampoline + (C-callback ;callback ID + (lambda (w) + (let ((i (C-call "gtk_combo_box_get_active" combo))) + (discover-gui (apply-ith-thunk discovered-opers i)))))) + + (C-call "g_signal_connect" window "delete_event" + (C-callback "delete_event") ;trampoline + (C-callback ;callback ID + (lambda (w e) + (begin + (C-call "gtk_main_quit") + 0)))) + (C-call "gtk_widget_show_all" window) + (C-call "gtk_main") + window)) + + + |