├── mzscheme-lib ├── mzscheme │ ├── examples │ │ ├── info.rkt │ │ ├── fmod-ez.rkt │ │ ├── curses-demo.rkt │ │ ├── cfile.rkt │ │ ├── tree-finish.rkt │ │ ├── helloprint.c │ │ ├── idmodule.c │ │ ├── hello.c │ │ ├── msgbox.rkt │ │ ├── makeadder.c │ │ ├── fmod.c │ │ ├── makeadder3m.c │ │ ├── README │ │ ├── curses.c │ │ ├── catch.c │ │ ├── bitmatrix.c │ │ └── tree.cxx │ ├── info.rkt │ ├── mzscheme.1 │ └── installer.rkt ├── compiler │ ├── info.rkt │ ├── mzc.1 │ └── main.rkt ├── setup │ ├── info.rkt │ └── setup-plt.1 └── info.rkt ├── mzscheme-doc ├── mzscheme │ ├── info.rkt │ └── mzscheme.scrbl └── info.rkt ├── .gitignore ├── mzscheme └── info.rkt ├── LICENSE └── README.md /mzscheme-lib/mzscheme/examples/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define test-omit-paths 'all) 4 | -------------------------------------------------------------------------------- /mzscheme-doc/mzscheme/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings '(("mzscheme.scrbl" (multi-page) (legacy)))) 4 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/fmod-ez.rkt: -------------------------------------------------------------------------------- 1 | 2 | (c-declare "#include ") 3 | 4 | (define fmod (c-lambda (double double) double "fmod")) 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /mzscheme-lib/compiler/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define mzscheme-launcher-libraries (list "main.rkt")) 4 | (define mzscheme-launcher-names (list "mzc")) 5 | (define copy-man-pages '("mzc.1")) 6 | -------------------------------------------------------------------------------- /mzscheme-lib/setup/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define mzscheme-launcher-libraries '("main.rkt")) 4 | (define mzscheme-launcher-names '("Setup PLT")) 5 | (define copy-man-pages '("setup-plt.1")) 6 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version '(400)) 4 | 5 | (define install-collection "installer.rkt") 6 | (define copy-man-pages '("mzscheme.1")) 7 | 8 | (define compile-omit-paths '("examples")) 9 | -------------------------------------------------------------------------------- /mzscheme/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("mzscheme-lib" "mzscheme-doc")) 6 | (define implies '("mzscheme-lib" "mzscheme-doc")) 7 | 8 | (define pkg-desc "The legacy MzScheme language") 9 | 10 | (define pkg-authors '(mflatt)) 11 | 12 | (define license 13 | '(Apache-2.0 OR MIT)) 14 | -------------------------------------------------------------------------------- /mzscheme-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | (define deps '("scheme-lib" 5 | ["base" #:version "6.5.0.2"])) 6 | 7 | (define pkg-desc "implementation (no documentation) part of \"mzscheme\"") 8 | 9 | (define pkg-authors '(mflatt)) 10 | 11 | (define license 12 | '(Apache-2.0 OR MIT)) 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/curses-demo.rkt: -------------------------------------------------------------------------------- 1 | ; Uses the curses.so extension. Run with 2 | ; racket -r curses-demo.rkt 3 | 4 | ; To get append-extension-suffix, which adds .so or .dll as 5 | ; approrpiate for the current platform: 6 | (require dynext/file) 7 | 8 | ; Load the curses extension 9 | (load-extension (append-extension-suffix "curses")) 10 | 11 | ; Screen is initialize. Let's go! 12 | (move 8 10) 13 | (put "Hello, World!") 14 | (put #\newline) 15 | (put "Hit any key to continue.") 16 | (refresh) 17 | 18 | (get) 19 | -------------------------------------------------------------------------------- /mzscheme-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | 5 | (define deps '("base")) 6 | 7 | (define pkg-desc "documentation part of \"mzscheme\"") 8 | 9 | (define pkg-authors '(mflatt)) 10 | (define build-deps '("compatibility-lib" 11 | "r5rs-doc" 12 | "r5rs-lib" 13 | "racket-doc" 14 | "scheme-lib" 15 | "scheme-doc" 16 | "scribble-lib")) 17 | 18 | (define license 19 | '(Apache-2.0 OR MIT)) 20 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/cfile.rkt: -------------------------------------------------------------------------------- 1 | 2 | ;; Direct access to fopen, fread, fwrite, and fclose. The interface is 3 | ;; not remotely safe, since #f is accepted (and converted to NULL) 4 | ;; for `(pointer "FILE")' arguments. Also, blocking reads or writes 5 | ;; will block all Racket threads. 6 | 7 | (c-declare "#include ") 8 | 9 | (define fopen 10 | (c-lambda (char-string char-string) (pointer "FILE") "fopen")) 11 | (define fread 12 | (c-lambda (char-string long long (pointer "FILE")) long "fread")) 13 | (define fwrite 14 | (c-lambda (char-string long long (pointer "FILE")) long "fwrite")) 15 | (define fclose 16 | (c-lambda ((pointer "FILE")) int "fclose")) 17 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/tree-finish.rkt: -------------------------------------------------------------------------------- 1 | 2 | ;; Assumes that tree.so has been loaded 3 | 4 | (require mzlib/class) 5 | 6 | (define tree% 7 | (let ([method-names '(get-leaves 8 | get-left get-right 9 | grow 10 | graft)]) 11 | (make-primitive-class 12 | (lambda (class prop:object preparer dispatcher) 13 | (primitive-class-prepare-struct-type! 14 | tree-primitive-class 15 | prop:object 16 | class 17 | preparer 18 | dispatcher)) 19 | initialize-primitive-object 20 | 'tree% 21 | object% 22 | null 23 | '(leaves) 24 | null 25 | method-names 26 | null 27 | (map 28 | (lambda (name) 29 | (primitive-class-find-method tree-primitive-class name)) 30 | method-names)))) 31 | 32 | -------------------------------------------------------------------------------- /mzscheme-lib/compiler/mzc.1: -------------------------------------------------------------------------------- 1 | .\" dummy line 2 | .TH MZC 1 "May 2010" 3 | .UC 4 4 | .SH NAME 5 | mzc \- compatibility Racket compiler tool 6 | .SH SYNOPSIS 7 | .B mzc 8 | [ 9 | .I option ... 10 | ] [ 11 | .I argument ... 12 | ] 13 | .SH DESCRIPTION 14 | .B mzc 15 | provides an old interface to some Racket tools that are now 16 | normally provided via 17 | .BR raco . 18 | 19 | .PP 20 | Run 21 | .PP 22 | mzc --help 23 | .PP 24 | for a list of command-line options. 25 | 26 | .SH MORE INFORMATION 27 | For further information, run 28 | .PP 29 | raco docs 30 | .PP 31 | to open installed documentation in your web browser. 32 | 33 | .PP 34 | Alternately, consult the on-line 35 | documentation and other information available at 36 | .PP 37 | .ce 1 38 | http://racket-lang.org/ 39 | 40 | .SH SEE ALSO 41 | .BR raco(1), 42 | .BR racket(1) 43 | -------------------------------------------------------------------------------- /mzscheme-lib/setup/setup-plt.1: -------------------------------------------------------------------------------- 1 | .\" dummy line 2 | .TH SETUP-PLT 1 "May 2010" 3 | .UC 4 4 | .SH NAME 5 | setup-plt \- compatibility Racket setup tool 6 | .SH SYNOPSIS 7 | .B setup-plt 8 | [ 9 | .I option ... 10 | ] [ 11 | .I argument ... 12 | ] 13 | .SH DESCRIPTION 14 | .B setup-plt 15 | provides an old interface to some Racket tools that are now 16 | normally provided via 17 | .BR raco . 18 | 19 | .PP 20 | Run 21 | .PP 22 | setup-plt --help 23 | .PP 24 | for a list of command-line options. 25 | 26 | .SH MORE INFORMATION 27 | For further information, run 28 | .PP 29 | raco help 30 | .PP 31 | to open installed documentation in your web browser. 32 | 33 | .PP 34 | Alternately, consult the on-line 35 | documentation and other information available at 36 | .PP 37 | .ce 1 38 | http://racket-lang.org/ 39 | 40 | .SH SEE ALSO 41 | .BR raco(1), 42 | .BR racket(1) 43 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/mzscheme.1: -------------------------------------------------------------------------------- 1 | .\" dummy line 2 | .TH MZSCHEME 1 "May 2010" 3 | .UC 4 4 | .SH NAME 5 | mzscheme \- compatibility executable for Racket 6 | .SH SYNOPSIS 7 | .B mzscheme 8 | [ 9 | .I option ... 10 | ] [ 11 | .I argument ... 12 | ] 13 | .SH DESCRIPTION 14 | MzScheme is the old name for the core Racket implementation. 15 | 16 | .PP 17 | For most cases, running 18 | .B mzscheme 19 | is the same as running 20 | .BR racket , 21 | except that the default interaction language is slightly 22 | different for backward compatibility. 23 | 24 | .SH MORE INFORMATION 25 | For further information, run 26 | .PP 27 | raco docs 28 | .PP 29 | to open installed documentation in your web browser. 30 | 31 | .PP 32 | Alternately, consult the on-line 33 | documentation and other information available at 34 | .PP 35 | .ce 1 36 | http://racket-lang.org/ 37 | 38 | .SH SEE ALSO 39 | .BR racket(1) 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mzscheme 2 | 3 | This the source for the Racket packages: "mzscheme", "mzscheme-doc", "mzscheme-lib". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/mzscheme/pulls 22 | [issue]: https://github.com/racket/mzscheme/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/helloprint.c: -------------------------------------------------------------------------------- 1 | /* Like hello.c, but prints to the current output port and returns 2 | (void). */ 3 | 4 | #include "escheme.h" 5 | 6 | Scheme_Object *scheme_reload(Scheme_Env *env) 7 | { 8 | /* Make the string: */ 9 | Scheme_Object *hw; 10 | hw = scheme_make_utf8_string("Hello, World!\n"); 11 | 12 | /* Display it: */ 13 | scheme_display(hw, scheme_get_param(scheme_current_config(), 14 | MZCONFIG_OUTPUT_PORT)); 15 | 16 | /* Why not just 17 | printf("Hello, World!\n"); 18 | ? That would write to stdout, which may or may not be the same as 19 | the current output port. But sometimes printf() is what you 20 | want. */ 21 | 22 | return scheme_void; 23 | } 24 | 25 | Scheme_Object *scheme_initialize(Scheme_Env *env) 26 | { 27 | /* First load is same as every load: */ 28 | return scheme_reload(env); 29 | } 30 | 31 | Scheme_Object *scheme_module_name() 32 | { 33 | /* This extension doesn't define a module: */ 34 | return scheme_false; 35 | } 36 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/idmodule.c: -------------------------------------------------------------------------------- 1 | /* 2 | Extension that declares a module. 3 | The extension is equivalent to Scheme source of them form: 4 | (module idmodule mzscheme 5 | (define (identity x) x) 6 | (provide identity)) 7 | */ 8 | 9 | #include "escheme.h" 10 | 11 | static Scheme_Object *id(int argc, Scheme_Object **argv) 12 | { 13 | return argv[0]; 14 | } 15 | 16 | Scheme_Object *scheme_reload(Scheme_Env *env) 17 | { 18 | Scheme_Env *menv; 19 | Scheme_Object *proc; 20 | 21 | menv = scheme_primitive_module(scheme_intern_symbol("idmodule"), 22 | env); 23 | 24 | proc = scheme_make_prim_w_arity(id, "identity", 1, 1); 25 | 26 | /* All added names are automatically exported by the module: */ 27 | scheme_add_global("identity", proc, menv); 28 | 29 | scheme_finish_primitive_module(menv); 30 | 31 | return scheme_void; 32 | } 33 | 34 | Scheme_Object *scheme_initialize(Scheme_Env *env) 35 | { 36 | /* First load is same as every load: */ 37 | return scheme_reload(env); 38 | } 39 | 40 | Scheme_Object *scheme_module_name() 41 | { 42 | /* This extension defines a module named `idmodule': */ 43 | return scheme_intern_symbol("idmodule"); 44 | } 45 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/hello.c: -------------------------------------------------------------------------------- 1 | /* 2 | Racket extension example that returns the string "Hello, world!" 3 | when loaded. 4 | 5 | For the 3m GC (the default), compile with: 6 | mzc --xform hello.c 7 | mzc --3m --cc hello.3m.c 8 | mzc --3m --ld hello.so hello_3m.o 9 | And load with 10 | (load-extension "hello.so") ; or "hello.dylib" for Mac OS X 11 | ; or "hello.dll" for Windows 12 | 13 | For CGC, compile with: 14 | mzc --cgc --cc hello.c 15 | mzc --cgc --ld hello.so hello.o 16 | And load with 17 | (load-extension "hello.so") ; or "hello.dylib" for Mac OS X 18 | ; or "hello.dll" for Windows 19 | 20 | */ 21 | 22 | #include "escheme.h" 23 | 24 | Scheme_Object *scheme_reload(Scheme_Env *env) 25 | { 26 | /* When the extension is loaded, return a Scheme string: */ 27 | return scheme_make_utf8_string("Hello, world!"); 28 | } 29 | 30 | Scheme_Object *scheme_initialize(Scheme_Env *env) 31 | { 32 | /* First load is same as every load: */ 33 | return scheme_reload(env); 34 | } 35 | 36 | Scheme_Object *scheme_module_name() 37 | { 38 | /* This extension doesn't define a module: */ 39 | return scheme_false; 40 | } 41 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/msgbox.rkt: -------------------------------------------------------------------------------- 1 | ;; Build with 2 | ;; mzc ++ldf user32.lib msgbox.rkt 3 | ;; so that MessageBox() is linked in. 4 | 5 | (module msgbox mzscheme 6 | (require compiler/cffi) 7 | 8 | ;; c-declare is really file-specific, and 9 | ;; not module-specific 10 | (c-declare "#include ") 11 | 12 | ;; A direct hook to the MessageBox() function. 13 | ;; We never have a parent window, but NULL is ok, 14 | ;; and we can pretend that a window is a string 15 | ;; for the purposes of providing a NULL: 16 | (define unsafe-message-box 17 | (c-lambda ((pointer "void") ; always use #f 18 | nonnull-char-string ; title 19 | nonnull-char-string ; message 20 | int) ; style 21 | int 22 | "MessageBox")) 23 | 24 | ;; Functions that really just access constants: 25 | (define get-mb-okcancel 26 | (c-lambda () int "___result = MB_OKCANCEL;")) 27 | (define get-mb-yesno 28 | (c-lambda () int "___result = MB_YESNO;")) 29 | 30 | ;; Nice function for clients to use: 31 | (define (message-box title message style) 32 | (unsafe-message-box 33 | #f 34 | title 35 | message 36 | (case style 37 | [(ok-cancel) (get-mb-okcancel)] 38 | [(yes-no) (get-mb-yesno)] 39 | [else (raise-type-error 'message-box "'ok-cancel or 'yes-no" style)]))) 40 | 41 | (provide message-box)) 42 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/installer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require launcher 3 | compiler/embed 4 | racket/file 5 | racket/path 6 | setup/dirs) 7 | 8 | (provide installer) 9 | 10 | (define (installer path coll user? no-main?) 11 | (unless no-main? 12 | (do-installer path coll user? #f) 13 | (when (and (not user?) 14 | (find-config-tethered-console-bin-dir)) 15 | (do-installer path coll #f #t))) 16 | (when (find-addon-tethered-console-bin-dir) 17 | (do-installer path coll #t #t))) 18 | 19 | (define (do-installer path coll user? tethered?) 20 | (define variants (available-mzscheme-variants)) 21 | (for ([v (in-list variants)]) 22 | (parameterize ([current-launcher-variant v]) 23 | (create-embedding-executable 24 | (prep-dir (mzscheme-program-launcher-path "MzScheme" #:user? user? #:tethered? tethered?)) 25 | #:variant v 26 | #:cmdline (append 27 | (if (or user? tethered?) 28 | (list "-X" (path->string (find-collects-dir)) 29 | "-G" (path->string (find-config-dir))) 30 | null) 31 | (if (and tethered? user?) 32 | (list "-A" (path->string (find-system-path 'addon-dir))) 33 | null) 34 | '("-I" "scheme/init")) 35 | #:launcher? #t 36 | #:aux (append 37 | (if (or user? tethered?) 38 | null 39 | `((framework-root . #f) 40 | (dll-dir . #f))) 41 | `((relative? . ,(not (or user? tethered?))))))))) 42 | 43 | (define (prep-dir p) 44 | (define dir (path-only p)) 45 | (make-directory* dir) 46 | p) 47 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/makeadder.c: -------------------------------------------------------------------------------- 1 | /* 2 | Defines make-adder: 3 | (define (make-adder n) 4 | (lambda (m) (+ m n))) 5 | which illustrates closure-creation, looking up Scheme 6 | definitions, and calling Scheme procedures from C. 7 | */ 8 | 9 | #include "escheme.h" 10 | 11 | /* The inner lambda, which must close over `n'. A closure function is 12 | like a regular Scheme-procedure function, except that it takes an 13 | extra argument containing the closure data. The closre data can be 14 | any format that we want. */ 15 | static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv) 16 | { 17 | /* We only close over one value, so our closure data reprsentation 18 | is just thaht value: */ 19 | Scheme_Object *n = (Scheme_Object *)closure_data; 20 | Scheme_Object *plus; 21 | Scheme_Object *a[2]; 22 | 23 | plus = scheme_lookup_global(scheme_intern_symbol("+"), 24 | scheme_get_env(NULL)); 25 | 26 | /* return the result of summing m and n: */ 27 | a[0] = n; 28 | a[1] = argv[0]; /* m */ 29 | return _scheme_apply(plus, 2, a); 30 | 31 | /* Actually, that's not quite right. In the Scheme code, (+ m n) is 32 | a tail call. The following would be better: 33 | return _scheme_tail_apply(plus, 2, a); */ 34 | } 35 | 36 | static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv) 37 | { 38 | return scheme_make_closed_prim_w_arity(sch_inner, 39 | argv[0], 40 | "adder", 41 | 1, 1); 42 | } 43 | 44 | Scheme_Object *scheme_reload(Scheme_Env *env) 45 | { 46 | scheme_add_global("make-adder", 47 | scheme_make_prim_w_arity(sch_make_adder, 48 | "make-adder", 49 | 1, 1), 50 | env); 51 | 52 | return scheme_void; 53 | } 54 | 55 | Scheme_Object *scheme_initialize(Scheme_Env *env) 56 | { 57 | /* First load is same as every load: */ 58 | return scheme_reload(env); 59 | } 60 | 61 | Scheme_Object *scheme_module_name() 62 | { 63 | /* This extension doesn't define a module: */ 64 | return scheme_false; 65 | } 66 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/fmod.c: -------------------------------------------------------------------------------- 1 | /* 2 | Extension that defines fmod, modulo on floating-point numbers. 3 | The extension is equivalent to Scheme source of them form: 4 | (define (fmod a b) ...) 5 | */ 6 | 7 | #include "escheme.h" 8 | #include 9 | 10 | /**************************************************/ 11 | 12 | /* Every C implementation of a Scheme function takes argc and an array 13 | of Scheme_Object* values for argv, and returns a Scheme_Object*: */ 14 | static Scheme_Object *sch_fmod(int argc, Scheme_Object **argv) 15 | { 16 | /* Because we'll use scheme_make_prim_w_arity, Racket will 17 | have already checked that we're getting the right number of 18 | arguments. */ 19 | Scheme_Object *a = argv[0], *b = argv[1]; 20 | double v; 21 | 22 | /* Make sure we got real numbers, and complain if not: */ 23 | if (!SCHEME_REALP(a)) 24 | scheme_wrong_type("fmod", "real number", 0, argc, argv); 25 | /* 1st arg wrong ----^ */ 26 | if (!SCHEME_REALP(b)) 27 | scheme_wrong_type("fmod", "real number", 1, argc, argv); 28 | /* 2nd arg wrong ----^ */ 29 | 30 | /* Convert the Scheme numbers to double-precision floating point 31 | numbers, and compute fmod: */ 32 | v = fmod(scheme_real_to_double(a), 33 | scheme_real_to_double(b)); 34 | 35 | /* Return the result, packaging it as a Scheme value: */ 36 | return scheme_make_double(v); 37 | } 38 | 39 | /**************************************************/ 40 | 41 | Scheme_Object *scheme_reload(Scheme_Env *env) 42 | { 43 | Scheme_Object *proc; 44 | 45 | /* The MZ_GC... lines are for for 3m, because env is live across an 46 | allocating call. They're not needed for plain old (conservatively 47 | collected) Mzscheme. See makeadder3m.c for more info. */ 48 | MZ_GC_DECL_REG(1); 49 | MZ_GC_VAR_IN_REG(0, env); 50 | MZ_GC_REG(); 51 | 52 | /* Package the C implementation of fmod into a Scheme procedure 53 | value: */ 54 | proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2); 55 | /* Requires at least two args ------^ ^ */ 56 | /* Accepts no more than two args ---| */ 57 | 58 | /* Define `fmod' as a global :*/ 59 | scheme_add_global("fmod", proc, env); 60 | 61 | MZ_GC_UNREG(); 62 | 63 | return scheme_void; 64 | } 65 | 66 | Scheme_Object *scheme_initialize(Scheme_Env *env) 67 | { 68 | /* First load is same as every load: */ 69 | return scheme_reload(env); 70 | } 71 | 72 | Scheme_Object *scheme_module_name() 73 | { 74 | /* This extension doesn't define a module: */ 75 | return scheme_false; 76 | } 77 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/makeadder3m.c: -------------------------------------------------------------------------------- 1 | /* 2 | The same as makeaddr.c, but revised and annotated so that it works 3 | with 3m without using --xform. All non-3m comments have been 4 | deleted (to better highlight the 3m parts). 5 | */ 6 | 7 | #include "escheme.h" 8 | 9 | static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv) 10 | { 11 | Scheme_Object *n = (Scheme_Object *)closure_data; 12 | Scheme_Object *plus, *plus_sym, *result; 13 | Scheme_Env *env; 14 | Scheme_Object *a[2]; 15 | /* Declare registration space. The number 6 comes from the 16 | MZ_GC_VAR... declarations (i.e., if we add or remove 17 | some, the number changes */ 18 | MZ_GC_DECL_REG(6); 19 | 20 | MZ_GC_ARRAY_VAR_IN_REG(0, a, 2); /* takes 3 slots */ 21 | MZ_GC_VAR_IN_REG(3, argv); 22 | MZ_GC_VAR_IN_REG(4, n); 23 | MZ_GC_VAR_IN_REG(5, plus_sym); 24 | MZ_GC_REG(); 25 | 26 | /* Note that we've pulled out nested calls and assigned 27 | the results to explicitly declared variables. Even though 28 | `env' is not help across an allocating function call, 29 | we need to lift out the call to scheme_get_env(), otherwise 30 | plus_sym's value might get pushed on the stack in anticipation 31 | of the function call, and the corresponding object might 32 | move. As written, plus_sym's value is not set up for the 33 | call until after scheme_get_env() returns. */ 34 | plus_sym = scheme_intern_symbol("+"); 35 | env = scheme_get_env(NULL); 36 | plus = scheme_lookup_global(plus_sym, env); 37 | 38 | a[0] = n; 39 | a[1] = argv[0]; /* m */ 40 | result = _scheme_apply(plus, 2, a); 41 | 42 | /* The following unregister can't go before _scheme_apply, 43 | because `a' is passed in as a stack-allocated array. 44 | If `a' were heap-allocated, instead, MZ_GC_UNREG() 45 | could go before the call to _scheme_apply. */ 46 | MZ_GC_UNREG(); 47 | 48 | return result; 49 | 50 | } 51 | 52 | static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv) 53 | { 54 | return scheme_make_closed_prim_w_arity(sch_inner, 55 | argv[0], 56 | "adder", 57 | 1, 1); 58 | } 59 | 60 | Scheme_Object *scheme_reload(Scheme_Env *env) 61 | { 62 | Scheme_Object *p; 63 | MZ_GC_DECL_REG(1); 64 | MZ_GC_VAR_IN_REG(0, env); 65 | 66 | MZ_GC_REG(); 67 | 68 | p = scheme_make_prim_w_arity(sch_make_adder, 69 | "make-adder", 70 | 1, 1); 71 | 72 | scheme_add_global("make-adder", p, env); 73 | 74 | MZ_GC_UNREG(); 75 | 76 | return scheme_void; 77 | } 78 | 79 | Scheme_Object *scheme_initialize(Scheme_Env *env) 80 | { 81 | /* First load is same as every load: */ 82 | return scheme_reload(env); 83 | } 84 | 85 | Scheme_Object *scheme_module_name() 86 | { 87 | /* This extension doesn't define a module: */ 88 | return scheme_false; 89 | } 90 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/README: -------------------------------------------------------------------------------- 1 | This directory contains a few example Racket extensions. Most 2 | examples are implemented directly in C. A few examples listed at the 3 | end use the mzc `c-lambda', etc. forms. 4 | 5 | * hello.c - returns the string "Hello, World!". Demonstrates creating 6 | a Scheme value. 7 | 8 | * fmod.c - defines the `fmod' procedure, which calculates modulo on 9 | floating-point numbers. Demonstrates creating Scheme procedures 10 | from C and adding top-level definitions. (Manually instrumented for 11 | 3m, so do not use `mzc --xform'.) 12 | 13 | * curses.c - links Racket to the curses library. Demonstrates more 14 | procedures and definitions, a little more type dispatching, and 15 | returning multiple values. (Manually instrumented for 3m, so do not 16 | use `mzc --xform'.) 17 | 18 | * makeadder.c - defines `make-adder', which takes a number and 19 | returns a procedure that takes another number to add to 20 | it. Demonstrates closure creation in C, getting Scheme global 21 | values, and calling Scheme procedures from C. 22 | 23 | makeadder3m.c - the same, but manually instrumented 3m (so do not 24 | use `mzc --xform'). Making the code work with 3m requires several 25 | changes, but `mzc --xform' works on "makeadder.c" without changes. 26 | 27 | * catch.c - defined `eval-string/catch-error', which catches 28 | exceptions while evaluating a string. Demonstrates how to catch 29 | exceptions from C code. 30 | 31 | * bitmatrix.c - implements two-dimensional bit matrixes with some 32 | operations. Demonstrates defining a new Scheme data type, data 33 | allocation, fancy integer type checking, general exception raising, 34 | and registering static variables. Also demonstrates supplying 35 | traversal functions for 3m (but still needs `mzc --xform' 36 | preprocessing to build for 3m). 37 | 38 | * idmodule.c - Declares the module named `idmodule' that provides an 39 | `identity' function. Demonstrates implementing a primitive module 40 | in C. 41 | 42 | * helloprint.c - prints "Hello, World!" directly to the current 43 | output port rather than relying on the read-eval-print-loop. 44 | Demonstrates using built-in Scheme parameter values from C. 45 | 46 | * tree.cxx, tree-finish.ss - shows how to inject a C++ class into 47 | MzLib's class.ss world. (Does not work with 3m.) 48 | 49 | 50 | * fmod-ez.ss - same as fmod.c, but with 10% of the code. Demonstrates 51 | `c-lambda'. 52 | 53 | * cfile.ss - simple (and unsafe) glue to the fopen(), fread(), 54 | fwrite(), and fclose() C library functions. Demonstrates the use of 55 | `(pointer ...)' types. Technically, this example is broken for 3m, 56 | because fclose() frees the FILE* pointer, and it's possible that 57 | the GC will later try to use the same memory. 58 | 59 | * msgbox.ss - a Windows-only example, provides a `message-box' 60 | procedure. Demonstrates some of the limitations of `c-lambda' and 61 | how to work around them. 62 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/curses.c: -------------------------------------------------------------------------------- 1 | /* 2 | Extension that uses the curses library. 3 | 4 | Link the extension to the curses library like this: 5 | mzc --xform curses.c 6 | mzc --3m --cc curses.3m.c 7 | mzc --3m --ld curses.so curses_3m.o -lcurses 8 | 9 | For obvious reasons, this library doesn't interact well 10 | with Racket's read-eval-print loop. The example file 11 | curses-demo.ss demos this extension. 12 | */ 13 | 14 | #include "escheme.h" 15 | #include 16 | 17 | /**************************************************/ 18 | 19 | static Scheme_Object *sch_clear(int argc, Scheme_Object **argv) 20 | { 21 | clear(); 22 | } 23 | 24 | static Scheme_Object *sch_put(int argc, Scheme_Object **argv) 25 | { 26 | /* Puts a char or string on the screen */ 27 | if (SCHEME_CHARP(argv[0])) 28 | addch(SCHEME_CHAR_VAL(argv[0])); 29 | else if (SCHEME_BYTE_STRINGP(argv[0])) 30 | addstr(SCHEME_BYTE_STR_VAL(argv[0])); 31 | else if (SCHEME_CHAR_STRINGP(argv[0])) { 32 | Scheme_Object *bs; 33 | bs = scheme_char_string_to_byte_string(argv[0]); 34 | addstr(SCHEME_BYTE_STR_VAL(bs)); 35 | } else 36 | scheme_wrong_type("put", "character, string, or byte string", 0, argc, argv); 37 | 38 | return scheme_void; 39 | } 40 | 41 | static Scheme_Object *sch_get(int argc, Scheme_Object **argv) 42 | { 43 | /* Gets keyboard input */ 44 | int c; 45 | c = getch(); 46 | return scheme_make_character(c); 47 | } 48 | 49 | static Scheme_Object *sch_move(int argc, Scheme_Object **argv) 50 | { 51 | /* Move the output cursor */ 52 | if (!SCHEME_INTP(argv[0])) 53 | scheme_wrong_type("move", "exact integer", 0, argc, argv); 54 | if (!SCHEME_INTP(argv[1])) 55 | scheme_wrong_type("move", "exact integer", 1, argc, argv); 56 | 57 | move(SCHEME_INT_VAL(argv[0]), SCHEME_INT_VAL(argv[1])); 58 | 59 | return scheme_void; 60 | } 61 | 62 | static Scheme_Object *sch_get_size(int argc, Scheme_Object **argv) 63 | { 64 | /* Returns two values */ 65 | int w, h; 66 | Scheme_Object *a[2]; 67 | 68 | w = getmaxx(stdscr); 69 | h = getmaxy(stdscr); 70 | 71 | a[0] = scheme_make_integer(w); 72 | a[1] = scheme_make_integer(h); 73 | return scheme_values(1, a); 74 | } 75 | 76 | static Scheme_Object *sch_refresh(int argc, Scheme_Object **argv) 77 | { 78 | refresh(); 79 | return scheme_void; 80 | } 81 | 82 | /**************************************************/ 83 | 84 | Scheme_Object *scheme_reload(Scheme_Env *env) 85 | { 86 | /* The MZ_GC... lines are for for 3m, because env is live across an 87 | allocating call. They're not needed for plain old (conservatively 88 | collected) Mzscheme. See makeadder3m.c for more info. */ 89 | Scheme_Object *v; 90 | /* Old annotations, are they needed? 91 | MZ_GC_DECL_REG(1); 92 | MZ_GC_VAR_IN_REG(0, env); 93 | MZ_GC_REG(); 94 | */ 95 | 96 | v = scheme_make_prim_w_arity(sch_clear, "clear", 0, 0), 97 | scheme_add_global("clear", v, env); 98 | 99 | v = scheme_make_prim_w_arity(sch_put, "put", 1, 1); 100 | scheme_add_global("put", v, env); 101 | 102 | v = scheme_make_prim_w_arity(sch_get, "get", 0, 0); 103 | scheme_add_global("get", v, env); 104 | 105 | v = scheme_make_prim_w_arity(sch_move, "move", 2, 2); 106 | scheme_add_global("move", v, env); 107 | 108 | v = scheme_make_prim_w_arity(sch_get_size, "get-size", 0, 0); 109 | scheme_add_global("get-size", v, env); 110 | 111 | v = scheme_make_prim_w_arity(sch_refresh, "refresh", 0, 0); 112 | scheme_add_global("refresh", v, env); 113 | 114 | MZ_GC_UNREG(); 115 | 116 | return scheme_void; 117 | } 118 | 119 | Scheme_Object *scheme_initialize(Scheme_Env *env) 120 | { 121 | /* The first time we're loaded, initialize the screen: */ 122 | initscr(); 123 | cbreak(); 124 | noecho(); 125 | atexit(endwin); 126 | 127 | /* Then do the usual stuff: */ 128 | return scheme_reload(env); 129 | } 130 | 131 | Scheme_Object *scheme_module_name() 132 | { 133 | /* This extension doesn't define a module: */ 134 | return scheme_false; 135 | } 136 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/catch.c: -------------------------------------------------------------------------------- 1 | /* 2 | Racket extension example that catches exceptions and extracts 3 | error messages. 4 | 5 | The defined function is `eval-string/catch-error', which takes a 6 | string and evaluates it, returning either the value, a string for 7 | the error message, and a non-exn value raised by the expression. 8 | 9 | > (eval-string/catch-error "10") 10 | 10 11 | 12 | > (eval-string/catch-error "(+ 'a)") 13 | "+: expects argument of type ; given a" 14 | 15 | > (eval-string/catch-error "(raise 'ack)") 16 | ack 17 | 18 | */ 19 | 20 | #include "escheme.h" 21 | 22 | /*********************************************************************/ 23 | /* Exception-catching code */ 24 | /*********************************************************************/ 25 | 26 | /* These must be registered with the memory manager: */ 27 | static Scheme_Object *exn_catching_apply, *exn_p, *exn_message; 28 | 29 | static void init_exn_catching_apply() 30 | { 31 | if (!exn_catching_apply) { 32 | Scheme_Env *env; 33 | char *e = 34 | "(lambda (thunk) " 35 | "(with-handlers ([void (lambda (exn) (cons #f exn))]) " 36 | "(cons #t (thunk))))"; 37 | 38 | /* make sure we have a namespace with the standard bindings: */ 39 | env = (Scheme_Env *)scheme_make_namespace(0, NULL); 40 | 41 | scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *)); 42 | scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *)); 43 | scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *)); 44 | 45 | exn_catching_apply = scheme_eval_string(e, env); 46 | exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env); 47 | exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env); 48 | } 49 | } 50 | 51 | /* This function applies a thunk, returning the Scheme value if there's no exception, 52 | otherwise returning NULL and setting *exn to the raised value (usually an exn 53 | structure). */ 54 | Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn) 55 | { 56 | Scheme_Object *v; 57 | 58 | init_exn_catching_apply(); 59 | 60 | v = _scheme_apply(exn_catching_apply, 1, &f); 61 | /* v is a pair: (cons #t value) or (cons #f exn) */ 62 | 63 | if (SCHEME_TRUEP(SCHEME_CAR(v))) 64 | return SCHEME_CDR(v); 65 | else { 66 | *exn = SCHEME_CDR(v); 67 | return NULL; 68 | } 69 | } 70 | 71 | Scheme_Object *extract_exn_message(Scheme_Object *v) 72 | { 73 | init_exn_catching_apply(); 74 | 75 | if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v))) 76 | return _scheme_apply(exn_message, 1, &v); 77 | else 78 | return NULL; /* Not an exn structure */ 79 | } 80 | 81 | /*********************************************************************/ 82 | /* Use of example exception-catching code */ 83 | /*********************************************************************/ 84 | 85 | static Scheme_Object *do_eval(void *s, int noargc, Scheme_Object **noargv) 86 | { 87 | return scheme_eval_string((char *)s, scheme_get_env(NULL)); 88 | } 89 | 90 | static Scheme_Object *eval_string_or_get_exn_message(char *s) 91 | { 92 | Scheme_Object *v, *exn; 93 | 94 | v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval, s), &exn); 95 | /* Got a value? */ 96 | if (v) 97 | return v; 98 | 99 | v = extract_exn_message(exn); 100 | /* Got an exn? */ 101 | if (v) 102 | return v; 103 | 104 | /* `raise' was called on some arbitrary value */ 105 | return exn; 106 | } 107 | 108 | static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv) 109 | { 110 | Scheme_Object *bs; 111 | 112 | if (!SCHEME_CHAR_STRINGP(argv[0])) 113 | scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv); 114 | 115 | bs = scheme_char_string_to_byte_string(argv[0]); 116 | 117 | return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs)); 118 | } 119 | 120 | /*********************************************************************/ 121 | /* Initialization */ 122 | /*********************************************************************/ 123 | 124 | Scheme_Object *scheme_reload(Scheme_Env *env) 125 | { 126 | scheme_add_global("eval-string/catch-error", 127 | scheme_make_prim_w_arity(catch_eval_error, 128 | "eval-string/catch-error", 129 | 1, 1), 130 | env); 131 | 132 | return scheme_void; 133 | } 134 | 135 | Scheme_Object *scheme_initialize(Scheme_Env *env) 136 | { 137 | /* First load is same as every load: */ 138 | return scheme_reload(env); 139 | } 140 | 141 | Scheme_Object *scheme_module_name() 142 | { 143 | /* This extension doesn't define a module: */ 144 | return scheme_false; 145 | } 146 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/bitmatrix.c: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | This extension Defines a new type of Scheme data: a two-dimensional 4 | matrix of bits. 5 | 6 | A client using this extension would look something like this: 7 | 8 | (load-extension "bitmatrix.so") 9 | (define bm (make-bit-matrix 1000 1000)) 10 | ... 11 | (bit-matrix-set! bm 500 500 #t) 12 | ... 13 | (if (bit-matrix-get bm 500 500) ...) 14 | ... 15 | 16 | */ 17 | 18 | #include "escheme.h" 19 | 20 | /* Instances of this Bitmatrix structure will be the Scheme bit matirx 21 | values: */ 22 | typedef struct { 23 | Scheme_Object so; /* Every Scheme value starts with a Scheme_Object, 24 | which stars with a type tag. The 25 | format for the rest of the structure is 26 | anything we want it to be. */ 27 | unsigned long w, h, l; /* l = w rounded to multiple of LONG_SIZE */ 28 | unsigned long *matrix; 29 | } Bitmatrix; 30 | 31 | #ifdef MZ_PRECISE_GC 32 | START_XFORM_SKIP; 33 | /* Traversal procedures for precise GC: */ 34 | static int bm_size(void *p) { 35 | return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); 36 | } 37 | static int bm_mark(void *p) { 38 | gcMARK(((Bitmatrix *)p)->matrix); 39 | return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); 40 | } 41 | static int bm_fixup(void *p) { 42 | gcFIXUP(((Bitmatrix *)p)->matrix); 43 | return gcBYTES_TO_WORDS(sizeof(Bitmatrix)); 44 | } 45 | END_XFORM_SKIP; 46 | #endif 47 | 48 | /* We'll get some Scheme primitives so we can calculate with numbers 49 | that are potentially bignums: */ 50 | static Scheme_Object *mult, *add, *sub, *modulo, *neg; 51 | 52 | /* The type tag for bit matrixes, initialized with scheme_make_type */ 53 | static Scheme_Type bitmatrix_type; 54 | 55 | #define LONG_SIZE 32 56 | #define LOG_LONG_SIZE 5 57 | #define LONG_SIZE_PER_BYTE 4 58 | 59 | # define FIND_BIT(p) (1 << (p & (LONG_SIZE - 1))) 60 | 61 | /* Helper function to check whether an integer (fixnum or bignum) is 62 | negative: */ 63 | static int negative(Scheme_Object *o) 64 | { 65 | return SCHEME_TRUEP(_scheme_apply(neg, 1, &o)); 66 | } 67 | 68 | /* Scheme procedure to make a bit matrix: */ 69 | Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv) 70 | { 71 | Scheme_Object *size, *rowlength, *a[2]; 72 | unsigned long w, h, s, l, *lp; 73 | Bitmatrix *bm; 74 | 75 | /* Really fancy: we allow any kind of positive integer for 76 | specifying the size of a bit matrix. If we get a bignum (or the 77 | resulting matrix size is a bignum), we'll signal an out-of-memory 78 | exception. */ 79 | if ((!SCHEME_INTP(argv[0]) && !SCHEME_BIGNUMP(argv[0])) 80 | || negative(argv[0])) 81 | scheme_wrong_type("make-bit-matrix", "positive integer", 0, argc, argv); 82 | if ((!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1])) 83 | || (negative(argv[1]))) 84 | scheme_wrong_type("make-bit-matrix", "positive integer", 1, argc, argv); 85 | 86 | a[0] = argv[0]; 87 | a[1] = scheme_make_integer(LONG_SIZE - 1); 88 | /* Apply the Scheme `add' procedure to argv[0] and argv[1]. Note the 89 | "_" in "_scheme_apply"; that's a lot faster than "scheme_apply", 90 | and we know that no continuation jumps will occur (although it 91 | would be fine if one did. */ 92 | a[0] = _scheme_apply(add, 2, a); 93 | a[1] = scheme_make_integer(LONG_SIZE); 94 | a[1] = _scheme_apply(modulo, 2, a); 95 | a[0] = _scheme_apply(sub, 2, a); 96 | rowlength = a[0]; 97 | a[1] = argv[1]; 98 | size = _scheme_apply(mult, 2, a); 99 | if (SCHEME_BIGNUMP(size)) 100 | /* Use scheme_raise_exn to raise exceptions. The first argument 101 | describes the type of the exception. After an exception-specific 102 | number of Scheme values (none in this case), the rest of the 103 | arguments are like printf. */ 104 | scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory"); 105 | 106 | s = SCHEME_INT_VAL(size); 107 | w = SCHEME_INT_VAL(argv[0]); 108 | h = SCHEME_INT_VAL(argv[1]); 109 | l = SCHEME_INT_VAL(rowlength); 110 | 111 | /* Malloc the bit matrix structure. Since we use scheme_malloc, the 112 | bit matrix value is GC-able. */ 113 | bm = (Bitmatrix *)scheme_malloc_tagged(sizeof(Bitmatrix)); 114 | bm->so.type = bitmatrix_type; 115 | 116 | /* Try to allocate the bit matrix. Handle failure gracefully. Note 117 | that we use scheme_malloc_atomic since the allocated memory will 118 | never contain pointers to GC-allocated memory. */ 119 | s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE); 120 | lp = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, 121 | sizeof(long) * s); 122 | if (!lp) 123 | scheme_raise_exn(MZEXN_FAIL, "make-bit-matrix: out of memory"); 124 | bm->matrix = lp; 125 | 126 | bm->w = w; 127 | bm->h = h; 128 | bm->l = l; 129 | 130 | /* Init matirx to all 0s: */ 131 | while (s--) { 132 | bm->matrix[s] = 0; 133 | } 134 | 135 | return (Scheme_Object *)bm; 136 | } 137 | 138 | /* Internal utility function for error-checking with a fancy error 139 | message: */ 140 | static void range_check_one(char *name, char *which, 141 | int l, int h, int startpos, 142 | int argc, Scheme_Object **argv) 143 | { 144 | int bad1; 145 | 146 | if (SCHEME_BIGNUMP(argv[startpos])) { 147 | bad1 = 1; 148 | } else { 149 | int v = SCHEME_INT_VAL(argv[startpos]); 150 | bad1 = ((v < l) || (v > h)); 151 | } 152 | 153 | if (bad1) { 154 | /* A mismatch exception requires one Scheme value, so we provide 155 | it before the printf string: */ 156 | char *args; 157 | long argslen; 158 | 159 | args = scheme_make_args_string("other ", startpos, argc, argv, &argslen); 160 | scheme_raise_exn(MZEXN_FAIL_CONTRACT, 161 | "%s: %s index %s is not in the range [%d,%d]%t", 162 | name, which, 163 | scheme_make_provided_string(argv[startpos], 1, NULL), 164 | l, h, 165 | args, 166 | argslen); 167 | } 168 | } 169 | 170 | /* Internal utility function that implements most of the work of the 171 | get- and set- Scheme procedures: */ 172 | static Scheme_Object *do_bit_matrix(char *name, int get, int argc, Scheme_Object **argv) 173 | { 174 | Bitmatrix *bm; 175 | unsigned long x, y, p, v, m; 176 | 177 | if (SCHEME_TYPE(argv[0]) != bitmatrix_type) 178 | scheme_wrong_type(name, "bit-matrix", 0, argc, argv); 179 | if (!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1])) 180 | scheme_wrong_type(name, "integer", 1, argc, argv); 181 | if (!SCHEME_INTP(argv[2]) && !SCHEME_BIGNUMP(argv[2])) 182 | scheme_wrong_type(name, "integer", 2, argc, argv); 183 | 184 | /* After checking that argv[0] has te bitmatrix_type tag, we can safely perform 185 | a cast to Bitmatrix*: */ 186 | bm = (Bitmatrix *)argv[0]; 187 | 188 | range_check_one(name, "first", 0, bm->w - 1, 1, argc, argv); 189 | range_check_one(name, "second", 0, bm->h - 1, 2, argc, argv); 190 | 191 | x = SCHEME_INT_VAL(argv[1]); 192 | y = SCHEME_INT_VAL(argv[2]); 193 | 194 | p = y * bm->l + x; 195 | m = FIND_BIT(p); 196 | v = bm->matrix[p >> LOG_LONG_SIZE]; 197 | if (get) { 198 | return (v & m) ? scheme_true : scheme_false; 199 | } else { 200 | if (SCHEME_TRUEP(argv[3])) 201 | bm->matrix[p >> LOG_LONG_SIZE] = (v | m); 202 | else 203 | bm->matrix[p >> LOG_LONG_SIZE] = (v - (v & m)); 204 | return scheme_void; 205 | } 206 | } 207 | 208 | /* Scheme procedure: get a bit from the matrix */ 209 | Scheme_Object *bit_matrix_get(int argc, Scheme_Object **argv) 210 | { 211 | return do_bit_matrix("bit-matrix-get", 1, argc, argv); 212 | } 213 | 214 | /* Scheme procedure: set a bit in the matrix */ 215 | Scheme_Object *bit_matrix_set(int argc, Scheme_Object **argv) 216 | { 217 | return do_bit_matrix("bit-matrix-set!", 0, argc, argv); 218 | } 219 | 220 | /* Scheme procedure: invert the whole matrix */ 221 | Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv) 222 | { 223 | Bitmatrix *bm; 224 | unsigned long i; 225 | 226 | if (SCHEME_TYPE(argv[0]) != bitmatrix_type) 227 | scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv); 228 | 229 | bm = (Bitmatrix *)argv[0]; 230 | 231 | i = (bm->l * bm->h) >> LOG_LONG_SIZE; 232 | while (i--) { 233 | bm->matrix[i] = ~bm->matrix[i]; 234 | } 235 | 236 | return scheme_void; 237 | } 238 | 239 | /* Scheme procedure: clear the whole matrix */ 240 | Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv) 241 | { 242 | char *name = "bit-matrix-clear!"; 243 | Bitmatrix *bm; 244 | unsigned long i; 245 | 246 | if (SCHEME_TYPE(argv[0]) != bitmatrix_type) 247 | scheme_wrong_type(name, "bit-matrix", 0, argc, argv); 248 | 249 | bm = (Bitmatrix *)argv[0]; 250 | 251 | i = (bm->l * bm->h) >> LOG_LONG_SIZE; 252 | while (i--) { 253 | bm->matrix[i] = 0; 254 | } 255 | 256 | return scheme_void; 257 | } 258 | 259 | Scheme_Object *scheme_reload(Scheme_Env *env) 260 | { 261 | /* Define our new primitives: */ 262 | 263 | scheme_add_global("make-bit-matrix", 264 | scheme_make_prim_w_arity(make_bit_matrix, 265 | "make-bit-matrix", 266 | 2, 2), 267 | env); 268 | 269 | scheme_add_global("bit-matrix-get", 270 | scheme_make_prim_w_arity(bit_matrix_get, 271 | "bit-matrix-get", 272 | 3, 3), 273 | env); 274 | 275 | scheme_add_global("bit-matrix-set!", 276 | scheme_make_prim_w_arity(bit_matrix_set, 277 | "bit-matrix-set!", 278 | 4, 4), 279 | env); 280 | 281 | scheme_add_global("bit-matrix-invert!", 282 | scheme_make_prim_w_arity(bit_matrix_invert, 283 | "bit-matrix-invert!", 284 | 1, 1), 285 | env); 286 | 287 | scheme_add_global("bit-matrix-clear!", 288 | scheme_make_prim_w_arity(bit_matrix_clear, 289 | "bit-matrix-clear!", 290 | 1, 1), 291 | env); 292 | 293 | return scheme_void; 294 | } 295 | 296 | Scheme_Object *scheme_initialize(Scheme_Env *env) 297 | { 298 | bitmatrix_type = scheme_make_type(""); 299 | 300 | #ifdef MZ_PRECISE_GC 301 | /* Register traversal procedures: */ 302 | GC_register_traversers(bitmatrix_type, bm_size, bm_mark, bm_fixup, 1, 0); 303 | #endif 304 | 305 | /* Get some Scheme primitives. Conservative garbage collection sees 306 | any local variables we use within a function, but we have to register 307 | static variables: */ 308 | 309 | scheme_register_extension_global(&mult, sizeof(Scheme_Object*)); 310 | mult = scheme_builtin_value("*"); 311 | 312 | scheme_register_extension_global(&add, sizeof(Scheme_Object*)); 313 | add = scheme_builtin_value("+"); 314 | 315 | scheme_register_extension_global(&sub, sizeof(Scheme_Object*)); 316 | sub = scheme_builtin_value("-"); 317 | 318 | scheme_register_extension_global(&modulo, sizeof(Scheme_Object*)); 319 | modulo = scheme_builtin_value("modulo"); 320 | 321 | scheme_register_extension_global(&neg, sizeof(Scheme_Object*)); 322 | neg = scheme_builtin_value("negative?"); 323 | 324 | return scheme_reload(env); 325 | } 326 | 327 | 328 | Scheme_Object *scheme_module_name() 329 | { 330 | /* This extension doesn't define a module: */ 331 | return scheme_false; 332 | } 333 | -------------------------------------------------------------------------------- /mzscheme-doc/mzscheme/mzscheme.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/manual 3 | (for-label (except-in mzscheme 4 | exn:fail exn:fail:contract) 5 | (only-in r5rs set-car! set-cdr!) 6 | (only-in scheme/base 7 | for-syntax #%plain-module-begin 8 | exact-nonnegative-integer? 9 | exact-positive-integer? 10 | syntax? 11 | #%plain-lambda #%plain-app 12 | syntax->datum datum->syntax 13 | make-base-empty-namespace 14 | make-hash make-hasheq make-weak-hash make-weak-hasheq 15 | make-immutable-hash 16 | make-immutable-hasheq 17 | hash-ref hash-set! hash-remove! 18 | hash-count hash-copy hash-map hash-for-each 19 | hash-iterate-first hash-iterate-next 20 | hash-iterate-value hash-iterate-key 21 | cleanse-path 22 | exn:fail exn:fail:contract))) 23 | 24 | @(define-syntax-rule (def-base base-define base-define-syntax base-define-for-syntax 25 | base-define-struct 26 | base-if base-cond base-case base-top-interaction 27 | base-open-input-file base-apply base-prop:procedure 28 | base-free-identifier=? base-free-template-identifier=? 29 | base-free-transformer-identifier=? base-free-label-identifier=? 30 | base-collection-file-path base-collection-path 31 | base-thread) 32 | (begin 33 | (require (for-label scheme/base)) 34 | (define base-define (racket define)) 35 | (define base-define-syntax (racket define-syntax)) 36 | (define base-define-for-syntax (racket define-for-syntax)) 37 | (define base-define-struct (racket define-struct)) 38 | (define base-if (racket if)) 39 | (define base-cond (racket cond)) 40 | (define base-case (racket case)) 41 | (define base-top-interaction (racket #%top-interaction)) 42 | (define base-open-input-file (racket open-input-file)) 43 | (define base-apply (racket apply)) 44 | (define base-prop:procedure (racket prop:procedure)) 45 | (define base-free-identifier=? (racket free-identifier=?)) 46 | (define base-free-template-identifier=? (racket free-template-identifier=?)) 47 | (define base-free-transformer-identifier=? (racket free-transformer-identifier=?)) 48 | (define base-free-label-identifier=? (racket free-label-identifier=?)) 49 | (define base-collection-file-path (racket collection-file-path)) 50 | (define base-collection-path (racket collection-path)) 51 | (define base-thread (racket thread)))) 52 | @(def-base base-define base-define-syntax base-define-for-syntax base-define-struct 53 | base-if base-cond base-case base-top-interaction 54 | base-open-input-file base-apply base-prop:procedure 55 | base-free-identifier=? base-free-template-identifier=? 56 | base-free-transformer-identifier=? base-free-label-identifier=? 57 | base-collection-file-path base-collection-path 58 | base-thread) 59 | 60 | @(define-syntax-rule (additionals racket/base id ...) 61 | (begin 62 | (require (for-label (only-in racket/base id ...))) 63 | (racketblock id ...))) 64 | 65 | @(define old-vers @elem{version 372}) 66 | 67 | @title{MzScheme: Legacy Language} 68 | 69 | @defmodule[mzscheme]{ 70 | 71 | The @racketmodname[mzscheme] language provides nearly the same 72 | bindings as the @racketmodname[mzscheme] module of PLT Scheme 73 | @|old-vers| and earlier.} 74 | 75 | Unlike @|old-vers|, the @racketmodname[mzscheme] language does not 76 | include @racket[set-car!] or @racket[set-cdr!], and @racket[cons] 77 | makes immutable pairs, as in @racket[scheme/base]; those changes make 78 | modules built on @racketmodname[mzscheme] reasonably compatible with 79 | modules built on @racketmodname[scheme/base]. 80 | 81 | Otherwise, the @racketmodname[mzscheme] language shares many bindings 82 | with @racketmodname[scheme/base]. It renames a few bindings, such as 83 | @racket[syntax-object->datum] instead of @racket[syntax->datum], and 84 | it provides old versions of some syntactic forms, such as 85 | @racket[lambda] without support for keyword and optional arguments. 86 | In addition, @racketmodname[mzscheme] includes all of the exports of 87 | @racketmodname[racket/tcp] and @racketmodname[racket/udp]. 88 | 89 | @table-of-contents[] 90 | 91 | @; ---------------------------------------- 92 | 93 | @section[#:tag "Old_Syntactic_Forms"]{Old Syntactic Forms} 94 | 95 | @defform[(#%module-begin form ...)]{ 96 | 97 | Like @racket[#%plain-module-begin] from @racketmodname[scheme/base], 98 | but @racket[(require-for-syntax mzscheme)] is added to the beginning 99 | of the @racket[form] sequence, thus importing @racketmodname[mzscheme] 100 | into the transformer environment for the module body. (In contrast, 101 | @racketmodname[scheme/base] exports @racket[for-syntax] minimal 102 | transformer support, while @racketmodname[scheme] exports all of 103 | @racketmodname[scheme/base] @racket[for-syntax].)} 104 | 105 | 106 | @defform[(#%plain-module-begin form ...)]{ 107 | 108 | The same binding as @racket[#%plain-module-begin] from 109 | @racketmodname[scheme/base].} 110 | 111 | 112 | @defform[(#%plain-lambda formals body ...+)]{ 113 | 114 | The same binding as @racket[#%plain-lambda] in 115 | @racketmodname[scheme/base]. (This binding was not present in 116 | @|old-vers| and earlier.)} 117 | 118 | 119 | @deftogether[( 120 | @defform[(lambda formals body ...+)] 121 | @defform[(λ formals body ...+)] 122 | )]{ 123 | 124 | The same bindings as @racket[#%plain-lambda].} 125 | 126 | 127 | @defform*[[(#%app proc-expr arg-expr ...) 128 | (#%app)]]{ 129 | 130 | The same binding as @racket[#%plain-app] from 131 | @racketmodname[scheme/base].} 132 | 133 | @defform*[[(#%plain-app proc-expr arg-expr ...) 134 | (#%plain-app)]]{ 135 | 136 | The same binding as @racket[#%app]. (This binding was not present in 137 | @|old-vers| and earlier.)} 138 | 139 | @defform*/subs[[(define id expr) 140 | (define (head args) body ...+)] 141 | ([head id 142 | (head args)] 143 | [args (code:line arg-id ...) 144 | (code:line arg-id ... @#,racketparenfont{.} rest-id)])]{ 145 | 146 | Like @|base-define| in @racketmodname[scheme/base], but without 147 | support for keyword arguments or optional arguments.} 148 | 149 | @deftogether[( 150 | @defform*[[(define-syntax id expr) 151 | (define-syntax (head args) body ...+)]] 152 | @defform*[[(define-for-syntax id expr) 153 | (define-for-syntax (head args) body ...+)]] 154 | )]{ 155 | 156 | Like @|base-define-syntax| and @|base-define-for-syntax| in 157 | @racketmodname[scheme/base], but without support for keyword arguments 158 | or optional arguments (i.e., @racket[head] is as for @racket[define]).} 159 | 160 | @defform*[[(if test-expr then-expr else-expr) 161 | (if test-expr then-expr)]]{ 162 | 163 | Like @|base-if| in @racketmodname[scheme/base], but @racket[else-expr] 164 | defaults to @racket[(void)].} 165 | 166 | @deftogether[( 167 | @defform[(cond cond-clause ...)] 168 | @defform[(case val-expr case-clause ...)] 169 | )]{ 170 | 171 | Like @|base-cond| and @|base-case| in @racketmodname[scheme/base], but 172 | @racket[else] and @racket[=>] are recognized as unbound identifiers, 173 | instead of as the @racketmodname[scheme/base] bindings. } 174 | 175 | @defform[(fluid-let ([id expr] ...) body ...+)]{ 176 | 177 | Provides a kind of dynamic binding via mutation of the @racket[id]s. 178 | 179 | The @racket[fluid-let] form first evaluates each @racket[expr] to 180 | obtain an @defterm{entry value} for each @racket[id]. As evaluation 181 | moves into @racket[body], either though normal evaluation or a 182 | continuation jump, the current value of each @racket[id] is swapped 183 | with the entry value. On exit from @racket[body], then the current 184 | value and entry value are swapped again.} 185 | 186 | @defform/subs[(define-struct id-maybe-super (field-id ...) maybe-inspector-expr) 187 | ([maybe-inspector-expr code:blank 188 | expr])]{ 189 | 190 | Like @base-define-struct from @racket[scheme/base], but with fewer 191 | options. Each field is implicitly mutable, and the optional 192 | @racket[expr] is analogous to supplying an @racket[#:inspector] 193 | expression.} 194 | 195 | @defform[(let-struct id-maybe-super (field-id ...) body ...+)]{ 196 | 197 | Expands to 198 | 199 | @racketblock[ 200 | (let () 201 | (define-struct id-maybe-super (field-id ...)) 202 | body ...+) 203 | ]} 204 | 205 | @deftogether[( 206 | @defform[(require raw-require-spec)] 207 | @defform[(require-for-syntax raw-require-spec)] 208 | @defform[(require-for-template raw-require-spec)] 209 | @defform[(require-for-label raw-require-spec)] 210 | @defform[(provide raw-provide-spec)] 211 | @defform[(provide-for-syntax raw-provide-spec)] 212 | @defform[(provide-for-label raw-provide-spec)] 213 | )]{ 214 | 215 | Like @racket[#%require] and @racket[#%provide]. The 216 | @racketidfont{-for-syntax}, @racketidfont{-for-template}, and 217 | @racketidfont{-for-label} forms are translated to @racket[#%require] 218 | and @racket[#%provide] using @racketidfont{for-syntax}, 219 | @racketidfont{for-template}, and @racketidfont{for-label} sub-forms, 220 | respectively.} 221 | 222 | @defform[(#%datum . datum)]{ 223 | 224 | Expands to @racket[(quote datum)], even if @racket[datum] is a 225 | keyword.} 226 | 227 | @defform[(#%top-interaction . form)]{ 228 | 229 | The same as @|base-top-interaction| in @racketmodname[scheme/base].} 230 | 231 | @; ---------------------------------------- 232 | 233 | @section[#:tag "Old_Functions"]{Old Functions} 234 | 235 | @defproc[(apply [proc procedure?] [v any/c] ... [lst list?]) any]{ 236 | 237 | Like @base-apply from @racketmodname[scheme/base], but without support 238 | for keyword arguments.} 239 | 240 | @defthing[prop:procedure struct-type-property?]{ 241 | 242 | Like @base-prop:procedure from @racketmodname[scheme/base], but even 243 | if the property's value for a structure type is a procedure that 244 | accepts keyword arguments, then instances of the structure type still 245 | do not accept keyword arguments. (In contrast, if the property's value 246 | is an integer for a field index, then a keyword-accepting procedure in 247 | the field for an instance causes the instance to accept keyword 248 | arguments.)} 249 | 250 | @deftogether[( 251 | @defproc[(open-input-file [file path-string?] 252 | [mode (one-of/c 'text 'binary) 'binary] 253 | [module-mode (or-of/c 'module 'none) 'none]) 254 | input-port?] 255 | @defproc[(open-output-file [file path-string?] 256 | [mode (one-of/c 'text 'binary) 'binary] 257 | [exists (one-of/c 'error 'append 'update 258 | 'replace 'truncate 'truncate/replace) 'error]) 259 | input-port?] 260 | @defproc[(open-input-output-file [file path-string?] 261 | [mode (one-of/c 'text 'binary) 'binary] 262 | [exists (one-of/c 'error 'append 'update 263 | 'replace 'truncate 'truncate/replace) 'error]) 264 | (values input-port? output-port?)] 265 | @defproc[(with-input-from-file [file path-string?] 266 | [thunk (-> any)] 267 | [mode (one-of/c 'text 'binary) 'binary]) 268 | any] 269 | @defproc[(with-output-to-file [file path-string?] 270 | [thunk (-> any)] 271 | [mode (one-of/c 'text 'binary) 'binary] 272 | [exists (one-of/c 'error 'append 'update 273 | 'replace 'truncate 'truncate/replace) 'error]) 274 | any] 275 | @defproc[(call-with-input-file [file path-string?] 276 | [proc (input-port? -> any)] 277 | [mode (one-of/c 'text 'binary) 'binary]) 278 | any] 279 | @defproc[(call-with-output-file [file path-string?] 280 | [proc (output-port? -> any)] 281 | [mode (one-of/c 'text 'binary) 'binary] 282 | [exists (one-of/c 'error 'append 'update 283 | 'replace 'truncate 'truncate/replace) 'error]) 284 | any] 285 | )]{ 286 | 287 | Like @base-open-input-file, etc. from @racketmodname[scheme/base], but 288 | the @racket[mode], @racket[exists], and @racket[module-mode] 289 | (corresponds to @racket[#:for-module?]) arguments are not keyword 290 | arguments. When both @racket[mode] and @racket[exists] or 291 | @racket[module-mode] are accepted, they are accepted in either order. 292 | 293 | @history[#:changed "6.0.1.6" 294 | @elem{Added the @scheme[module-mode] argument to @racket[open-input-file].}]} 295 | 296 | @deftogether[( 297 | @defproc[(syntax-object->datum [stx syntax?]) any] 298 | @defproc[(datum->syntax-object [ctxt (or/c syntax? false/c)] 299 | [v any/c] 300 | [srcloc (or/c syntax? false/c 301 | (list/c any/c 302 | (or/c exact-positive-integer? false/c) 303 | (or/c exact-nonnegative-integer? false/c) 304 | (or/c exact-nonnegative-integer? false/c) 305 | (or/c exact-positive-integer? false/c)) 306 | (vector/c any/c 307 | (or/c exact-positive-integer? false/c) 308 | (or/c exact-nonnegative-integer? false/c) 309 | (or/c exact-nonnegative-integer? false/c) 310 | (or/c exact-positive-integer? false/c)))] 311 | [prop (or/c syntax? false/c) #f] 312 | [cert (or/c syntax? false/c) #f]) 313 | syntax?] 314 | )]{ 315 | 316 | The same as @racket[syntax->datum] and @racket[datum->syntax].} 317 | 318 | @deftogether[( 319 | @defproc[(module-identifier=? [a-id syntax?][b-id syntax?]) boolean?] 320 | @defproc[(module-transformer-identifier=? [a-id syntax?][b-id syntax?]) boolean?] 321 | @defproc[(module-template-identifier=? [a-id syntax?][b-id syntax?]) boolean?] 322 | @defproc[(module-label-identifier=? [a-id syntax?][b-id syntax?]) boolean?] 323 | @defproc[(free-identifier=? [a-id syntax?][b-id syntax?]) boolean?] 324 | )]{ 325 | 326 | The @racket[module-identifier=?], @|etc| functions are the same as 327 | @base-free-identifier=?, @|etc| in @racketmodname[scheme/base]. 328 | 329 | The @racket[free-identifier=?] procedure returns 330 | 331 | @racketblock[ 332 | (and (eq? (syntax-e a) (syntax-e b)) 333 | (module-identifier=? a b)) 334 | ]} 335 | 336 | 337 | @defproc[(make-namespace [mode (one-of/c 'initial 'empty) 'initial]) namespace?]{ 338 | 339 | Creates a namespace with @racketmodname[mzscheme] attached. If the 340 | @racket[mode] is empty, the namespace's top-level environment is left 341 | empty. If @racket[mode] is @racket['initial], then the namespace's 342 | top-level environment is initialized with 343 | @racket[(namespace-require/copy 'mzscheme)]. See also 344 | @racket[make-base-empty-namespace].} 345 | 346 | 347 | @defproc[(namespace-transformer-require [req any/c]) void?]{ 348 | 349 | Equivalent to @racket[(namespace-require `(for-syntax ,req))].} 350 | 351 | @deftogether[( 352 | @defproc[(transcript-on [filename any/c]) any] 353 | @defproc[(transcript-off) any] 354 | )]{ 355 | 356 | Raises @racket[exn:fail], because the operations are not supported.} 357 | 358 | 359 | @defproc*[([(hash-table? [v any/c]) 360 | hash-table?] 361 | [(hash-table? [v any/c] [flag (one-of/c 'weak 'equal 'eqv)]) 362 | hash-table?] 363 | [(hash-table? [v any/c] 364 | [flag (one-of/c 'weak 'equal 'eqv)] 365 | [flag2 (one-of/c 'weak 'equal 'eqv)]) 366 | hash-table?])]{ 367 | 368 | Returns @racket[#t] if @racket[v] is a hash table created by 369 | @racket[make-hash-table] or @racket[make-immutable-hash-table] with the 370 | given @racket[flag]s (or more), @racket[#f] otherwise. If @racket[flag2] 371 | is provided, it must be distinct from @racket[flag] and @racket['equal] 372 | cannot be used with @racket['eqv], otherwise the 373 | @racket[exn:fail:contract] exception is raised.} 374 | 375 | 376 | @defproc*[([(make-hash-table) 377 | hash-table?] 378 | [(make-hash-table [flag (one-of/c 'weak 'equal 'eqv)]) 379 | hash-table?] 380 | [(make-hash-table [flag (one-of/c 'weak 'equal 'eqv)] 381 | [flag2 (one-of/c 'weak 'equal 'eqv)]) 382 | hash-table?])]{ 383 | 384 | Creates and returns a new hash table. If provided, each @racket[flag] 385 | must one of the following: 386 | 387 | @itemize[ 388 | 389 | @item{@indexed-racket['weak] --- creates a hash table with 390 | weakly-held keys via @racket[make-weak-hash], 391 | @racket[make-weak-hasheq], or @racket[make-weak-hasheqv].} 392 | 393 | @item{@indexed-racket['equal] --- creates a hash table that compares 394 | keys using @racket[equal?] instead of @racket[eq?] using 395 | @racket[make-hash] or @racket[make-weak-hash].} 396 | 397 | @item{@indexed-racket['eqv] --- creates a hash table that compares 398 | keys using @racket[eqv?] instead of @racket[eq?] using 399 | @racket[make-hasheqv] or @racket[make-weak-hasheqv].} 400 | 401 | ] 402 | 403 | By default, key comparisons use @racket[eq?] (i.e., the hash table is 404 | created with @racket[make-hasheq]). If @racket[flag2] is 405 | redundant or @racket['equal] is provided with @racket['eqv], the 406 | @racket[exn:fail:contract] exception is raised.} 407 | 408 | 409 | @defproc*[([(make-immutable-hash-table [assocs (listof pair?)]) 410 | (and/c hash-table? immutable?)] 411 | [(make-immutable-hash-table [assocs (listof pair?)] 412 | [flag (one-of/c 'equal 'eqv)]) 413 | (and/c hash-table? immutable?)])]{ 414 | 415 | Like @racket[make-immutable-hash], @racket[make-immutable-hasheq], or 416 | @racket[make-immutable-hasheqv], depending on whether an 417 | @racket['equal] or @racket['eqv] @racket[flag] is provided.} 418 | 419 | @deftogether[( 420 | @defthing[hash-table-get procedure?] 421 | @defthing[hash-table-put! procedure?] 422 | @defthing[hash-table-remove! procedure?] 423 | @defthing[hash-table-count procedure?] 424 | @defthing[hash-table-copy procedure?] 425 | @defthing[hash-table-map procedure?] 426 | @defthing[hash-table-for-each procedure?] 427 | @defthing[hash-table-iterate-first procedure?] 428 | @defthing[hash-table-iterate-next procedure?] 429 | @defthing[hash-table-iterate-value procedure?] 430 | @defthing[hash-table-iterate-key procedure?] 431 | )]{ 432 | 433 | The same as @racket[hash-ref], @racket[hash-set!], @racket[hash-remove!], 434 | @racket[hash-count],@racket[hash-copy], @racket[hash-map], @racket[hash-for-each], 435 | @racket[hash-iterate-first], @racket[hash-iterate-next], @racket[hash-iterate-value], 436 | and @racket[hash-iterate-key], respectively.} 437 | 438 | @defthing[expand-path procedure?]{ 439 | 440 | The same as @racket[cleanse-path].} 441 | 442 | @defthing[list-immutable procedure?]{ 443 | 444 | The same as @racket[list].} 445 | 446 | @deftogether[( 447 | @defproc[(collection-file-path [file path-string?] [collection path-string?] ...+) path?] 448 | @defproc[(collection-path [collection path-string?] ...+) path?] 449 | )]{ 450 | 451 | Like @base-collection-file-path and @base-collection-path, but without 452 | the @racket[#:fail] option.} 453 | 454 | @defproc[(thread [proc procedure?] [keep (or/c #f 'results) #f]) thread?]{ 455 | 456 | Like @base-thread, but does not accept a @racket[#:pool] argument, and 457 | accepts @racket[#:keep] as by-position instead of as a keyword 458 | argument. 459 | 460 | @history[#:changed "1.1" @elem{Made binding distinct from @base-thread and 461 | added the @racket[keep] argument.}]} 462 | 463 | @; ---------------------------------------- 464 | 465 | @section{Extra Libraries} 466 | 467 | The @racketmodname[mzscheme] library re-exports 468 | @racketmodname[racket/promise], @racketmodname[racket/tcp], and 469 | @racketmodname[racket/udp]. 470 | 471 | @; ---------------------------------------- 472 | 473 | @section{Omitted Forms and Functions} 474 | 475 | In addition to forms and functions that have replacements listed in 476 | @secref["Old_Syntactic_Forms"] and @secref["Old_Functions"], the 477 | following forms and functions are exported by 478 | @racketmodname[racket/base] but not @racketmodname[mzscheme]: 479 | 480 | @additionals[ racket/base 481 | compose filter sort foldl foldr 482 | remv remq remove remv* remq* remove* memf assf findf 483 | build-vector build-string build-list 484 | hash-keys hash-values hash->list hash-set* hash-set*! 485 | hash-update hash-update! 486 | vector-copy! 487 | thread-send thread-receive thread-try-receive thread-receive-evt 488 | log-fatal log-error log-warning log-info log-debug 489 | log-message log-level? make-logger logger? 490 | current-logger logger-name make-log-receiver log-receiver? 491 | ] 492 | -------------------------------------------------------------------------------- /mzscheme-lib/compiler/main.rkt: -------------------------------------------------------------------------------- 1 | ;; Starts up the compiler according to command-line flags. 2 | ;; (c) 1997-2001 PLT 3 | 4 | ;; Scheme->C compilation is the only mode really handled 5 | ;; by the code in this collection. Other modes are handled 6 | ;; by other collections, such as MzLib and dynext. 7 | ;; If you are interested Scheme->C part of mzc, look in 8 | ;; "private/driver.rkt", which is the `main' file for the compiler. 9 | 10 | ;; Different compilation modes are driven by dynamically 11 | ;; linking in appropriate libraries. This is handled 12 | ;; by "compiler.rkt". 13 | 14 | ;; See manual for information about the Scheme-level interface 15 | ;; provided by this collection. 16 | 17 | #lang scheme/base 18 | 19 | ;; On error, exit with 1 status code 20 | (error-escape-handler (lambda () (exit 1))) 21 | 22 | (error-print-width 512) 23 | 24 | (require (prefix-in compiler:option: compiler/option) 25 | compiler/compiler) 26 | 27 | ;; Read argv array for arguments and input file name 28 | (require racket/cmdline 29 | dynext/file 30 | scheme/pretty 31 | setup/pack 32 | setup/getinfo 33 | setup/dirs 34 | racket/lazy-require) 35 | 36 | (lazy-require [dynext/compile (use-standard-compiler get-standard-compilers current-extension-compiler 37 | current-extension-compiler-flags current-extension-preprocess-flags 38 | compile-variant compile-extension)] 39 | [dynext/link (use-standard-linker expand-for-link-variant current-extension-linker 40 | current-extension-linker-flags current-standard-link-libraries 41 | link-variant link-extension)] 42 | [compiler/cm (managed-compile-zo)] 43 | [compiler/xform (xform)] 44 | [compiler/distribute (assemble-distribution)] 45 | [compiler/zo-parse (zo-parse)] 46 | [compiler/private/embed (mzc:embedding-executable-add-suffix write-module-bundle 47 | mzc:create-embedding-executable)] 48 | [compiler/decompile (decompile)]) 49 | 50 | (define dest-dir (make-parameter #f)) 51 | (define auto-dest-dir (make-parameter #f)) 52 | 53 | (define ld-output (make-parameter #f)) 54 | 55 | (define exe-output (make-parameter #f)) 56 | (define exe-embedded-flags (make-parameter '("-U" "--"))) 57 | (define exe-embedded-libraries (make-parameter null)) 58 | (define exe-aux (make-parameter null)) 59 | (define exe-embedded-config-path (make-parameter "etc")) 60 | (define exe-embedded-collects-path (make-parameter #f)) 61 | (define exe-embedded-collects-dest (make-parameter #f)) 62 | (define exe-dir-add-collects-dirs (make-parameter null)) 63 | 64 | (define exe-dir-output (make-parameter #f)) 65 | 66 | (define mods-output (make-parameter #f)) 67 | 68 | (define module-mode (make-parameter #f)) 69 | 70 | (define default-plt-name "archive") 71 | 72 | (define disable-inlining (make-parameter #f)) 73 | (define assume-primitives (make-parameter #t)) 74 | 75 | (define plt-output (make-parameter #f)) 76 | (define plt-name (make-parameter default-plt-name)) 77 | (define plt-files-replace (make-parameter #f)) 78 | (define plt-files-plt-relative? (make-parameter #f)) 79 | (define plt-files-plt-home-relative? (make-parameter #f)) 80 | (define plt-force-install-dir? (make-parameter #f)) 81 | (define plt-setup-collections (make-parameter null)) 82 | (define plt-include-compiled (make-parameter #f)) 83 | 84 | (define stop-at-source (make-parameter #f)) 85 | 86 | (define (extract-suffix appender) 87 | (bytes->string/latin-1 88 | (subbytes (path->bytes (appender (bytes->path #"x"))) 1))) 89 | 90 | ;; Returns (values mode files prefixes) 91 | ;; where mode is 'compile, 'make-zo, etc. 92 | (define (parse-options argv) 93 | (define ((add-to-param param) f v) (param (append (param) (list v)))) 94 | (parse-command-line 95 | "mzc" 96 | argv 97 | `([help-labels 98 | "-------------------------------- mode flags ---------------------------------"] 99 | [once-any 100 | [("-k" "--make") 101 | ,(lambda (f) 'make-zo) 102 | ("Recursively compile Scheme source(s); uses/generates .dep files")] 103 | [("--make-collection") 104 | ,(lambda (f) 'collection-zos) 105 | ((,(format "Makes all Scheme sources in specified collection(s)") ""))] 106 | [("--exe") 107 | ,(lambda (f name) (exe-output name) 'exe) 108 | (,(format "Embed module in Racket to create ") 109 | "exe")] 110 | [("--gui-exe") 111 | ,(lambda (f name) (exe-output name) 'gui-exe) 112 | (,(format "Embed module in GRacket to create ") 113 | "exe")] 114 | [("--exe-dir") 115 | ,(lambda (f name) (exe-dir-output name) 'exe-dir) 116 | ((,(format "Combine executables with support files in ") "") 117 | "dir")] 118 | [("--collection-plt") 119 | ,(lambda (f name) (plt-output name) 'plt-collect) 120 | (,(format "Create .plt containing collections") 121 | "archive")] 122 | [("--plt") 123 | ,(lambda (f name) (plt-output name) 'plt) 124 | ((,(format "Create .plt containing relative files/dirs") "") 125 | "archive")] 126 | [("--cc") 127 | ,(lambda (f) 'cc) 128 | (,(format "Compile arbitrary file(s) for an extension: ~a -> ~a" 129 | (extract-suffix append-c-suffix) 130 | (extract-suffix append-object-suffix)))] 131 | [("--ld") 132 | ,(lambda (f name) (ld-output name) 'ld) 133 | (,(format "Link arbitrary file(s) to create : ~a -> ~a" 134 | (extract-suffix append-object-suffix) 135 | (extract-suffix append-extension-suffix)) 136 | "extension")] 137 | [("-x" "--xform") 138 | ,(lambda (f) 'xform) 139 | ((,(format "Convert for 3m compilation: ~a -> ~a" 140 | (extract-suffix append-c-suffix) 141 | (extract-suffix append-c-suffix)) 142 | ""))] 143 | [("--c-mods") 144 | ,(lambda (f name) (mods-output name) 'c-mods) 145 | ((,(format "Write C-embeddable module bytecode to ") "") 146 | "file")] 147 | [("--expand") 148 | ,(lambda (f) 'expand) 149 | ((,(format "Write macro-expanded Scheme source(s) to stdout") ""))] 150 | [("-r" "--decompile") 151 | ,(lambda (f) 'decompile) 152 | ((,(format "Write quasi-Scheme for ~a file(s) to stdout" (extract-suffix append-zo-suffix)) ""))] 153 | [("-z" "--zo") 154 | ,(lambda (f) 'zo) 155 | ((,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-zo-suffix)) ""))]] 156 | [help-labels ""] 157 | [once-any 158 | [("--3m") 159 | ,(lambda (f) (compiler:option:3m #t)) 160 | (,(format "Compile/link for 3m, with --exe/etc.~a" 161 | (if (eq? '3m (system-type 'gc)) " [current default]" "")))] 162 | [("--cgc") 163 | ,(lambda (f) (compiler:option:3m #f)) 164 | (,(format "Compile/link for CGC, with --exe/etc.~a" 165 | (if (eq? 'cgc (system-type 'gc)) " [current default]" "")))]] 166 | [once-each 167 | [("-m" "--module") 168 | ,(lambda (f) (module-mode #t)) 169 | ("Skip eval of top-level syntax, etc. for -z")] 170 | [("-p" "--prefix") 171 | ,(lambda (f v) v) 172 | ("Add elaboration-time prefix file for -z" "file")] 173 | [("-n" "--name") 174 | ,(lambda (f name) (compiler:option:setup-prefix name)) 175 | ("Use as extra part of public low-level names" "name")]] 176 | [once-any 177 | [("-d" "--destination") 178 | ,(lambda (f d) 179 | (unless (directory-exists? d) 180 | (error 'mzc "the destination directory does not exist: ~s" d)) 181 | (dest-dir d)) 182 | ("Output -z/-x file(s) to " "dir")] 183 | [("--auto-dir") 184 | ,(lambda (f) (auto-dest-dir #t)) 185 | (,(format "Output -z to \"compiled\", -e to ~s" 186 | (path->string (build-path "compiled" "native" 187 | (system-library-subpath #f)))))]] 188 | [help-labels 189 | "----------------------- bytecode compilation flags --------------------------"] 190 | [once-each 191 | [("--no-prim") 192 | ,(lambda (f) (assume-primitives #f)) 193 | ("Do not assume `scheme' bindings at top level")] 194 | [("--disable-inline") 195 | ,(lambda (f) (disable-inlining #t)) 196 | ("Disable procedure inlining during compilation")]] 197 | [help-labels 198 | "--------------------- executable configuration flags ------------------------"] 199 | [once-each 200 | [("--config-path") 201 | ,(lambda (f i) 202 | (exe-embedded-config-path i)) 203 | ("Set configuration directory path in --[gui-]exe" "path")] 204 | [("--collects-path") 205 | ,(lambda (f i) 206 | (exe-embedded-collects-path i)) 207 | ("Set main collects in --[gui-]exe/--exe-dir" "path")] 208 | [("--collects-dest") 209 | ,(lambda (f i) (exe-embedded-collects-dest i)) 210 | ("Add --[gui-]exe collection code to " "dir")] 211 | [("--ico") 212 | ,(lambda (f i) (exe-aux (cons (cons 'ico i) (exe-aux)))) 213 | ("Windows icon for --[gui-]exe executable" ".ico-file")] 214 | [("--icns") 215 | ,(lambda (f i) (exe-aux (cons (cons 'icns i) (exe-aux)))) 216 | ("Mac OS icon for --[gui-]exe executable" ".icns-file")] 217 | [("--orig-exe") 218 | ,(lambda (f) (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))) 219 | ("Use original executable for --[gui-]exe instead of stub")]] 220 | [multi 221 | [("++lib") 222 | ,(lambda (f l) 223 | (exe-embedded-libraries (append (exe-embedded-libraries) (list l)))) 224 | ("Embed in --[gui-]exe executable or --c-mods output" "lib")] 225 | [("++collects-copy") 226 | ,(lambda (f d) 227 | (exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list d)))) 228 | ("Add collects in to --exe-dir" "dir")] 229 | [("++exf") 230 | ,(add-to-param exe-embedded-flags) 231 | ("Add flag to embed in --[gui-]exe executable" "flag")] 232 | [("--exf") 233 | ,(lambda (f v) (exe-embedded-flags (remove v (exe-embedded-flags)))) 234 | ("Remove flag to embed in --[gui-]exe executable" "flag")] 235 | [("--exf-clear") 236 | ,(lambda (f) (exe-embedded-flags null)) 237 | ("Clear flags to embed in --[gui-]exe executable")] 238 | [("--exf-show") 239 | ,(lambda (f) (printf "Flags to embed: ~s\n" (exe-embedded-flags))) 240 | ("Show flag to embed in --[gui-]exe executable")]] 241 | [help-labels 242 | "----------------------------- .plt archive flags ----------------------------"] 243 | [once-each 244 | [("--plt-name") 245 | ,(lambda (f n) (plt-name n)) 246 | ("Set the printed describing the archive" "name")] 247 | [("--replace") 248 | ,(lambda (f) (plt-files-replace #t)) 249 | ("Files in archive replace existing files when unpacked")] 250 | [("--at-plt") 251 | ,(lambda (f) (plt-files-plt-relative? #t)) 252 | ("Files/dirs in archive are relative to user's add-ons directory")]] 253 | [once-any 254 | [("--all-users") 255 | ,(lambda (f) (plt-files-plt-home-relative? #t)) 256 | ("Files/dirs in archive go to PLT installation if writable")] 257 | [("--force-all-users") 258 | ,(lambda (f) (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)) 259 | ("Files/dirs forced to PLT installation")]] 260 | [once-each 261 | [("--include-compiled") 262 | ,(lambda (f) (plt-include-compiled #t)) 263 | ("Include \"compiled\" subdirectories in the archive")]] 264 | [multi 265 | [("++setup") 266 | ,(lambda (f c) 267 | (plt-setup-collections (append (plt-setup-collections) (list c)))) 268 | ("Setup after the archive is unpacked" "collect")]] 269 | [help-labels 270 | "------------------- compiler/linker configuration flags ---------------------"] 271 | [once-each 272 | [("--tool") 273 | ,(lambda (f v) 274 | (let ([v (string->symbol v)]) 275 | (use-standard-compiler v) 276 | (use-standard-linker v))) 277 | (,(format "Use pre-defined as C compiler/linker:~a" 278 | (apply string-append 279 | (apply append (map (lambda (t) 280 | (list " " (symbol->string t))) 281 | (get-standard-compilers))))) 282 | "tool")] 283 | [("--compiler") 284 | ,(lambda (f v) (current-extension-compiler v)) 285 | ("Use as C compiler" "compiler-path")]] 286 | [multi 287 | [("++ccf") 288 | ,(add-to-param current-extension-compiler-flags) 289 | ("Add C compiler flag" "flag")] 290 | [("--ccf") 291 | ,(lambda (f v) 292 | (current-extension-compiler-flags 293 | (remove v (current-extension-compiler-flags)))) 294 | ("Remove C compiler flag" "flag")] 295 | [("--ccf-clear") 296 | ,(lambda (f) (current-extension-compiler-flags null)) 297 | ("Clear C compiler flags")] 298 | [("--ccf-show") 299 | ,(lambda (f) 300 | (printf "C compiler flags: ~s\n" 301 | (expand-for-link-variant (current-extension-compiler-flags)))) 302 | ("Show C compiler flags")]] 303 | [once-each 304 | [("--linker") 305 | ,(lambda (f v) (current-extension-linker v)) 306 | ("Use as C linker" "linker-path")]] 307 | [multi 308 | [("++ldf") 309 | ,(add-to-param current-extension-linker-flags) 310 | ("Add C linker flag" "flag")] 311 | [("--ldf") 312 | ,(lambda (f v) 313 | (current-extension-linker-flags 314 | (remove v (current-extension-linker-flags)))) 315 | ("Remove C linker flag" "flag")] 316 | [("--ldf-clear") 317 | ,(lambda (f) (current-extension-linker-flags null)) 318 | ("Clear C linker flags")] 319 | [("--ldf-show") 320 | ,(lambda (f) 321 | (printf "C linker flags: ~s\n" 322 | (expand-for-link-variant (current-extension-linker-flags)))) 323 | ("Show C linker flags")] 324 | [("++ldl") 325 | ,(add-to-param current-standard-link-libraries) 326 | ("Add C linker library" "lib")] 327 | [("--ldl-show") 328 | ,(lambda (f) 329 | (printf "C linker libraries: ~s\n" 330 | (expand-for-link-variant (current-standard-link-libraries)))) 331 | ("Show C linker libraries")]] 332 | [multi 333 | [("++cppf") 334 | ,(add-to-param current-extension-preprocess-flags) 335 | ("Add C preprocess (xform) flag" "flag")] 336 | [("--cppf") 337 | ,(lambda (f v) 338 | (current-extension-preprocess-flags 339 | (remove v (current-extension-preprocess-flags)))) 340 | ("Remove C preprocess (xform) flag" "flag")] 341 | [("--cppf-clear") 342 | ,(lambda (f) (current-extension-preprocess-flags null)) 343 | ("Clear C preprocess (xform) flags")] 344 | [("--cppf-show") 345 | ,(lambda (f) 346 | (printf "C compiler flags: ~s\n" 347 | (expand-for-link-variant (current-extension-preprocess-flags)))) 348 | ("Show C preprocess (xform) flags")]] 349 | [help-labels 350 | "-------------------------- miscellaneous flags ------------------------------"] 351 | [once-each 352 | [("-v") 353 | ,(lambda (f) (compiler:option:somewhat-verbose #t)) 354 | ("Slightly verbose mode, including version banner and output files")] 355 | [("--vv") 356 | ,(lambda (f) (compiler:option:somewhat-verbose #t) (compiler:option:verbose #t)) 357 | ("Very verbose mode")]]) 358 | (lambda (accum . files) 359 | (let ([mode (let ([l (filter symbol? accum)]) 360 | (if (null? l) 'make-zo (car l)))]) 361 | (values 362 | mode 363 | files 364 | (let ([prefixes (filter string? accum)]) 365 | (unless (or (memq mode '(zo)) (null? prefixes)) 366 | (error 'mzc "prefix files are not useful in ~a mode" mode)) 367 | (if (module-mode) 368 | (begin 369 | (unless (null? prefixes) 370 | (error 'mzc "prefix files not allowed with -m or --module")) 371 | #f) 372 | `(begin 373 | (require scheme) 374 | ,(if (assume-primitives) 375 | '(void) 376 | '(namespace-require/copy 'scheme)) 377 | ,@(map (lambda (s) `(load ,s)) prefixes) 378 | (void))))))) 379 | (list "file/directory/collection"))) 380 | 381 | (define-values (mode source-files prefix) 382 | (parse-options (current-command-line-arguments))) 383 | 384 | (define (compiler-warning) 385 | (eprintf "Warning: ~a\n ~a\n" 386 | "compilation to C is usually less effective for performance" 387 | "than relying on the bytecode just-in-time compiler.")) 388 | 389 | (when (compiler:option:somewhat-verbose) 390 | (printf "mzc v~a [~a], Copyright (c) 2004-2014 PLT Design Inc.\n" 391 | (version) 392 | (system-type 'gc))) 393 | 394 | (when (and (auto-dest-dir) (not (memq mode '(zo compile)))) 395 | (error 'mzc "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)")) 396 | 397 | (if (compiler:option:3m) 398 | (begin (link-variant '3m) (compile-variant '3m)) 399 | (begin (link-variant 'cgc) (compile-variant 'cgc))) 400 | 401 | (case mode 402 | [(zo) 403 | ((compile-zos prefix #:verbose? (compiler:option:somewhat-verbose)) 404 | source-files 405 | (if (auto-dest-dir) 'auto (dest-dir)))] 406 | [(expand) 407 | (for ([src-file source-files]) 408 | (let ([src-file (path->complete-path src-file)]) 409 | (let-values ([(base name dir?) (split-path src-file)]) 410 | (parameterize ([current-load-relative-directory base] 411 | [current-namespace (make-base-namespace)] 412 | [read-accept-reader #t]) 413 | (call-with-input-file* 414 | src-file 415 | (lambda (in) 416 | (port-count-lines! in) 417 | (let loop () 418 | (let ([e (read-syntax src-file in)]) 419 | (unless (eof-object? e) 420 | (pretty-print (syntax->datum (expand e))) 421 | (loop))))))))))] 422 | [(decompile) 423 | (for ([zo-file source-files]) 424 | (let ([zo-file (path->complete-path zo-file)]) 425 | (let-values ([(base name dir?) (split-path zo-file)]) 426 | (let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))]) 427 | (parameterize ([current-load-relative-directory base] 428 | [print-graph #t]) 429 | (pretty-print 430 | (decompile 431 | (call-with-input-file* 432 | (if (file-exists? alt-file) alt-file zo-file) 433 | (lambda (in) 434 | (zo-parse in))))))))))] 435 | [(make-zo) 436 | (let ([n (make-base-empty-namespace)] 437 | [did-one? #f]) 438 | (define manager-trace-handler 439 | (dynamic-require 'compiler/cm 'manager-trace-handler)) 440 | (define manager-compile-notify-handler 441 | (dynamic-require 'compiler/cm 'manager-compile-notify-handler)) 442 | (parameterize ([current-namespace n] 443 | [manager-trace-handler 444 | (lambda (p) 445 | (when (compiler:option:verbose) 446 | (printf " ~a\n" p)))] 447 | [manager-compile-notify-handler 448 | (lambda (p) 449 | (set! did-one? #t) 450 | (when (compiler:option:somewhat-verbose) 451 | (printf " making ~s\n" (path->string p))))]) 452 | (for ([file source-files]) 453 | (unless (file-exists? file) 454 | (error 'mzc "file does not exist: ~a" file)) 455 | (set! did-one? #f) 456 | (let ([name (extract-base-filename/ss file 'mzc)]) 457 | (when (compiler:option:somewhat-verbose) 458 | (printf "\"~a\":\n" file)) 459 | (parameterize ([compile-context-preservation-enabled 460 | (disable-inlining)]) 461 | (managed-compile-zo file)) 462 | (let ([dest (append-zo-suffix 463 | (let-values ([(base name dir?) (split-path file)]) 464 | (build-path (if (symbol? base) 'same base) 465 | "compiled" name)))]) 466 | (when (compiler:option:somewhat-verbose) 467 | (printf " [~a \"~a\"]\n" 468 | (if did-one? "output to" "already up-to-date at") 469 | dest)))))))] 470 | [(collection-zos) 471 | (parameterize ([compile-notify-handler 472 | (lambda (path) 473 | (when (compiler:option:somewhat-verbose) 474 | (printf " making ~s\n" path)))]) 475 | (apply compile-collection-zos source-files))] 476 | [(cc) 477 | (for ([file source-files]) 478 | (let* ([base (extract-base-filename/c file 'mzc)] 479 | [dest (append-object-suffix 480 | (let-values ([(base name dir?) (split-path base)]) 481 | (build-path (or (dest-dir) 'same) name)))]) 482 | (when (compiler:option:somewhat-verbose) 483 | (printf "\"~a\":\n" file)) 484 | (compile-extension (not (compiler:option:verbose)) file dest null) 485 | (when (compiler:option:somewhat-verbose) 486 | (printf " [output to \"~a\"]\n" dest))))] 487 | [(ld) 488 | (extract-base-filename/ext (ld-output) 'mzc) 489 | ;; (for ([file source-files]) (extract-base-filename/o file 'mzc)) 490 | (let ([dest (if (dest-dir) 491 | (build-path (dest-dir) (ld-output)) 492 | (ld-output))]) 493 | (when (compiler:option:somewhat-verbose) 494 | (printf "~a:\n" (let ([s (apply string-append 495 | (map (lambda (n) (format " \"~a\"" n)) 496 | source-files))]) 497 | (substring s 1 (string-length s))))) 498 | (link-extension (not (compiler:option:verbose)) 499 | source-files 500 | dest) 501 | (when (compiler:option:somewhat-verbose) 502 | (printf " [output to \"~a\"]\n" dest)))] 503 | [(xform) 504 | (for ([file source-files]) 505 | (let* ([out-file (path-replace-suffix file ".3m.c")] 506 | [out-file (if (dest-dir) 507 | (build-path (dest-dir) out-file) 508 | out-file)]) 509 | (xform 510 | (not (compiler:option:verbose)) 511 | file 512 | out-file 513 | (list (find-include-dir))) 514 | (when (compiler:option:somewhat-verbose) 515 | (printf " [output to \"~a\"]\n" out-file))))] 516 | [(exe gui-exe) 517 | (unless (= 1 (length source-files)) 518 | (error 'mzc "expected a single module source file to embed; given: ~e" 519 | source-files)) 520 | (let ([dest (mzc:embedding-executable-add-suffix 521 | (exe-output) 522 | (eq? mode 'gui-exe))]) 523 | (mzc:create-embedding-executable 524 | dest 525 | #:mred? (eq? mode 'gui-exe) 526 | #:variant (if (eq? 'racket (system-type 'vm)) 527 | (if (compiler:option:3m) '3m 'cgc) 528 | (system-type 'gc)) 529 | #:verbose? (compiler:option:verbose) 530 | #:modules (cons `(#%mzc: (file ,(car source-files))) 531 | (map (lambda (l) `(#t (lib ,l))) 532 | (exe-embedded-libraries))) 533 | #:configure-via-first-module? #t 534 | #:literal-expression 535 | (parameterize ([current-namespace (make-base-namespace)]) 536 | (compile 537 | `(namespace-require 538 | '',(string->symbol 539 | (format "#%mzc:~a" 540 | (let-values ([(base name dir?) 541 | (split-path (car source-files))]) 542 | (path->bytes (path-replace-suffix name #"")))))))) 543 | #:cmdline (exe-embedded-flags) 544 | #:collects-path (exe-embedded-collects-path) 545 | #:collects-dest (exe-embedded-collects-dest) 546 | #:aux (cons `(config-dir . ,(exe-embedded-config-path)) 547 | (exe-aux))) 548 | (when (compiler:option:somewhat-verbose) 549 | (printf " [output to \"~a\"]\n" dest)))] 550 | [(c-mods) 551 | (let ([dest (mods-output)]) 552 | (let-values ([(in out) (make-pipe)]) 553 | (parameterize ([current-output-port out]) 554 | (write-module-bundle 555 | #:modules 556 | (append (map (lambda (l) `(#f (file ,l))) source-files) 557 | (map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries))))) 558 | (close-output-port out) 559 | (let ([out (open-output-file dest #:exists 'truncate/replace)]) 560 | (fprintf out "#ifdef MZ_XFORM\n") 561 | (fprintf out "XFORM_START_SKIP;\n") 562 | (fprintf out "#endif\n") 563 | (fprintf out "static void declare_modules(Scheme_Env *env) {\n") 564 | (fprintf out " static unsigned char data[] = {") 565 | (let loop ([pos 0]) 566 | (let ([b (read-byte in)]) 567 | (when (zero? (modulo pos 20)) (fprintf out "\n ")) 568 | (unless (eof-object? b) (fprintf out "~a," b) (loop (add1 pos))))) 569 | (fprintf out "0\n };\n") 570 | (fprintf out " Scheme_Object *eload = NULL, *a[3] = {NULL, NULL, NULL};\n") 571 | (fprintf out " MZ_GC_DECL_REG(4);\n") 572 | (fprintf out " MZ_GC_VAR_IN_REG(0, eload);\n") 573 | (fprintf out " MZ_GC_ARRAY_VAR_IN_REG(1, a, 3);\n") 574 | (fprintf out " MZ_GC_REG();\n") 575 | (fprintf out " eload = scheme_builtin_value(\"embedded-load\");\n") 576 | (fprintf out " a[0] = scheme_false;\n") 577 | (fprintf out " a[1] = scheme_false;\n") 578 | (fprintf out " a[2] = scheme_make_sized_byte_string((char *)data, ~a, 0);\n" 579 | (file-position in)) 580 | (fprintf out " scheme_apply(eload, 3, a);\n") 581 | (fprintf out " MZ_GC_UNREG();\n") 582 | (fprintf out "}\n") 583 | (fprintf out "#ifdef MZ_XFORM\n") 584 | (fprintf out "XFORM_END_SKIP;\n") 585 | (fprintf out "#endif\n") 586 | (close-output-port out))) 587 | (when (compiler:option:somewhat-verbose) 588 | (printf " [output to \"~a\"]\n" dest)))] 589 | [(exe-dir) 590 | (assemble-distribution 591 | (exe-dir-output) 592 | source-files 593 | #:collects-path (exe-embedded-collects-path) 594 | #:copy-collects (exe-dir-add-collects-dirs)) 595 | (when (compiler:option:somewhat-verbose) 596 | (printf " [output to \"~a\"]\n" (exe-dir-output)))] 597 | [(plt) 598 | (for ([fd source-files]) 599 | (unless (relative-path? fd) 600 | (error 'mzc 601 | "file/directory is not relative to the current directory: \"~a\"" 602 | fd))) 603 | (pack-plt (plt-output) (plt-name) 604 | source-files 605 | #:collections (map list (plt-setup-collections)) 606 | #:file-mode (if (plt-files-replace) 'file-replace 'file) 607 | #:plt-relative? (or (plt-files-plt-relative?) 608 | (plt-files-plt-home-relative?)) 609 | #:at-plt-home? (plt-files-plt-home-relative?) 610 | #:test-plt-dirs (if (or (plt-force-install-dir?) 611 | (not (plt-files-plt-home-relative?))) 612 | #f 613 | '("collects" "doc" "include" "lib")) 614 | #:requires 615 | ;; Get current version of mzscheme for require: 616 | (let* ([i (get-info '("mzscheme"))] 617 | [v (and i (i 'version (lambda () #f)))]) 618 | (list (list '("mzscheme") v)))) 619 | (when (compiler:option:somewhat-verbose) 620 | (printf " [output to \"~a\"]\n" (plt-output)))] 621 | [(plt-collect) 622 | (pack-collections-plt 623 | (plt-output) 624 | (if (eq? default-plt-name (plt-name)) #f (plt-name)) 625 | (map (lambda (sf) 626 | (let loop ([sf sf]) 627 | (let ([m (regexp-match "^([^/]*)/(.*)$" sf)]) 628 | (if m (cons (cadr m) (loop (caddr m))) (list sf))))) 629 | source-files) 630 | #:replace? (plt-files-replace) 631 | #:extra-setup-collections (map list (plt-setup-collections)) 632 | #:file-filter (if (plt-include-compiled) 633 | (lambda (path) 634 | (or (regexp-match #rx#"compiled$" (path->bytes path)) 635 | (std-filter path))) 636 | std-filter) 637 | #:at-plt-home? (plt-files-plt-home-relative?) 638 | #:test-plt-collects? (not (plt-force-install-dir?))) 639 | (when (compiler:option:somewhat-verbose) 640 | (printf " [output to \"~a\"]\n" (plt-output)))] 641 | [else (printf "bad mode: ~a\n" mode)]) 642 | -------------------------------------------------------------------------------- /mzscheme-lib/mzscheme/examples/tree.cxx: -------------------------------------------------------------------------------- 1 | /* Example demonstrating how to inject a C++ class into the class 2 | world of MzLib's class.ss library. 3 | 4 | Since it uses C++, this example can be slightly tricky to compile. 5 | Specifying a C++ linker (e.g., g++) ensures that the right C++ 6 | libraries get included: 7 | mzc --cc tree.cxx 8 | mzc --linker /usr/bin/g++ --ld tree.so tree.o 9 | 10 | The C++ class Tree defines the following: 11 | 12 | Tree(int init_leaves); constructor 13 | 14 | int leaves; \ fields 15 | Tree *left_branch, *right_branch; / 16 | 17 | void Graft(Tree *left, Tree *right); method 18 | 19 | virtual void Grow(int n); \ overloaded and 20 | virtual void Grow(char *cmd, char *&result); / with ref param 21 | 22 | The Scheme version of the class has the following methods: 23 | 24 | "get-leaves", "get-left", "get-rght" -- gets field values 25 | "grow" -- override to replace C++ methods 26 | "graft" -- takes Scheme tree% objects 27 | 28 | Example use in Scheme: 29 | 30 | (load-extension "tree.so") ; defines tree-primitive-class and 31 | ; other things not to be used directly 32 | (load "tree-finish.ss") ; defines tree% 33 | 34 | (define o (make-object tree% 10)) 35 | (send o get-leaves) ; => 10 36 | (send o get-left) ; => #f 37 | 38 | (send o grow 2) ; grows new branches on the frontier 39 | (send o get-left) ; => # 40 | (send (send o get-left) get-leaves) ; => 2 41 | 42 | (define b (box "sunshine")) 43 | (send o grow "sunshine" b) 44 | (unbox b) ; => "sprouted left" 45 | 46 | (define apple-tree% 47 | (class tree% 48 | (inherit graft) 49 | (override grow) 50 | 51 | (define grow 52 | ;; This `grow' drops branches and grows new ones. 53 | ;; For the command-string form, it does nothing. 54 | (case-lambda 55 | [(n) 56 | (let ([l (make-object apple-tree%)] 57 | [r (make-object apple-tree%)]) 58 | (graft l r))] 59 | [(cmd result) 60 | (set-box! result (format "ignoring ~a" cmd))])) 61 | 62 | (super-instantiate () (leaves 1)))) 63 | 64 | (define a (make-object apple-tree%)) 65 | (send a get-leaves) ; => 1 66 | (send a grow 1) 67 | (send a get-left) ; => # 68 | 69 | (define o (make-object tree% 10)) 70 | (define a (make-object apple-tree%)) 71 | (send o graft a #f) 72 | (send o grow 1) ; C++ calls apple-tree%'s `grow' for `a' 73 | (send a get-left) ; -> # 74 | 75 | (send a grow "sunshine" b) 76 | (unbox b) ; => "ignoring sunshine" 77 | 78 | How it Works 79 | 80 | The class.ss library cooperates with primitive classes through a 81 | `make-primitive-class' function. The glue code in this file 82 | essentially builds up the necessary arguments to 83 | `make-primitive-class', and tree-finish.ss actually makes the 84 | call. In fact, tree.cxx knows nothing about the class 85 | implementation, and the class implementation knows nothing about 86 | the glue; they "just happen" to be compatible, but this glue could 87 | work with a variety of class implementation. 88 | 89 | The glue, furthermore, is split into two parts. The first part is 90 | specific to the Tree class. The second part is more generic, 91 | providing a fairly simple objscheme_ interface to class-specific 92 | glue, such the Tree glue. The second part can be shared for any 93 | number of C++ classes, and it is similar to code used by GRacket. 94 | */ 95 | 96 | #include "escheme.h" 97 | 98 | /**********************************************************/ 99 | /* The original C++ class: Tree */ 100 | /**********************************************************/ 101 | 102 | /* This kind of tree never grows or loses leaves. It only changes when 103 | it grows subtrees, or when subtrees are grafted onto it. We can 104 | derive new classes (in Scheme) for trees that can grow leaves and 105 | fruit. */ 106 | 107 | class Tree { 108 | private: 109 | 110 | int refcount; /* Suppose the C++ class uses reference counting. */ 111 | 112 | public: 113 | 114 | /* Public fields: */ 115 | Tree *left_branch, *right_branch; 116 | int leaves; 117 | 118 | void *user_data; /* Field that we use for pointing back to the 119 | Scheme view of the objects. The original class 120 | might not be this friendly, but for simplicity 121 | we assume that it is. The alternative is to use 122 | a hash table. */ 123 | 124 | Tree(int init_leaves) { 125 | left_branch = right_branch = NULL; 126 | leaves = init_leaves; 127 | refcount = 1; 128 | user_data = NULL; 129 | } 130 | 131 | /* The Grow method is overloaded... */ 132 | 133 | virtual void Grow(int n) { 134 | if (left_branch) 135 | left_branch->Grow(n); 136 | else 137 | left_branch = new Tree(n); 138 | if (right_branch) 139 | right_branch->Grow(n); 140 | else 141 | right_branch = new Tree(n); 142 | } 143 | 144 | virtual void Grow(char *command, char *&result) { 145 | if (!strcmp(command, "sunshine")) { 146 | if (left_branch) 147 | left_branch->Grow(command, result); 148 | else { 149 | left_branch = new Tree(1); 150 | result = "sprouted left"; 151 | } 152 | } else if (!strcmp(command, "water")) { 153 | if (right_branch) 154 | right_branch->Grow(command, result); 155 | else { 156 | right_branch = new Tree(1); 157 | result = "sprouted left"; 158 | } 159 | } else { 160 | result = "unrecognized command for growing"; 161 | } 162 | } 163 | 164 | void Graft(Tree *left, Tree *right) { 165 | Drop(left_branch); 166 | Drop(right_branch); 167 | 168 | left_branch = left; 169 | right_branch = right; 170 | 171 | Add(left_branch); 172 | Add(right_branch); 173 | } 174 | 175 | /* Note that Graft is not overrideable in C++. 176 | In Scheme, we might override this method, but 177 | the C++ code never has to know since it never 178 | calls the Graft method itself. */ 179 | 180 | /* Reference counting utils: */ 181 | 182 | static void Add(Tree *t) { 183 | if (t) 184 | t->refcount++; 185 | } 186 | static void Drop(Tree *t) { 187 | if (t) { 188 | t->refcount--; 189 | if (!t->refcount) 190 | delete t; 191 | } 192 | } 193 | }; 194 | 195 | /**********************************************************/ 196 | /* The glue class: mzTree (C++ calls to Scheme) */ 197 | /**********************************************************/ 198 | 199 | /* Forward declarations (documented further below) */ 200 | void objscheme_init(); 201 | void objscheme_add_procedures(Scheme_Env *); 202 | Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 203 | Scheme_Prim *initf, int num_methods); 204 | Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name, 205 | Scheme_Prim *f, int mina, int maxa); 206 | Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass); 207 | Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache); 208 | int objscheme_is_a(Scheme_Object *o, Scheme_Object *c); 209 | 210 | 211 | /* The # value: */ 212 | static Scheme_Object *tree_class; 213 | /* Cache for lookup of overrideable method: */ 214 | static void *grow_method_cache= NULL; 215 | /* To recognize original overrideable method: */ 216 | Scheme_Object *grow_prim; 217 | 218 | /* We keep a pointer to the Scheme object, and override the 219 | Grow method to (potentially) dispatch to Scheme. */ 220 | 221 | class mzTree : public Tree { 222 | public: 223 | mzTree(int c) : Tree(c) { } 224 | 225 | virtual void Grow(int n) { 226 | /* Check whether the Scheme class for user_data is 227 | actually a derived class that overrides `grow': */ 228 | Scheme_Object *scmobj; 229 | Scheme_Object *overriding; 230 | 231 | /* Pointer to Scheme instance kept in user_data: */ 232 | scmobj = (Scheme_Object *)user_data; 233 | 234 | /* Look for an overriding `grow' method in scmobj: */ 235 | overriding = objscheme_find_method(scmobj, 236 | "grow", 237 | &grow_method_cache); 238 | 239 | if (overriding != grow_prim) { 240 | /* Call Scheme-based overriding implementation: */ 241 | Scheme_Object *argv[2]; 242 | 243 | argv[0] = scmobj; 244 | argv[1] = scheme_make_integer(n); 245 | _scheme_apply(overriding, 2, argv); 246 | } else { 247 | /* Grow is not overridden in Scheme: */ 248 | Tree::Grow(n); 249 | } 250 | } 251 | 252 | /* Same strategy for other form of Grow, but we have to 253 | deal with the "result" parameter: */ 254 | virtual void Grow(char *cmd, char *&result) { 255 | Scheme_Object *scmobj; 256 | Scheme_Object *overriding; 257 | 258 | scmobj = (Scheme_Object *)user_data; 259 | 260 | /* Look for an overriding `grow' method in scmobj: */ 261 | overriding = objscheme_find_method(scmobj, 262 | "grow", 263 | &grow_method_cache); 264 | 265 | if (overriding != grow_prim) { 266 | /* When calling the Scheme-based overriding implementation, 267 | we implement the `result' parameter as a boxed string. 268 | The Scheme code mutates the box content to return a 269 | result. */ 270 | Scheme_Object *argv[2], *res; 271 | 272 | argv[0] = scmobj; 273 | argv[1] = scheme_make_utf8_string(cmd); 274 | argv[2] = scheme_box(scheme_make_utf8_string("")); 275 | 276 | _scheme_apply(overriding, 3, argv); 277 | 278 | res = scheme_unbox(argv[2]); 279 | if (!SCHEME_CHAR_STRINGP(res)) { 280 | scheme_wrong_type("result for tree%'s grow method", 281 | "string", -1, 0, &res); 282 | } else 283 | result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[2]), -1, NULL, 0); 284 | } else { 285 | Tree::Grow(cmd, result); 286 | } 287 | } 288 | }; 289 | 290 | /**********************************************************/ 291 | /* The glue functions (Scheme calls to C++) */ 292 | /**********************************************************/ 293 | 294 | /* Macro for accessing C++ object pointer from a Scheme object: */ 295 | #define OBJSCHEME_GET_CPP_OBJ(obj) scheme_struct_ref(obj, 0) 296 | #define OBJSCHEME_SET_CPP_OBJ(obj, v) scheme_struct_set(obj, 0, v) 297 | 298 | /* Used for finalizing: */ 299 | void FreeTree(void *scmobj, void *t) 300 | { 301 | Tree::Drop((Tree *)t); 302 | } 303 | 304 | Scheme_Object *Make_Tree(int argc, Scheme_Object **argv) 305 | { 306 | Scheme_Object *obj; 307 | 308 | /* Unfortunately, init arity is not automatically checked: */ 309 | if (argc != 2) 310 | scheme_wrong_count("tree% initialization", 2, 2, argc, argv); 311 | 312 | /* Assuming the initializer is only called through 313 | the class interface, argv[0] is always ok: */ 314 | obj = argv[0]; 315 | 316 | if (!SCHEME_INTP(argv[1])) 317 | scheme_wrong_type("tree% initialization", 318 | "fixnum", 319 | 1, argc, argv); 320 | 321 | /* Create C++ instance, and remember pointer back to Scheme instance: */ 322 | Tree *t = new mzTree(SCHEME_INT_VAL(argv[1])); 323 | t->user_data = obj; 324 | 325 | /* Store C++ pointer in Scheme object: */ 326 | OBJSCHEME_SET_CPP_OBJ(obj, (Scheme_Object *)t); 327 | 328 | /* Free C++ instance when the Scheme object is no longer referenced: */ 329 | scheme_add_finalizer(obj, FreeTree, t); 330 | 331 | return obj; 332 | } 333 | 334 | Scheme_Object *Grow(int argc, Scheme_Object **argv) 335 | { 336 | Scheme_Object *obj = argv[0]; 337 | 338 | if (argc == 2) { 339 | Tree *t; 340 | int n; 341 | 342 | if (!SCHEME_INTP(argv[1])) 343 | scheme_wrong_type("tree%'s grow", 344 | "fixnum", 345 | 1, argc, argv); 346 | n = SCHEME_INT_VAL(argv[1]); 347 | 348 | /* Extract the C++ pointer: */ 349 | t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj); 350 | 351 | /* Call method (without override check): */ 352 | t->Tree::Grow(n); 353 | } else { 354 | Tree *t; 355 | char *cmd, *result; 356 | 357 | if (!SCHEME_CHAR_STRINGP(argv[1])) 358 | scheme_wrong_type("tree%'s grow", 359 | "string", 360 | 1, argc, argv); 361 | if (!SCHEME_BOXP(argv[2]) 362 | || !SCHEME_CHAR_STRINGP(SCHEME_BOX_VAL(argv[2]))) 363 | scheme_wrong_type("tree%'s grow", 364 | "boxed string", 365 | 2, argc, argv); 366 | 367 | cmd = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(argv[1]), -1, NULL, 0); 368 | result = scheme_utf8_encode_to_buffer(SCHEME_CHAR_STR_VAL(SCHEME_BOX_VAL(argv[2])), 1, NULL, 0); 369 | 370 | /* Extract the C++ pointer: */ 371 | t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj); 372 | 373 | /* Call method (without override check): */ 374 | t->Tree::Grow(cmd, result); 375 | 376 | /* Put result back in box: */ 377 | SCHEME_BOX_VAL(argv[2]) = scheme_make_utf8_string(result); 378 | } 379 | 380 | return scheme_void; 381 | } 382 | 383 | Scheme_Object *Graft(int argc, Scheme_Object **argv) 384 | { 385 | Scheme_Object *obj = argv[0]; 386 | Tree *t, *l, *r; 387 | 388 | if (!SCHEME_FALSEP(argv[1]) && !objscheme_is_a(argv[1], tree_class)) 389 | scheme_wrong_type("tree%'s graft", 390 | "tree% object or #f", 391 | 1, argc, argv); 392 | if (!SCHEME_FALSEP(argv[2]) && !objscheme_is_a(argv[2], tree_class)) 393 | scheme_wrong_type("tree%'s graft", 394 | "tree% object or #f", 395 | 2, argc, argv); 396 | 397 | /* Extract the C++ pointer for `this': */ 398 | t = (Tree *)OBJSCHEME_GET_CPP_OBJ(obj); 399 | 400 | /* Extract the C++ pointers for the args: */ 401 | l = (SCHEME_FALSEP(argv[1]) 402 | ? (Tree *)NULL 403 | : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[1])); 404 | r = (SCHEME_FALSEP(argv[2]) 405 | ? (Tree *)NULL 406 | : (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[2])); 407 | 408 | /* Call method: */ 409 | t->Graft(l, r); 410 | 411 | return scheme_void; 412 | } 413 | 414 | Scheme_Object *MarshalTree(Tree *t) 415 | { 416 | if (!t) 417 | return scheme_false; 418 | else if (!t->user_data) { 419 | /* Object created in C++, not seen by Scheme, yet. 420 | Create a Scheme version of this object. */ 421 | Scheme_Object *scmobj; 422 | 423 | /* Make Scheme object: */ 424 | scmobj = objscheme_make_uninited_object(tree_class); 425 | 426 | /* Link C++ and Scheme objects: */ 427 | t->user_data = scmobj; 428 | OBJSCHEME_SET_CPP_OBJ(scmobj, (Scheme_Object *)t); 429 | 430 | return scmobj; 431 | } else 432 | /* Get pointer back to Scheme: */ 433 | return (Scheme_Object *)t->user_data; 434 | } 435 | 436 | Scheme_Object *Get_Left(int argc, Scheme_Object **argv) 437 | { 438 | Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]); 439 | 440 | return MarshalTree(t->left_branch); 441 | } 442 | 443 | Scheme_Object *Get_Right(int argc, Scheme_Object **argv) 444 | { 445 | Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]); 446 | 447 | return MarshalTree(t->right_branch); 448 | } 449 | 450 | Scheme_Object *Get_Leaves(int argc, Scheme_Object **argv) 451 | { 452 | Tree *t = (Tree *)OBJSCHEME_GET_CPP_OBJ(argv[0]); 453 | 454 | return scheme_make_integer(t->leaves); 455 | } 456 | 457 | /**********************************************************/ 458 | /* Extension initialization: create the Scheme class */ 459 | /**********************************************************/ 460 | 461 | Scheme_Object *scheme_reload(Scheme_Env *env) 462 | { 463 | scheme_add_global("tree-primitive-class", tree_class, env); 464 | 465 | objscheme_add_procedures(env); 466 | 467 | return scheme_void; 468 | } 469 | 470 | Scheme_Object *scheme_initialize(Scheme_Env *env) 471 | { 472 | objscheme_init(); 473 | 474 | scheme_register_extension_global(&tree_class, sizeof(tree_class)); 475 | 476 | tree_class = objscheme_make_class("tree%", /* name */ 477 | NULL, /* superclass */ 478 | Make_Tree, /* init func */ 479 | 5); /* num methods */ 480 | 481 | scheme_register_extension_global(&grow_prim, sizeof(grow_prim)); 482 | 483 | grow_prim = objscheme_add_method_w_arity(tree_class, "grow", 484 | Grow, 1, 2); 485 | (void)objscheme_add_method_w_arity(tree_class, "graft", 486 | Graft, 2, 2); 487 | 488 | (void)objscheme_add_method_w_arity(tree_class, "get-left", 489 | Get_Left, 0, 0); 490 | (void)objscheme_add_method_w_arity(tree_class, "get-right", 491 | Get_Right, 0, 0); 492 | (void)objscheme_add_method_w_arity(tree_class, "get-leaves", 493 | Get_Leaves, 0, 0); 494 | 495 | return scheme_reload(env); 496 | } 497 | 498 | 499 | Scheme_Object *scheme_module_name() 500 | { 501 | /* This extension doesn't define a module: */ 502 | return scheme_false; 503 | } 504 | 505 | /**********************************************************/ 506 | /* The generic (class-independent) C++--Scheme glue */ 507 | /**********************************************************/ 508 | 509 | /* 510 | (This code is mostly the same as code used by GRacket, and duplicating 511 | it is certainly a bad idea in principle, but putting the code in a 512 | shareable place seems like more work than is worthwhile for now.) 513 | 514 | Scheme side: 515 | ------------ 516 | 517 | This glue provides a new type, #, and several 518 | procedures: 519 | 520 | (initialize-primitive-object prim-obj v ...) - 521 | initializes the primitive object, given initialization 522 | arguments v ... 523 | 524 | (primitive-class-prepare-struct-type! prim-class gen-property 525 | gen-value preparer dispatcher) - prepares a class's struct-type for 526 | objects generated C-side; returns a constructor, predicate, 527 | and a struct:type for derived classes. The constructor and 528 | struct:type map the given dispatcher to the class. 529 | 530 | The preparer takes a symbol naming the method. It returns a 531 | value to be used in future calls to the dispatcher. 532 | 533 | The dispatcher takes two arguments: an object and a 534 | method-specific value produced by the prepaper. It returns a 535 | method procedure. 536 | 537 | (primitive-class-find-method prim-class sym) - gets the method 538 | procedure for the given symbol from the class. The procedure 539 | consumes "self" and then the rest of the arguments. 540 | 541 | C side: 542 | ------- 543 | 544 | void objscheme_init() - initializes the glue; call this first. 545 | 546 | void objscheme_add_procedures(Scheme_Env *) - installs the 547 | Scheme-side procedure listed above into the environment. 548 | 549 | Scheme_Object *objscheme_make_class(const char *name, 550 | Scheme_Object *sup, Scheme_Prim *initf, int num_methods) - 551 | creates a # representing a C++ class. The 552 | initf function is called to create and initialize the C++-side 553 | when the class is instantiated from Scheme; the first argument 554 | is the Scheme-side `self' object. The Scheme-side object is a 555 | struct, and the first field should be set to point to the C++ 556 | object. 557 | 558 | The sup argument is a # for a superclass, or 559 | scheme_false. The num_methods argument specifies the number of 560 | methods that will be added to the class. 561 | 562 | void objscheme_add_method_w_arity(Scheme_Object *c, const char 563 | *name, Scheme_Prim *f, int mina, int maxa) - adds a method to 564 | a #, specifying the method's arity as with 565 | scheme_make_prim_w_arity(). 566 | 567 | Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass) 568 | - creates a Scheme-side object for an existing C++ obj. The 569 | Scheme-side object is a struct, and the first field should be 570 | set to point to the C++ object. 571 | 572 | Scheme_Object *objscheme_find_method(Scheme_Object *obj, char 573 | *name, void **cache) - finds a method by name in a Scheme-side 574 | object. It is a Scheme procedure for the method (which takes 575 | the Scheme-side `self' as its first argument). The cache 576 | pointer should point to static, class-specific space for 577 | caching lookup information. 578 | 579 | int objscheme_is_a(Scheme_Object *o, Scheme_Object *c) - returns 1 580 | if the given Scheme-side object is an instance of the given 581 | #, 0 otherwise. 582 | 583 | */ 584 | 585 | typedef struct Objscheme_Class { 586 | Scheme_Type type; 587 | const char *name; 588 | Scheme_Object *sup; 589 | Scheme_Object *initf; 590 | int num_methods, num_installed; 591 | Scheme_Object **names; 592 | Scheme_Object **methods; 593 | Scheme_Object *base_struct_type; 594 | Scheme_Object *struct_type; 595 | } Objscheme_Class; 596 | 597 | Scheme_Type objscheme_class_type; 598 | 599 | static Scheme_Object *object_struct; 600 | static Scheme_Object *object_property; 601 | static Scheme_Object *preparer_property; 602 | static Scheme_Object *dispatcher_property; 603 | 604 | #define CONS(a, b) scheme_make_pair(a, b) 605 | 606 | /***************************************************************************/ 607 | /* Scheme-side implementation: */ 608 | 609 | static Scheme_Object *init_prim_obj(int argc, Scheme_Object **argv) 610 | { 611 | Objscheme_Class *c; 612 | Scheme_Object *obj = argv[0]; 613 | 614 | if (!SCHEME_STRUCTP(argv[0]) 615 | || !scheme_is_struct_instance(object_struct, argv[0])) 616 | scheme_wrong_type("initialize-primitive-object", "primitive-object", 0, argc, argv); 617 | 618 | c = (Objscheme_Class *)scheme_struct_type_property_ref(object_property, obj); 619 | 620 | return _scheme_apply(c->initf, argc, argv); 621 | } 622 | 623 | static Scheme_Object *class_prepare_struct_type(int argc, Scheme_Object **argv) 624 | { 625 | Scheme_Object *name, *base_stype, *stype, *derive_stype; 626 | Scheme_Object **names, **vals, *a[3], *props; 627 | Objscheme_Class *c; 628 | int flags, count; 629 | 630 | if (SCHEME_TYPE(argv[0]) != objscheme_class_type) 631 | scheme_wrong_type("primitive-class-prepare-struct-type!", "primitive-class", 0, argc, argv); 632 | if (SCHEME_TYPE(argv[1]) != scheme_struct_property_type) 633 | scheme_wrong_type("primitive-class-prepare-struct-type!", "struct-type-property", 1, argc, argv); 634 | scheme_check_proc_arity("primitive-class-prepare-struct-type!", 1, 3, argc, argv); 635 | scheme_check_proc_arity("primitive-class-prepare-struct-type!", 2, 4, argc, argv); 636 | 637 | c = ((Objscheme_Class *)argv[0]); 638 | 639 | stype = c->struct_type; 640 | 641 | name = scheme_intern_symbol(c->name); 642 | 643 | if (stype) { 644 | scheme_arg_mismatch("primitive-class-prepare-struct-type!", 645 | "struct-type already prepared for primitive-class: ", 646 | name); 647 | return NULL; 648 | } 649 | 650 | if (SCHEME_TRUEP(c->sup) && !((Objscheme_Class *)c->sup)->base_struct_type) { 651 | scheme_arg_mismatch("primitive-class-prepare-struct-type!", 652 | "super struct-type not yet prepared for primitive-class: ", 653 | name); 654 | return NULL; 655 | } 656 | 657 | /* Root for this class. */ 658 | 659 | base_stype = scheme_make_struct_type(name, 660 | (SCHEME_TRUEP(c->sup) 661 | ? ((Objscheme_Class *)c->sup)->base_struct_type 662 | : object_struct), 663 | NULL, 664 | 0, 0, NULL, 665 | NULL, NULL); 666 | c->base_struct_type = base_stype; 667 | 668 | /* Type to use when instantiating from C: */ 669 | 670 | props = CONS(CONS(object_property, 671 | argv[0]), 672 | scheme_null); 673 | 674 | stype = scheme_make_struct_type(name, 675 | base_stype, 676 | NULL, 677 | 0, 0, NULL, 678 | CONS(CONS(argv[1], argv[2]), 679 | props), 680 | NULL); 681 | 682 | c->struct_type = stype; 683 | 684 | /* Type to derive from Scheme: */ 685 | 686 | props = CONS(CONS(preparer_property, argv[3]), 687 | CONS(CONS(dispatcher_property, argv[4]), 688 | props)); 689 | 690 | derive_stype = scheme_make_struct_type(name, 691 | base_stype, 692 | NULL, 693 | 0, 0, NULL, 694 | props, 695 | NULL); 696 | 697 | /* Type to instantiate from Scheme: */ 698 | 699 | stype = scheme_make_struct_type(name, 700 | base_stype, 701 | NULL, 702 | 0, 0, NULL, 703 | CONS(CONS(argv[1], argv[2]), props), 704 | NULL); 705 | 706 | /* Need constructor from instantiate type: */ 707 | flags = (SCHEME_STRUCT_NO_TYPE 708 | | SCHEME_STRUCT_NO_PRED 709 | | SCHEME_STRUCT_NO_GET 710 | | SCHEME_STRUCT_NO_SET); 711 | names = scheme_make_struct_names(name, NULL, flags, &count); 712 | vals = scheme_make_struct_values(stype, names, count, flags); 713 | a[0] = vals[0]; 714 | 715 | /* Need predicate from base type: */ 716 | flags = (SCHEME_STRUCT_NO_TYPE 717 | | SCHEME_STRUCT_NO_CONSTR 718 | | SCHEME_STRUCT_NO_GET 719 | | SCHEME_STRUCT_NO_SET); 720 | names = scheme_make_struct_names(name, NULL, flags, &count); 721 | vals = scheme_make_struct_values(base_stype, names, count, flags); 722 | a[1] = vals[0]; 723 | 724 | /* Need derive type: */ 725 | a[2] = derive_stype; 726 | 727 | return scheme_values(3, a); 728 | } 729 | 730 | static Scheme_Object *class_find_meth(int argc, Scheme_Object **argv) 731 | { 732 | Objscheme_Class *sclass = (Objscheme_Class *)argv[0]; 733 | Scheme_Object *s; 734 | int i; 735 | 736 | if (SCHEME_TYPE(argv[0]) != objscheme_class_type) 737 | scheme_wrong_type("primitive-class-find-method", "primitive-class", 0, argc, argv); 738 | if (!SCHEME_SYMBOLP(argv[1])) 739 | scheme_wrong_type("primitive-class-find-method", "symbol", 1, argc, argv); 740 | 741 | s = argv[1]; 742 | 743 | for (i = sclass->num_installed; i--; ) { 744 | if (SAME_OBJ(sclass->names[i], s)) 745 | return sclass->methods[i]; 746 | } 747 | 748 | return scheme_false; 749 | } 750 | 751 | Scheme_Object *objscheme_make_uninited_object(Scheme_Object *sclass) 752 | { 753 | Scheme_Object *obj; 754 | Scheme_Object *stype; 755 | 756 | stype = ((Objscheme_Class *)sclass)->struct_type; 757 | if (!stype) { 758 | scheme_arg_mismatch("make-primitive-object", 759 | "struct-type not yet prepared: ", 760 | sclass); 761 | return NULL; 762 | } 763 | 764 | obj = scheme_make_struct_instance(stype, 0, NULL); 765 | 766 | return obj; 767 | } 768 | 769 | /***************************************************************************/ 770 | /* C-side implementation: */ 771 | 772 | Scheme_Object *objscheme_make_class(const char *name, Scheme_Object *sup, 773 | Scheme_Prim *initf, int num_methods) 774 | { 775 | Objscheme_Class *sclass; 776 | Scheme_Object *f, **methods, **names; 777 | 778 | sclass = (Objscheme_Class *)scheme_malloc_tagged(sizeof(Objscheme_Class)); 779 | sclass->type = objscheme_class_type; 780 | 781 | if (!sup) 782 | sup = scheme_false; 783 | 784 | sclass->name = name; 785 | sclass->sup = sup; 786 | 787 | f = scheme_make_prim(initf); 788 | sclass->initf = f; 789 | 790 | sclass->num_methods = num_methods; 791 | sclass->num_installed = 0; 792 | 793 | methods = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods); 794 | names = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * num_methods); 795 | 796 | sclass->methods = methods; 797 | sclass->names = names; 798 | 799 | return (Scheme_Object *)sclass; 800 | } 801 | 802 | Scheme_Object *objscheme_add_method_w_arity(Scheme_Object *c, const char *name, 803 | Scheme_Prim *f, int mina, int maxa) 804 | { 805 | Scheme_Object *s; 806 | Objscheme_Class *sclass; 807 | 808 | sclass = (Objscheme_Class *)c; 809 | 810 | s = scheme_make_prim_w_arity(f, name, mina + 1, (maxa < 0) ? -1 : (maxa + 1)); 811 | 812 | sclass->methods[sclass->num_installed] = s; 813 | 814 | s = scheme_intern_symbol(name); 815 | 816 | sclass->names[sclass->num_installed] = s; 817 | 818 | sclass->num_installed++; 819 | 820 | return s; 821 | } 822 | 823 | int objscheme_is_a(Scheme_Object *o, Scheme_Object *c) 824 | { 825 | Scheme_Object *a; 826 | 827 | if (!SCHEME_STRUCTP(o) || !scheme_is_struct_instance(object_struct, o)) 828 | return 0; 829 | 830 | a = scheme_struct_type_property_ref(object_property, o); 831 | 832 | while (a && (a != c)) { 833 | a = ((Objscheme_Class *)a)->sup; 834 | } 835 | 836 | return !!a; 837 | } 838 | 839 | void objscheme_init() 840 | { 841 | objscheme_class_type = scheme_make_type(""); 842 | 843 | /* Attaches a primitive class to an object: */ 844 | scheme_register_extension_global(&object_property, sizeof(object_property)); 845 | object_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-object")); 846 | 847 | /* Attaches a preparer function to a derived class: */ 848 | scheme_register_extension_global(&preparer_property, sizeof(preparer_property)); 849 | preparer_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-preparer")); 850 | 851 | /* Attaches a dispatcher function to a derived class: */ 852 | scheme_register_extension_global(&dispatcher_property, sizeof(dispatcher_property)); 853 | dispatcher_property = scheme_make_struct_type_property(scheme_intern_symbol("primitive-dispatcher")); 854 | 855 | /* The base struct type for the Scheme view of a primitive object: */ 856 | scheme_register_extension_global(&object_struct, sizeof(object_struct)); 857 | object_struct = scheme_make_struct_type(scheme_intern_symbol("primitive-object"), 858 | NULL, NULL, 859 | 0, 2, NULL, 860 | NULL, NULL); 861 | } 862 | 863 | void objscheme_add_procedures(Scheme_Env *env) 864 | { 865 | scheme_add_global("initialize-primitive-object", 866 | scheme_make_prim_w_arity(init_prim_obj, 867 | "initialize-primitive-object", 868 | 1, -1), 869 | env); 870 | 871 | scheme_add_global("primitive-class-prepare-struct-type!", 872 | scheme_make_prim_w_arity(class_prepare_struct_type, 873 | "primitive-class-prepare-struct-type!", 874 | 5, 5), 875 | env); 876 | 877 | scheme_add_global("primitive-class-find-method", 878 | scheme_make_prim_w_arity(class_find_meth, 879 | "primitive-class-find-method", 880 | 2, 2), 881 | env); 882 | } 883 | 884 | Scheme_Object *objscheme_find_method(Scheme_Object *obj, char *name, void **cache) 885 | { 886 | Scheme_Object *s, *p[2], *dispatcher; 887 | 888 | if (!obj) 889 | return NULL; 890 | 891 | dispatcher = scheme_struct_type_property_ref(dispatcher_property, (Scheme_Object *)obj); 892 | if (!dispatcher) 893 | return NULL; 894 | 895 | if (*cache) 896 | s = (Scheme_Object *)*cache; 897 | else { 898 | s = scheme_intern_symbol(name); 899 | p[0] = s; 900 | s = scheme_struct_type_property_ref(preparer_property, (Scheme_Object *)obj); 901 | if (!s) 902 | return NULL; 903 | s = scheme_apply(s, 1, p); 904 | scheme_register_extension_global((void *)cache, sizeof(Scheme_Object*)); 905 | *cache = s; 906 | } 907 | 908 | p[0] = obj; 909 | p[1] = s; 910 | return _scheme_apply(dispatcher, 2, p); 911 | } 912 | --------------------------------------------------------------------------------