summaryrefslogtreecommitdiffstats
path: root/final_project/work
diff options
context:
space:
mode:
authorbnewbold <bnewbold@eta.mit.edu>2009-05-11 13:45:12 -0400
committerbnewbold <bnewbold@eta.mit.edu>2009-05-11 13:45:12 -0400
commit38e10dc81d5f8f1a2bbededb790e775c0c637d6c (patch)
treec1c97634df0c0ff31f70d87462ad1f1390fd301f /final_project/work
parentca6558941cf604b2e5ddb8fe38261091a99f6d09 (diff)
download6.945-38e10dc81d5f8f1a2bbededb790e775c0c637d6c.tar.gz
6.945-38e10dc81d5f8f1a2bbededb790e775c0c637d6c.zip
files from laura
Diffstat (limited to 'final_project/work')
-rw-r--r--final_project/work/Makefile43
-rw-r--r--final_project/work/discovery-examples.scm58
-rw-r--r--final_project/work/generic-string-opers.scm46
-rw-r--r--final_project/work/ghelper.scm6
-rw-r--r--final_project/work/hello.scm27
-rw-r--r--final_project/work/numerolgist.scm46
-rw-r--r--final_project/work/prhello-const.c50
-rw-r--r--final_project/work/prhello-shim.c829
-rw-r--r--final_project/work/prhello-types.binbin0 -> 5864 bytes
-rw-r--r--final_project/work/prhello.cdecl115
-rw-r--r--final_project/work/prhello.scm77
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
new file mode 100644
index 0000000..4bfc808
--- /dev/null
+++ b/final_project/work/prhello-types.bin
Binary files differ
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))
+
+
+