From 9c1c2d7e57695be87777ff45b1613fbc0ad38a1a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 May 2000 15:55:50 +0000 Subject: [PATCH] ... original commit: 66a62c2f50bd2b8c85867be3e415c6a0b3881f20 --- collects/framework/framework.ss | 6 +- collects/framework/frameworks.ss | 5 +- collects/framework/prefs.ss | 22 +- collects/framework/splash.ss | 15 +- collects/mzlib/traceld.ss | 2 + collects/mzlib/traceldr.ss | 49 + collects/mzlib/transcr.ss | 8 + collects/mzlib/transcrr.ss | 60 + collects/mzlib/transcrs.ss | 4 + collects/mzlib/transcru.ss | 8 + collects/mzscheme/examples/README | 27 + collects/mzscheme/examples/bitmatrix.c | 294 + collects/mzscheme/examples/curses-demo.ss | 23 + collects/mzscheme/examples/curses.c | 124 + collects/mzscheme/examples/fmod.c | 59 + collects/mzscheme/examples/hello.c | 24 + collects/mzscheme/examples/helloprint.c | 27 + collects/mzscheme/examples/makeadder.c | 59 + collects/mzscheme/include/escheme.h | 44 + collects/mzscheme/include/ext.exp | 4 + collects/mzscheme/include/mzscheme.exp | 311 + collects/mzscheme/include/scheme.h | 1317 ++ collects/mzscheme/include/schemef.h | 677 + collects/mzscheme/include/schemex.h | 559 + collects/mzscheme/include/schemexm.h | 371 + collects/mzscheme/include/schexn.h | 170 + collects/mzscheme/include/schvers.h | 8 + collects/mzscheme/include/sconfig.h | 1383 ++ collects/mzscheme/include/stypes.h | 184 + collects/mzscheme/include/uconfig.h | 32 + collects/mzscheme/lib/mzdyn.c | 55 + collects/net/base64.ss | 8 + collects/net/base64r.ss | 68 + collects/net/base64s.ss | 3 + collects/net/cgi.ss | 8 + collects/net/cgir.ss | 313 + collects/net/cgis.ss | 24 + collects/net/cgiu.ss | 4 + collects/net/dns.ss | 8 + collects/net/dnsr.ss | 293 + collects/net/dnss.ss | 5 + collects/net/doc.txt | 999 ++ collects/net/head.ss | 8 + collects/net/headr.ss | 243 + collects/net/heads.ss | 12 + collects/net/imap.ss | 8 + collects/net/imapr.ss | 379 + collects/net/imaps.ss | 20 + collects/net/info.ss | 9 + collects/net/mail.ss | 8 + collects/net/mailr.ss | 105 + collects/net/mails.ss | 4 + collects/net/mailu.ss | 4 + collects/net/nntp.sd | 128 + collects/net/nntp.ss | 8 + collects/net/nntpr.ss | 281 + collects/net/nntps.ss | 19 + collects/net/nntpu.ss | 5 + collects/net/pop3.ss | 32 + collects/net/pop3r.ss | 403 + collects/net/pop3s.ss | 26 + collects/net/pop3u.ss | 5 + collects/net/smtp.ss | 8 + collects/net/smtpr.ss | 101 + collects/net/smtps.ss | 4 + collects/net/url.ss | 20 + collects/net/urlr.ss | 525 + collects/net/urls.ss | 18 + collects/net/urlu.ss | 5 + collects/quasiquote/qq-client.ss | 230 + collects/quasiquote/qq.ss | 22 + collects/quasiquote/qqguir.ss | 21 + collects/quasiquote/qqr.ss | 98 + collects/quasiquote/qqs.ss | 11 + collects/quasiquote/qqu.ss | 8 + collects/readline/doc.txt | 54 + collects/readline/info.ss | 10 + collects/readline/mzmake.ss | 116 + collects/readline/mzrl.c | 94 + collects/readline/pread.ss | 61 + collects/readline/readline.ss | 2 + collects/readline/rep.ss | 10 + collects/setup/doc.txt | 289 + collects/setup/info.ss | 12 + collects/setup/pack.ss | 100 + collects/setup/setup-optionr.ss | 19 + collects/setup/setup.ss | 91 + collects/setup/setupr.ss | 587 + collects/setup/setupsig.ss | 20 + collects/slatex/doc.txt | 38 + collects/slatex/info.ss | 23 + collects/slatex/slatex-code/2col.tex | 54 + collects/slatex/slatex-code/8pt.tex | 49 + collects/slatex/slatex-code/README | 114 + collects/slatex/slatex-code/aliases.scm | 125 + collects/slatex/slatex-code/batconfg.lsp | 197 + collects/slatex/slatex-code/batconfg.scm | 206 + collects/slatex/slatex-code/cfg4lsp.lsp | 7 + collects/slatex/slatex-code/cfg4scm.scm | 10 + collects/slatex/slatex-code/cltl.sty | 57 + collects/slatex/slatex-code/codeset.scm | 259 + collects/slatex/slatex-code/config.dat | 12 + collects/slatex/slatex-code/config.scm | 7 + collects/slatex/slatex-code/copying | 25 + collects/slatex/slatex-code/defaults.scm | 139 + collects/slatex/slatex-code/defun.tex | 24 + collects/slatex/slatex-code/fileproc.scm | 59 + collects/slatex/slatex-code/helpers.scm | 197 + collects/slatex/slatex-code/history | 180 + collects/slatex/slatex-code/index.tex | 233 + collects/slatex/slatex-code/install | 173 + collects/slatex/slatex-code/lerror.scm | 131 + collects/slatex/slatex-code/manifest | 81 + collects/slatex/slatex-code/margins.tex | 11 + collects/slatex/slatex-code/pathproc.scm | 158 + collects/slatex/slatex-code/peephole.scm | 397 + collects/slatex/slatex-code/preproc.lsp | 157 + collects/slatex/slatex-code/preproc.scm | 247 + collects/slatex/slatex-code/proctex.scm | 245 + collects/slatex/slatex-code/proctex2.scm | 451 + collects/slatex/slatex-code/s4.scm | 102 + collects/slatex/slatex-code/seqprocs.scm | 193 + collects/slatex/slatex-code/slaconfg.lsp | 103 + collects/slatex/slatex-code/slaconfg.scm | 155 + collects/slatex/slatex-code/slatex.sty | 569 + collects/slatex/slatex-code/slatxdoc.dvi | Bin 0 -> 62944 bytes collects/slatex/slatex-code/slatxdoc.tex | 1777 +++ collects/slatex/slatex-code/structs.scm | 107 + collects/slatex/slatex-code/tex2html.css | 68 + collects/slatex/slatex-code/tex2html.tex | 810 ++ collects/slatex/slatex-code/texread.scm | 229 + collects/slatex/slatex-code/version | 1 + collects/slatex/slatex-launcher.scm | 15 + collects/slatex/slatex.ss | 51 + collects/slatex/slatexsrc.ss | 1 + collects/slibinit/doc.txt | 23 + collects/slibinit/init.ss | 315 + collects/srpersist/doc.txt | 2507 ++++ collects/srpersist/info.ss | 19 + collects/srpersist/invoke-1.0.ss | 3 + collects/srpersist/invoke-2.0.ss | 3 + collects/srpersist/invoke-3.0.ss | 3 + collects/srpersist/invoke-3.5.ss | 4 + collects/srpersist/lib/win32/i386/srpmain.dll | Bin 0 -> 159744 bytes collects/srpersist/sigs.ss | 327 + collects/srpersist/srpersist.ss | 22 + collects/srpersist/srpersistu.ss | 67 + collects/srpersist/tutorial.txt | 185 + collects/stepper/annotater.ss | 858 ++ collects/stepper/break.ss | 26 + collects/stepper/client-procs.ss | 14 + collects/stepper/debug-wrapper.ss | 40 + collects/stepper/doc.txt | 37 + collects/stepper/fake-model.ss | 19 + collects/stepper/info.ss | 7 + collects/stepper/instance.ss | 46 + collects/stepper/link-jr.ss | 42 + collects/stepper/link.ss | 72 + collects/stepper/marks.ss | 84 + collects/stepper/model.ss | 271 + collects/stepper/reconstructr.ss | 557 + collects/stepper/sharedr.ss | 134 + collects/stepper/sig.ss | 106 + collects/stepper/startup.ss | 52 + collects/stepper/tests/main.ss | 22 + collects/stepper/utils.ss | 133 + collects/stepper/view-controller.ss | 394 + collects/tests/addrhack.c | 53 + collects/tests/drscheme/README | 85 + collects/tests/drscheme/check-syntax-test.ss | 52 + collects/tests/drscheme/config-lang-test.ss | 76 + collects/tests/drscheme/drscheme-test-util.ss | 337 + collects/tests/drscheme/drscheme-test.ss | 47 + collects/tests/drscheme/event-efficency.ss | 63 + collects/tests/drscheme/io.ss | 35 + collects/tests/drscheme/language-test.ss | 545 + collects/tests/drscheme/launcher.ss | 96 + collects/tests/drscheme/line-art.ss | 27 + collects/tests/drscheme/menu-test.ss | 82 + collects/tests/drscheme/pr-144.ss | 106 + collects/tests/drscheme/pr-17.ss | 69 + collects/tests/drscheme/pr-246.ss | 47 + collects/tests/drscheme/pr-39.ss | 8 + collects/tests/drscheme/pr-46.ss | 35 + collects/tests/drscheme/pr-48.ss | 383 + collects/tests/drscheme/pr-51.dir/1.ss | 3 + collects/tests/drscheme/pr-51.dir/2.ss | 3 + collects/tests/drscheme/pr-51.ss | 5 + collects/tests/drscheme/pr-58.ss | 54 + collects/tests/drscheme/pr-80.ss | 29 + collects/tests/drscheme/pr-99.ss | 11 + collects/tests/drscheme/repl-test.ss | 490 + collects/tests/drscheme/sample-solutions.ss | 131 + collects/tests/drscheme/sig.ss | 26 + collects/tests/drscheme/sixlib.ss | 250 + collects/tests/drscheme/syncheck/basic.ss | 25 + collects/tests/drscheme/syncheck/circle.ss | 14 + collects/tests/drscheme/syncheck/generate.ss | 34 + collects/tests/drscheme/syncheck/lots.ss | 14 + collects/tests/drscheme/tool.ss | 206 + collects/tests/framework/info.ss | 14 + collects/tests/framework/key-specs.ss | 29 + collects/tests/framework/paren-test.ss | 139 + collects/tests/framework/send-sexp.ss | 11 + collects/tests/framework/utils.ss | 13 + collects/tests/info.ss | 13 + collects/tests/mred/auto.ss | 4 + collects/tests/mred/classhack.c | 149 + collects/tests/mred/frame-edit.ss | 73 + collects/tests/mred/gui-main.ss | 89 + collects/tests/mred/gui.ss | 5 + collects/tests/mred/imred.ss | 70 + collects/tests/mred/mediastream.ss | 60 + collects/tests/mred/random.ss | 1028 ++ collects/tests/mred/showkey.ss | 40 + collects/tests/mysterx/README | 26 + collects/tests/mysterx/dhtmltests.ss | 133 + collects/tests/mysterx/mystests.ss | 71 + collects/tests/mysterx/src/Makefile | 2 + collects/tests/mysterx/src/resource.h | 18 + collects/tests/mysterx/src/stdafx.cxx | 12 + collects/tests/mysterx/src/stdafx.h | 28 + collects/tests/mysterx/src/testcont.bmp | Bin 0 -> 246 bytes collects/tests/mysterx/src/testcontrol.cxx | 51 + collects/tests/mysterx/src/testcontrol.h | 172 + collects/tests/mysterx/src/testcontrol.rgs | 34 + collects/tests/mysterx/src/testobject.cxx | 72 + collects/tests/mysterx/src/testobject.def | 9 + collects/tests/mysterx/src/testobject.idl | 66 + collects/tests/mysterx/src/testobject.mak | 48 + collects/tests/mysterx/src/testobject.rc | 132 + collects/tests/mysterx/src/testobjectCP.h | 179 + collects/tests/mzscheme/README | 44 + collects/tests/mzscheme/all.ss | 40 + collects/tests/mzscheme/basic.ss | 1494 ++ collects/tests/mzscheme/censor.ss | 30 + collects/tests/mzscheme/chkdoc.ss | 28 + collects/tests/mzscheme/classd.ss | 147 + collects/tests/mzscheme/cmdline.ss | 159 + collects/tests/mzscheme/compfile.ss | 11 + collects/tests/mzscheme/compile.ss | 86 + collects/tests/mzscheme/compilex.ss | 14 + collects/tests/mzscheme/contmark.ss | 214 + collects/tests/mzscheme/date.ss | 42 + collects/tests/mzscheme/deep.ss | 126 + collects/tests/mzscheme/em-imp.ss | 467 + collects/tests/mzscheme/expand.ss | 26 + collects/tests/mzscheme/fact.ss | 6 + collects/tests/mzscheme/file.ss | 677 + collects/tests/mzscheme/function.ss | 69 + collects/tests/mzscheme/hashper.ss | 57 + collects/tests/mzscheme/image.ss | 32 + collects/tests/mzscheme/ktest.ss | 11 + collects/tests/mzscheme/loadable.ss | 1 + collects/tests/mzscheme/loop.ss | 29 + collects/tests/mzscheme/ltest.ss | 88 + collects/tests/mzscheme/macro.ss | 35 + collects/tests/mzscheme/macrolib.ss | 195 + collects/tests/mzscheme/makeflat.ss | 60 + collects/tests/mzscheme/multi-expand.ss | 82 + collects/tests/mzscheme/mzlib.ss | 32 + collects/tests/mzscheme/mzthr.ss | 75 + collects/tests/mzscheme/name.ss | 105 + collects/tests/mzscheme/namespac.ss | 104 + collects/tests/mzscheme/nch.ss | 30 + collects/tests/mzscheme/number.ss | 1797 +++ collects/tests/mzscheme/numstrs.ss | 168 + collects/tests/mzscheme/object.ss | 651 + collects/tests/mzscheme/oe.ss | 42 + collects/tests/mzscheme/oee.ss | 45 + collects/tests/mzscheme/optimize.ss | 60 + collects/tests/mzscheme/parallel.ss | 57 + collects/tests/mzscheme/param.ss | 388 + collects/tests/mzscheme/path.ss | 397 + collects/tests/mzscheme/pconvert.ss | 369 + collects/tests/mzscheme/pretty.ss | 110 + collects/tests/mzscheme/quiet.ss | 9 + collects/tests/mzscheme/read.ss | 169 + collects/tests/mzscheme/stream.ss | 305 + collects/tests/mzscheme/struct.ss | 234 + collects/tests/mzscheme/structc.ss | 182 + collects/tests/mzscheme/syntax.ss | 948 ++ collects/tests/mzscheme/tcp.ss | 59 + collects/tests/mzscheme/testing.ss | 250 + collects/tests/mzscheme/thread.ss | 369 + collects/tests/mzscheme/thrport.ss | 59 + collects/tests/mzscheme/ttt/listlib.ss | 42 + collects/tests/mzscheme/ttt/tic-bang.ss | 123 + collects/tests/mzscheme/ttt/tic-func.ss | 120 + collects/tests/mzscheme/ttt/ttt.ss | 14 + collects/tests/mzscheme/ttt/uinc4.ss | 7 + collects/tests/mzscheme/ttt/veclib.ss | 57 + collects/tests/mzscheme/uinc.ss | 2 + collects/tests/mzscheme/uinc2.ss | 2 + collects/tests/mzscheme/uinc3.ss | 6 + collects/tests/mzscheme/unit.ss | 524 + collects/tests/mzscheme/unitsig.ss | 502 + collects/tests/mzscheme/will.ss | 59 + collects/tests/mzscheme/ztest.ss | 20 + collects/tests/utils/guir.ss | 42 + collects/tests/utils/guis.ss | 2 + collects/texpict/doc.txt | 326 + collects/texpict/mztp.sty | 9 + collects/texpict/render.ss | 122 + collects/texpict/texpict.ss | 13 + collects/texpict/texpictr.ss | 1119 ++ collects/texpict/texpicts.ss | 121 + collects/typeset/doc.txt | 106 + collects/typeset/tool-sig.ss | 22 + collects/typeset/tool.ss | 345 + collects/typeset/utils.ss | 957 ++ collects/userspce/advancedr.ss | 13 + collects/userspce/basis.ss | 28 + collects/userspce/doc.txt | 31 + collects/userspce/errorr.ss | 22 + collects/userspce/errors.ss | 1 + collects/userspce/info.ss | 20 + collects/userspce/init-namespacer.ss | 155 + collects/userspce/init-paramr.ss | 715 + collects/userspce/interface.ss | 55 + collects/userspce/launcher-bootstrap.ss | 52 + collects/userspce/paramr.ss | 5 + collects/userspce/params.ss | 4 + collects/userspce/ricedefr.ss | 129 + collects/userspce/ricedefs.ss | 8 + collects/userspce/sig.ss | 158 + collects/userspce/userspce.ss | 17 + collects/userspce/userspcr.ss | 5 + collects/xml/doc.txt | 177 + collects/xml/info.ss | 10 + collects/xml/reader.ss | 346 + collects/xml/space.ss | 28 + collects/xml/structures.ss | 43 + collects/xml/writer.ss | 130 + collects/xml/xexpr.ss | 82 + collects/xml/xml.ss | 9 + collects/xml/xmlr.ss | 9 + collects/xml/xmls.ss | 23 + collects/zodiac/back.ss | 85 + collects/zodiac/basestr.ss | 19 + collects/zodiac/corelate.ss | 34 + collects/zodiac/doc.txt | 195 + collects/zodiac/info.ss | 13 + collects/zodiac/invoke.ss | 79 + collects/zodiac/link.ss | 80 + collects/zodiac/load.ss | 12 + collects/zodiac/make.ss | 27 + collects/zodiac/misc.ss | 46 + collects/zodiac/pattern.ss | 151 + collects/zodiac/quasi.ss | 121 + collects/zodiac/reader.ss | 382 + collects/zodiac/readstr.ss | 44 + collects/zodiac/scanner.ss | 747 + collects/zodiac/scanparm.ss | 81 + collects/zodiac/scanstr.ss | 18 + collects/zodiac/scm-core.ss | 896 ++ collects/zodiac/scm-hanc.ss | 2126 +++ collects/zodiac/scm-main.ss | 2252 +++ collects/zodiac/scm-obj.ss | 830 ++ collects/zodiac/scm-ou.ss | 48 + collects/zodiac/scm-spdy.ss | 535 + collects/zodiac/scm-unit.ss | 1168 ++ collects/zodiac/sexp.ss | 278 + collects/zodiac/sigs.ss | 209 + collects/zodiac/x.ss | 381 + collects/zodiac/zsigs.ss | 96 + install | 158 + man/man1/drscheme-jr.1 | 127 + man/man1/drscheme.1 | 60 + notes/COPYING.LIB | 481 + notes/drscheme/HISTORY | 596 + notes/drscheme/OPENBUGS | 19 + notes/mred/FONTS | 410 + notes/mred/MrEd.ad | 26 + notes/mred/OPENBUGS | 39 + notes/mred/fonts12.mre | Bin 0 -> 15724 bytes notes/mred/fontsall.mre | Bin 0 -> 18455 bytes notes/mred/mred.fnt | 8 + notes/mred/mred.ini | 8 + notes/mrspidey/HISTORY | 24 + notes/mysterx/HISTORY | 98 + notes/mzc/OPENBUGS | 2 + notes/mzcom/HISTORY | 5 + notes/mzscheme/HISTORY | 1085 ++ notes/mzscheme/OPENBUGS | 34 + notes/releases/53.html | 73 + notes/releases/releases.html | 37 + notes/srpersist/HISTORY | 10 + notes/stepper/DESIGN-NOTES | 486 + notes/stepper/HISTORY | 9 + notes/stepper/OPEN-BUGS | 6 + notes/teachpack/HISTORY | 91 + src/Makefile.in | 30 + src/README | 133 + src/a-list/A List Demo Ä.sit.hqx | 2627 ++++ src/a-list/ReadMe - The A List | 143 + src/a-list/The A List.mcp (Pro 3).sit.hqx | 204 + src/a-list/The A List.mcp (Pro 4).sit.hqx | 248 + src/a-list/The A List.mcp (Pro 5).sit.hqx | 292 + src/a-list/Version History - The A List | 215 + src/configure | 2708 ++++ src/cw.sit.hqx | 2085 +++ src/drjava/SchemeValue.c | 27 + src/drjava/build.ss | 204 + src/drjava/file-utils.ss | 40 + src/drjava/gen-wrappers.ss | 103 + src/drjava/hello.c | 640 + src/drjava/java/edu/rice/cs/drj/Env$$$.java | 94 + .../java/edu/rice/cs/drj/ReadFromScheme.java | 13 + .../java/edu/rice/cs/drj/SchemeFunction.java | 16 + .../java/edu/rice/cs/drj/SchemeList.java | 30 + .../java/edu/rice/cs/drj/SchemeValue.java | 10 + .../java/edu/rice/cs/drj/WriteToScheme.java | 13 + src/drjava/mzjvm.h | 34 + src/mac/mred/MrEdSetup.h | 30 + src/mac/mred/boundary.h | 13 + src/mac/mred/boundary_alpha.cc | 14 + src/mac/mred/boundary_beta.cc | 2 + src/mac/mred/boundary_omega.cc | 9 + src/mac/mred/wxGWin.pch | 40 + src/mac/mred/wxspre.pch | 12 + src/mac/mzscheme/maccfm.h | 2 + src/mac/mzscheme/macconf.h | 26 + src/mac/mzscheme/mzpre.pch | 9 + src/mac/mzscheme/simpledrop.c | 304 + src/mac/mzscheme/simpledrop.h | 15 + src/mac/starter/mrstart.h | 11 + src/mac/starter/mzstart.h | 11 + src/mac/starter/starter.c | 291 + src/mred/GNUmakefile.in | 115 + src/mred/Make.env.in | 80 + src/mred/README | 8 + src/mred/gc2/GNUmakefile.in | 455 + src/mred/misc/checkm.c | 261 + src/mred/misc/dl_stub.c | 32 + src/mred/misc/sgilinkhack.cxx | 11 + src/mred/mred.cxx | 2902 ++++ src/mred/mred.h | 96 + src/mred/mredmac.cxx | 774 + src/mred/mredmsw.cxx | 429 + src/mred/mredx.cxx | 579 + src/mred/wrap/Makefile.in | 19 + src/mred/wrap/export.ss | 70 + src/mred/wrap/import.ss | 44 + src/mred/wrap/macros.ss | 47 + src/mred/wrap/makewrap.bat | 4 + src/mred/wrap/mkwrap.ss | 128 + src/mred/wrap/propgate.ss | 92 + src/mred/wxme/GNUmakefile.in | 69 + src/mred/wxme/wx_cgrec.cxx | 480 + src/mred/wxme/wx_cgrec.h | 147 + src/mred/wxme/wx_gcrct.h | 30 + src/mred/wxme/wx_keym.cxx | 1025 ++ src/mred/wxme/wx_keym.h | 123 + src/mred/wxme/wx_madm.h | 137 + src/mred/wxme/wx_mbuf.cxx | 2355 ++++ src/mred/wxme/wx_medad.cxx | 1712 +++ src/mred/wxme/wx_medad.h | 484 + src/mred/wxme/wx_media.cxx | 4292 ++++++ src/mred/wxme/wx_media.h | 625 + src/mred/wxme/wx_medio.cxx | 805 ++ src/mred/wxme/wx_medio.h | 234 + src/mred/wxme/wx_medpb.h | 252 + src/mred/wxme/wx_mline.cxx | 1292 ++ src/mred/wxme/wx_mline.h | 118 + src/mred/wxme/wx_mpbrd.cxx | 3040 ++++ src/mred/wxme/wx_mpriv.cxx | 2997 ++++ src/mred/wxme/wx_mpriv.h | 36 + src/mred/wxme/wx_msnip.cxx | 1048 ++ src/mred/wxme/wx_mtype.h | 36 + src/mred/wxme/wx_ptreq.h | 8 + src/mred/wxme/wx_snip.cxx | 2042 +++ src/mred/wxme/wx_snip.h | 517 + src/mred/wxme/wx_style.cxx | 1730 +++ src/mred/wxme/wx_style.h | 247 + src/mred/wxs/GNUmakefile.in | 188 + src/mred/wxs/cb_end.xci | 29 + src/mred/wxs/cb_start.xci | 12 + src/mred/wxs/cbgen_s.xci | 30 + src/mred/wxs/cwrap.inc | 6260 +++++++++ src/mred/wxs/danger.tst | 17 + src/mred/wxs/list.xci | 115 + src/mred/wxs/prefix.xci | 3 + src/mred/wxs/range.xci | 5 + src/mred/wxs/vector.xci | 86 + src/mred/wxs/wrap.inc | 11736 ++++++++++++++++ src/mred/wxs/wxs.xci | 26 + src/mred/wxs/wxs_bkt.xci | 8 + src/mred/wxs/wxs_bmap.cxx | 528 + src/mred/wxs/wxs_bmap.h | 8 + src/mred/wxs/wxs_bmap.xc | 43 + src/mred/wxs/wxs_bmt.xci | 18 + src/mred/wxs/wxs_butn.cxx | 798 ++ src/mred/wxs/wxs_butn.h | 23 + src/mred/wxs/wxs_butn.xc | 33 + src/mred/wxs/wxs_char.xci | 2 + src/mred/wxs/wxs_chce.cxx | 977 ++ src/mred/wxs/wxs_chce.h | 17 + src/mred/wxs/wxs_chce.xc | 43 + src/mred/wxs/wxs_ckbx.cxx | 824 ++ src/mred/wxs/wxs_ckbx.h | 23 + src/mred/wxs/wxs_ckbx.xc | 31 + src/mred/wxs/wxs_cnvs.cxx | 1289 ++ src/mred/wxs/wxs_cnvs.h | 25 + src/mred/wxs/wxs_cnvs.xc | 71 + src/mred/wxs/wxs_cnvs.xci | 5 + src/mred/wxs/wxs_cret.xci | 7 + src/mred/wxs/wxs_dc.cxx | 2172 +++ src/mred/wxs/wxs_dc.h | 51 + src/mred/wxs/wxs_dc.xc | 301 + src/mred/wxs/wxs_dorf.xci | 2 + src/mred/wxs/wxs_draw.xci | 27 + src/mred/wxs/wxs_drwf.xci | 34 + src/mred/wxs/wxs_drws.xci | 6 + src/mred/wxs/wxs_eds.xci | 19 + src/mred/wxs/wxs_eop.xci | 14 + src/mred/wxs/wxs_espc.xci | 3 + src/mred/wxs/wxs_evnt.cxx | 2477 ++++ src/mred/wxs/wxs_evnt.h | 38 + src/mred/wxs/wxs_evnt.xc | 203 + src/mred/wxs/wxs_fcs.xci | 15 + src/mred/wxs/wxs_fram.cxx | 1217 ++ src/mred/wxs/wxs_fram.h | 22 + src/mred/wxs/wxs_fram.xc | 90 + src/mred/wxs/wxs_fram.xci | 3 + src/mred/wxs/wxs_gage.cxx | 755 + src/mred/wxs/wxs_gage.h | 17 + src/mred/wxs/wxs_gage.xc | 79 + src/mred/wxs/wxs_gdi.cxx | 4440 ++++++ src/mred/wxs/wxs_gdi.h | 108 + src/mred/wxs/wxs_gdi.xc | 356 + src/mred/wxs/wxs_glob.cxx | 648 + src/mred/wxs/wxs_glob.h | 7 + src/mred/wxs/wxs_glob.xc | 112 + src/mred/wxs/wxs_icol.xci | 8 + src/mred/wxs/wxs_ifnt.xci | 5 + src/mred/wxs/wxs_item.cxx | 872 ++ src/mred/wxs/wxs_item.h | 30 + src/mred/wxs/wxs_item.xc | 41 + src/mred/wxs/wxs_item.xci | 3 + src/mred/wxs/wxs_lbox.cxx | 1350 ++ src/mred/wxs/wxs_lbox.h | 17 + src/mred/wxs/wxs_lbox.xc | 94 + src/mred/wxs/wxs_madm.cxx | 4562 ++++++ src/mred/wxs/wxs_madm.h | 108 + src/mred/wxs/wxs_madm.xc | 284 + src/mred/wxs/wxs_madm.xci | 10 + src/mred/wxs/wxs_mbuf.xci | 87 + src/mred/wxs/wxs_mede.cxx | 7716 ++++++++++ src/mred/wxs/wxs_mede.h | 92 + src/mred/wxs/wxs_mede.xc | 308 + src/mred/wxs/wxs_medi.cxx | 5478 ++++++++ src/mred/wxs/wxs_medi.h | 91 + src/mred/wxs/wxs_medi.xc | 194 + src/mred/wxs/wxs_menu.cxx | 1127 ++ src/mred/wxs/wxs_menu.h | 28 + src/mred/wxs/wxs_menu.xc | 145 + src/mred/wxs/wxs_mio.cxx | 2220 +++ src/mred/wxs/wxs_mio.h | 46 + src/mred/wxs/wxs_mio.xc | 183 + src/mred/wxs/wxs_misc.cxx | 1725 +++ src/mred/wxs/wxs_misc.h | 30 + src/mred/wxs/wxs_misc.xc | 200 + src/mred/wxs/wxs_mpb.cxx | 6028 ++++++++ src/mred/wxs/wxs_mpb.h | 159 + src/mred/wxs/wxs_mpb.xc | 102 + src/mred/wxs/wxs_obj.cxx | 173 + src/mred/wxs/wxs_obj.h | 8 + src/mred/wxs/wxs_obj.xc | 15 + src/mred/wxs/wxs_ornt.xci | 5 + src/mred/wxs/wxs_panl.cxx | 1839 +++ src/mred/wxs/wxs_panl.h | 42 + src/mred/wxs/wxs_panl.xc | 87 + src/mred/wxs/wxs_panl.xci | 16 + src/mred/wxs/wxs_rado.cxx | 1206 ++ src/mred/wxs/wxs_rado.h | 19 + src/mred/wxs/wxs_rado.xc | 61 + src/mred/wxs/wxs_slid.cxx | 726 + src/mred/wxs/wxs_slid.h | 17 + src/mred/wxs/wxs_slid.xc | 36 + src/mred/wxs/wxs_snip.cxx | 10361 ++++++++++++++ src/mred/wxs/wxs_snip.h | 288 + src/mred/wxs/wxs_snip.xc | 202 + src/mred/wxs/wxs_snip.xci | 30 + src/mred/wxs/wxs_styl.cxx | 3382 +++++ src/mred/wxs/wxs_styl.h | 77 + src/mred/wxs/wxs_styl.xc | 247 + src/mred/wxs/wxs_win.cxx | 1260 ++ src/mred/wxs/wxs_win.h | 20 + src/mred/wxs/wxs_win.xc | 106 + src/mred/wxs/wxs_win.xci | 11 + src/mred/wxs/wxscheme.cxx | 1841 +++ src/mred/wxs/wxscheme.h | 13 + src/mred/wxs/wxsmred.h | 26 + src/mysterx/Makefile | 40 + src/mysterx/README | 13 + src/mysterx/array.cxx | 313 + src/mysterx/browser.cxx | 426 + src/mysterx/comtypes.cxx | 161 + src/mysterx/htmlevent.cxx | 300 + src/mysterx/htmlutil.cxx | 1150 ++ src/mysterx/htmlutil.h | 228 + src/mysterx/mysc/bstr.cxx | 76 + src/mysterx/mysc/bstr.h | 6 + src/mysterx/mysc/mysc.mak | 33 + src/mysterx/myspage/dhtmlpag.bmp | Bin 0 -> 246 bytes src/mysterx/myspage/dhtmlpage.cxx | 271 + src/mysterx/myspage/dhtmlpage.h | 110 + src/mysterx/myspage/dhtmlpage.rgs | 34 + src/mysterx/myspage/dhtmlpageui.htm | 15 + src/mysterx/myspage/event.cxx | 231 + src/mysterx/myspage/event.h | 71 + src/mysterx/myspage/event.rgs | 26 + src/mysterx/myspage/eventqueue.cxx | 119 + src/mysterx/myspage/eventqueue.h | 53 + src/mysterx/myspage/eventqueue.rgs | 26 + src/mysterx/myspage/myspage.cxx | 78 + src/mysterx/myspage/myspage.def | 9 + src/mysterx/myspage/myspage.idl | 142 + src/mysterx/myspage/myspage.mak | 64 + src/mysterx/myspage/myspage.rc | 140 + src/mysterx/myspage/resource.h | 21 + src/mysterx/myspage/stdafx.cxx | 12 + src/mysterx/myspage/stdafx.h | 31 + src/mysterx/myspage/wrapper.h | 54 + src/mysterx/myssink/comtypes.cxx | 16 + src/mysterx/myssink/comtypes.h | 3 + src/mysterx/myssink/myssink.cxx | 67 + src/mysterx/myssink/myssink.def | 9 + src/mysterx/myssink/myssink.idl | 42 + src/mysterx/myssink/myssink.mak | 56 + src/mysterx/myssink/myssink.rc | 124 + src/mysterx/myssink/myssinkps.def | 11 + src/mysterx/myssink/resource.h | 17 + src/mysterx/myssink/sink.cxx | 607 + src/mysterx/myssink/sink.h | 69 + src/mysterx/myssink/sink.rgs | 26 + src/mysterx/myssink/sinktbl.h | 47 + src/mysterx/myssink/stdafx.cxx | 12 + src/mysterx/myssink/stdafx.h | 27 + src/mysterx/mysterx.cxx | 4409 ++++++ src/mysterx/mysterx.h | 563 + src/mysterx/mysterx.mak | 53 + src/mysterx/resource.h | 17 + src/mysterx/stdafx.cxx | 12 + src/mysterx/stdafx.h | 18 + src/mzcom/README | 10 + src/mzcom/mzcom.cxx | 170 + src/mzcom/mzcom.idl | 52 + src/mzcom/mzobj.cxx | 369 + src/mzcom/mzobj.h | 77 + src/mzcom/resource.h | 21 + src/mzcom/stdafx.cxx | 12 + src/mzcom/stdafx.h | 37 + src/mzscheme/Makefile.in | 226 + src/mzscheme/README | 85 + src/mzscheme/clean_ac.ss | 27 + src/mzscheme/cmdline.inc | 709 + src/mzscheme/configure.in | 352 + src/mzscheme/dynsrc/Makefile.in | 61 + src/mzscheme/dynsrc/dynexmpl.c | 38 + src/mzscheme/dynsrc/fixup.c | 6 + src/mzscheme/dynsrc/gmkmzdyn.bat | 13 + src/mzscheme/dynsrc/init.cc | 34 + src/mzscheme/dynsrc/mkmzdyn.bat | 9 + src/mzscheme/dynsrc/mzdyn.c | 55 + src/mzscheme/dynsrc/mzdyn.def | 7 + src/mzscheme/dynsrc/oe.c | 495 + src/mzscheme/dynsrc/start.c | 325 + src/mzscheme/gc/BCC_MAKEFILE | 82 + src/mzscheme/gc/EMX_MAKEFILE | 141 + src/mzscheme/gc/MacOS.c | 165 + src/mzscheme/gc/MacProjects.sit.hqx | 886 ++ src/mzscheme/gc/Mac_files/MacOS_Test_config.h | 91 + src/mzscheme/gc/Mac_files/MacOS_config.h | 89 + src/mzscheme/gc/Mac_files/dataend.c | 9 + src/mzscheme/gc/Mac_files/datastart.c | 9 + src/mzscheme/gc/Makefile.DLLs | 107 + src/mzscheme/gc/Makefile.dj | 436 + src/mzscheme/gc/Makefile.in | 474 + src/mzscheme/gc/NT_MAKEFILE | 59 + src/mzscheme/gc/OS2_MAKEFILE | 45 + src/mzscheme/gc/PCR-Makefile | 68 + src/mzscheme/gc/README | 1509 ++ src/mzscheme/gc/README.Mac | 385 + src/mzscheme/gc/README.OS2 | 6 + src/mzscheme/gc/README.QUICK | 41 + src/mzscheme/gc/README.alpha | 22 + src/mzscheme/gc/README.amiga | 180 + src/mzscheme/gc/README.debugging | 58 + src/mzscheme/gc/README.dj | 12 + src/mzscheme/gc/README.hp | 11 + src/mzscheme/gc/README.linux | 50 + src/mzscheme/gc/README.rs6000 | 9 + src/mzscheme/gc/README.sgi | 41 + src/mzscheme/gc/README.solaris2 | 65 + src/mzscheme/gc/README.uts | 2 + src/mzscheme/gc/README.win32 | 149 + src/mzscheme/gc/SCoptions.amiga | 16 + src/mzscheme/gc/SMakefile.amiga | 48 + src/mzscheme/gc/WCC_MAKEFILE | 196 + src/mzscheme/gc/add_gc_prefix.c | 14 + src/mzscheme/gc/allchblk.c | 742 + src/mzscheme/gc/alloc.c | 935 ++ src/mzscheme/gc/alpha_mach_dep.s | 60 + src/mzscheme/gc/backptr.h | 56 + src/mzscheme/gc/barrett_diagram | 106 + src/mzscheme/gc/blacklst.c | 302 + src/mzscheme/gc/callprocs | 4 + src/mzscheme/gc/checksums.c | 201 + src/mzscheme/gc/cord/README | 31 + src/mzscheme/gc/cord/SCOPTIONS.amiga | 14 + src/mzscheme/gc/cord/SMakefile.amiga | 20 + src/mzscheme/gc/cord/cord.h | 327 + src/mzscheme/gc/cord/cordbscs.c | 915 ++ src/mzscheme/gc/cord/cordprnt.c | 390 + src/mzscheme/gc/cord/cordtest.c | 228 + src/mzscheme/gc/cord/cordxtra.c | 621 + src/mzscheme/gc/cord/de.c | 603 + src/mzscheme/gc/cord/de_cmds.h | 33 + src/mzscheme/gc/cord/de_win.ICO | Bin 0 -> 766 bytes src/mzscheme/gc/cord/de_win.RC | 78 + src/mzscheme/gc/cord/de_win.c | 366 + src/mzscheme/gc/cord/de_win.h | 103 + src/mzscheme/gc/cord/ec.h | 70 + src/mzscheme/gc/cord/gc.h | 746 + src/mzscheme/gc/cord/private/cord_pos.h | 118 + src/mzscheme/gc/dbg_mlc.c | 801 ++ src/mzscheme/gc/dyn_load.c | 799 ++ src/mzscheme/gc/finalize.c | 1012 ++ src/mzscheme/gc/gc.h | 746 + src/mzscheme/gc/gc.mak | 2087 +++ src/mzscheme/gc/gc.man | 80 + src/mzscheme/gc/gc_alloc.h | 380 + src/mzscheme/gc/gc_cpp.cc | 60 + src/mzscheme/gc/gc_cpp.h | 290 + src/mzscheme/gc/gc_hdrs.h | 135 + src/mzscheme/gc/gc_mark.h | 280 + src/mzscheme/gc/gc_priv.h | 1749 +++ src/mzscheme/gc/gc_private.h | 1 + src/mzscheme/gc/gc_typed.h | 91 + src/mzscheme/gc/gc_watcom.asm | 51 + src/mzscheme/gc/gcc_support.c | 516 + src/mzscheme/gc/gcconfig.h | 1106 ++ src/mzscheme/gc/headers.c | 351 + src/mzscheme/gc/if_mach.c | 40 + src/mzscheme/gc/if_not_there.c | 25 + src/mzscheme/gc/include/backptr.h | 56 + src/mzscheme/gc/include/cord.h | 327 + src/mzscheme/gc/include/ec.h | 70 + src/mzscheme/gc/include/gc.h | 746 + src/mzscheme/gc/include/gc_alloc.h | 380 + src/mzscheme/gc/include/gc_cpp.h | 290 + src/mzscheme/gc/include/gc_inl.h | 103 + src/mzscheme/gc/include/gc_inline.h | 1 + src/mzscheme/gc/include/gc_typed.h | 91 + src/mzscheme/gc/include/private/cord_pos.h | 118 + src/mzscheme/gc/include/private/gc_hdrs.h | 135 + src/mzscheme/gc/include/private/gc_priv.h | 1749 +++ src/mzscheme/gc/include/private/gcconfig.h | 1106 ++ src/mzscheme/gc/include/weakpointer.h | 221 + src/mzscheme/gc/irix_threads.c | 674 + src/mzscheme/gc/linux_threads.c | 666 + src/mzscheme/gc/mach_dep.c | 444 + src/mzscheme/gc/malloc.c | 442 + src/mzscheme/gc/mallocx.c | 380 + src/mzscheme/gc/mark.c | 1190 ++ src/mzscheme/gc/mark_rts.c | 503 + src/mzscheme/gc/mips_sgi_mach_dep.s | 40 + src/mzscheme/gc/mips_ultrix_mach_dep.s | 26 + src/mzscheme/gc/misc.c | 865 ++ src/mzscheme/gc/new_hblk.c | 244 + src/mzscheme/gc/obj_map.c | 142 + src/mzscheme/gc/os_dep.c | 2489 ++++ src/mzscheme/gc/pc_excludes | 15 + src/mzscheme/gc/pcr_interface.c | 173 + src/mzscheme/gc/ptr_chck.c | 326 + src/mzscheme/gc/real_malloc.c | 36 + src/mzscheme/gc/reclaim.c | 723 + src/mzscheme/gc/rs6000_mach_dep.s | 105 + src/mzscheme/gc/setjmp_t.c | 115 + src/mzscheme/gc/solaris_pthreads.c | 172 + src/mzscheme/gc/solaris_threads.c | 940 ++ src/mzscheme/gc/solaris_threads.h | 34 + src/mzscheme/gc/sparc_mach_dep.s | 38 + src/mzscheme/gc/sparc_sunos4_mach_dep.s | 38 + src/mzscheme/gc/stubborn.c | 328 + src/mzscheme/gc/test.c | 1263 ++ src/mzscheme/gc/test_cpp.cc | 265 + src/mzscheme/gc/threadlibs.c | 14 + src/mzscheme/gc/typd_mlc.c | 814 ++ src/mzscheme/gc/update_includes | 26 + src/mzscheme/gc/version.h | 11 + src/mzscheme/gc/weakpointer.h | 221 + src/mzscheme/gc/win32_threads.c | 209 + src/mzscheme/gc2/Makefile.in | 293 + src/mzscheme/gc2/README | 226 + src/mzscheme/gc2/compact.c | 3424 +++++ src/mzscheme/gc2/copy.c | 1788 +++ src/mzscheme/gc2/ctok.lex | 321 + src/mzscheme/gc2/gc.h | 3 + src/mzscheme/gc2/gc2.c | 10 + src/mzscheme/gc2/gc2.h | 252 + src/mzscheme/gc2/noncopy.c | 3390 +++++ src/mzscheme/gc2/xform.ss | 2533 ++++ src/mzscheme/guile/Makefile.in | 51 + src/mzscheme/guile/NOTES | 72 + src/mzscheme/guile/README | 7 + src/mzscheme/guile/gh.h | 117 + src/mzscheme/guile/ghbase.h | 27 + src/mzscheme/guile/guile.c | 247 + src/mzscheme/guile/guileinc.c | 380 + src/mzscheme/guile/mkghsrc | 263 + src/mzscheme/guile/test.c | 89 + src/mzscheme/guile/wrap.inc | 22 + src/mzscheme/include/escheme.h | 44 + src/mzscheme/include/ext.exp | 4 + src/mzscheme/include/gmzwin.def | 313 + src/mzscheme/include/mzscheme.exp | 311 + src/mzscheme/include/mzwin.def | 313 + src/mzscheme/include/scheme.h | 1317 ++ src/mzscheme/macglue.inc | 117 + src/mzscheme/main.c | 374 + src/mzscheme/oskglue.inc | 314 + src/mzscheme/palm/Makefile.in | 369 + src/mzscheme/palm/README | 31 + src/mzscheme/palm/debuginfo.ss | 163 + src/mzscheme/palm/mzpalm.h | 4 + src/mzscheme/palm/mzscheme.pbm | Bin 0 -> 137 bytes src/mzscheme/palm/mzscheme.rcp | 12 + src/mzscheme/palm/palm.c | 131 + src/mzscheme/palm/partition.ss | 110 + src/mzscheme/palm/resnum.h | 3 + src/mzscheme/palm/utils.c | 174 + src/mzscheme/sconfig.h | 1398 ++ src/mzscheme/sgc/Makefile.in | 42 + src/mzscheme/sgc/README | 29 + src/mzscheme/sgc/autostat.inc | 243 + src/mzscheme/sgc/checkreg | 179 + src/mzscheme/sgc/collect.inc | 387 + src/mzscheme/sgc/gc.h | 3 + src/mzscheme/sgc/sgc.c | 4932 +++++++ src/mzscheme/sgc/sgc.h | 83 + src/mzscheme/sgc/sgcdiff | 247 + src/mzscheme/sgc/splay.c | 136 + src/mzscheme/sgc/test.c | 127 + src/mzscheme/src/Makefile.in | 309 + src/mzscheme/src/bgnfloat.inc | 128 + src/mzscheme/src/bignum.c | 1490 ++ src/mzscheme/src/bool.c | 256 + src/mzscheme/src/builtin.c | 82 + src/mzscheme/src/char.c | 434 + src/mzscheme/src/cmacro.inc | 1082 ++ src/mzscheme/src/complex.c | 299 + src/mzscheme/src/cunitsig.inc | 658 + src/mzscheme/src/dynext.c | 577 + src/mzscheme/src/dynext.inc | 159 + src/mzscheme/src/env.c | 1680 +++ src/mzscheme/src/error.c | 1700 +++ src/mzscheme/src/eval.c | 3456 +++++ src/mzscheme/src/exnsrc.ss | 59 + src/mzscheme/src/file.c | 4401 ++++++ src/mzscheme/src/fun.c | 2772 ++++ src/mzscheme/src/hash.c | 516 + src/mzscheme/src/image.c | 757 + src/mzscheme/src/list.c | 1366 ++ src/mzscheme/src/mac_roman.inc | 150 + src/mzscheme/src/macro.inc | 1314 ++ src/mzscheme/src/macro.ss | 1315 ++ src/mzscheme/src/makeexn | 238 + src/mzscheme/src/makex | 158 + src/mzscheme/src/mkmark.ss | 86 + src/mzscheme/src/mzeqchk.inc | 19 + src/mzscheme/src/mzmark.c | 3572 +++++ src/mzscheme/src/mzmarksrc.c | 1586 +++ src/mzscheme/src/mzsj86.c | 65 + src/mzscheme/src/mzstkchk.h | 30 + src/mzscheme/src/network.c | 2029 +++ src/mzscheme/src/numarith.c | 645 + src/mzscheme/src/number.c | 2104 +++ src/mzscheme/src/numcomp.c | 262 + src/mzscheme/src/nummacs.h | 543 + src/mzscheme/src/numstr.c | 1438 ++ src/mzscheme/src/objclass.c | 1507 ++ src/mzscheme/src/object.c | 2783 ++++ src/mzscheme/src/pc_keys.inc | 146 + src/mzscheme/src/port.c | 5333 +++++++ src/mzscheme/src/portfun.c | 2223 +++ src/mzscheme/src/print.c | 1554 ++ src/mzscheme/src/process.c | 4189 ++++++ src/mzscheme/src/promise.c | 159 + src/mzscheme/src/qqsrc.ss | 90 + src/mzscheme/src/random.inc | 194 + src/mzscheme/src/ratfloat.inc | 114 + src/mzscheme/src/rational.c | 454 + src/mzscheme/src/read.c | 1998 +++ src/mzscheme/src/regexp.c | 1650 +++ src/mzscheme/src/salloc.c | 1622 +++ src/mzscheme/src/schapp.inc | 62 + src/mzscheme/src/schcpt.h | 57 + src/mzscheme/src/schemef.h | 677 + src/mzscheme/src/schemex.h | 559 + src/mzscheme/src/schemex.inc | 371 + src/mzscheme/src/schemexm.h | 371 + src/mzscheme/src/schexn.h | 170 + src/mzscheme/src/schfd.h | 8 + src/mzscheme/src/schgc.h | 22 + src/mzscheme/src/schmach.h | 52 + src/mzscheme/src/schminc.h | 33 + src/mzscheme/src/schpriv.h | 1681 +++ src/mzscheme/src/schrunst.h | 13 + src/mzscheme/src/schvers.h | 8 + src/mzscheme/src/schwinfd.h | 17 + src/mzscheme/src/sema.c | 429 + src/mzscheme/src/setjmpup.c | 443 + src/mzscheme/src/sstoinc | 90 + src/mzscheme/src/sstoinc.ss | 59 + src/mzscheme/src/string.c | 1366 ++ src/mzscheme/src/struct.c | 1105 ++ src/mzscheme/src/stypes.h | 184 + src/mzscheme/src/symbol.c | 540 + src/mzscheme/src/syntax.c | 2785 ++++ src/mzscheme/src/sysname | 10 + src/mzscheme/src/tsymbol.c | 2 + src/mzscheme/src/type.c | 426 + src/mzscheme/src/unit.c | 3241 +++++ src/mzscheme/src/unitsig.c | 45 + src/mzscheme/src/unitsig.inc | 1060 ++ src/mzscheme/src/unitsig.ss | 1099 ++ src/mzscheme/src/vector.c | 316 + src/mzscheme/uconfig.h | 32 + src/mzscheme/utils/README | 19 + src/mzscheme/utils/common.pl | 50 + src/mzscheme/utils/parse.pl | 600 + src/mzscheme/utils/sigclean | 123 + src/mzscheme/utils/xcglue.c | 782 + src/mzscheme/utils/xcglue.h | 203 + src/mzscheme/utils/xctocc | 2533 ++++ src/mzscheme/utils/xctocmn | 90 + src/mzscheme/utils/xctosig | 248 + src/mzscheme/utils/xctotest | 232 + src/mzscheme/utils/xctotex | 154 + src/srpersist/Makefile | 45 + src/srpersist/README | 112 + src/srpersist/srpbitmask.tbl | 844 ++ src/srpersist/srpbuffer.cxx | 1244 ++ src/srpersist/srpbuffer.h | 30 + src/srpersist/srpconsts.tbl | 860 ++ src/srpersist/srpersist.cxx | 6946 +++++++++ src/srpersist/srpersist.h | 447 + src/srpersist/srpersist.mac-make.hqx | 1856 +++ src/srpersist/srpersist.mak | 54 + src/srpersist/srpersist.pch | 11 + src/srpersist/srpexns.tbl | 39 + src/srpersist/srpinfo.tbl | 397 + src/srpersist/srpprims.tbl | 119 + src/srpersist/srpstructs.tbl | 159 + src/srpersist/srptypes.cxx | 56 + src/srpersist/srptypes.h | 189 + src/worksp/README | 106 + src/worksp/gc/gc.dsp | 223 + src/worksp/gc/gc.dsw | 29 + src/worksp/gc/gc.mak | 561 + src/worksp/gc/gc.opt | Bin 0 -> 48640 bytes src/worksp/mred/mred.dsp | 291 + src/worksp/mred/mred.dsw | 104 + src/worksp/mred/mred.ico | Bin 0 -> 1398 bytes src/worksp/mred/mred.mak | 1074 ++ src/worksp/mred/mred.opt | Bin 0 -> 84480 bytes src/worksp/mred/mred.rc | 53 + src/worksp/mrstart/mrstart.dsp | 77 + src/worksp/mrstart/mrstart.dsw | 29 + src/worksp/mrstart/mrstart.mak | 125 + src/worksp/mrstart/mrstart.opt | Bin 0 -> 48640 bytes src/worksp/mzcom/MzCOMCP.h | 32 + src/worksp/mzcom/README | 10 + src/worksp/mzcom/mzcom.def | 9 + src/worksp/mzcom/mzcom.dsp | 204 + src/worksp/mzcom/mzcom.dsw | 29 + src/worksp/mzcom/mzcom.ico | Bin 0 -> 1398 bytes src/worksp/mzcom/mzcom.mak | 273 + src/worksp/mzcom/mzcom.ncb | 1 + src/worksp/mzcom/mzcom.opt | 1 + src/worksp/mzcom/mzcom.rc | 165 + src/worksp/mzcom/mzcomps.def | 11 + src/worksp/mzcom/mzobj.rgs | 24 + src/worksp/mzscheme/mzscheme.dsp | 198 + src/worksp/mzscheme/mzscheme.dsw | 59 + src/worksp/mzscheme/mzscheme.ico | Bin 0 -> 1398 bytes src/worksp/mzscheme/mzscheme.mak | 609 + src/worksp/mzscheme/mzscheme.opt | Bin 0 -> 58880 bytes src/worksp/mzscheme/mzscheme.rc | 62 + src/worksp/mzscheme/resource.h | 16 + src/worksp/mzsrc/mzsrc.dsp | 951 ++ src/worksp/mzsrc/mzsrc.dsw | 29 + src/worksp/mzsrc/mzsrc.mak | 2680 ++++ src/worksp/mzsrc/mzsrc.opt | Bin 0 -> 48640 bytes src/worksp/mzstart/mzstart.dsp | 74 + src/worksp/mzstart/mzstart.dsw | 29 + src/worksp/mzstart/mzstart.mak | 123 + src/worksp/rebuild.bat | 40 + src/worksp/sgc/sgc.dsp | 104 + src/worksp/sgc/sgc.dsw | 29 + src/worksp/sgc/sgc.mak | 152 + src/worksp/sgc/sgc.opt | Bin 0 -> 48640 bytes src/worksp/starters/mrstart.ico | Bin 0 -> 1398 bytes src/worksp/starters/mzstart.ico | Bin 0 -> 1398 bytes src/worksp/starters/resource.h | 15 + src/worksp/starters/start.rc | 71 + src/worksp/wxs/wxs.dsp | 349 + src/worksp/wxs/wxs.dsw | 29 + src/worksp/wxs/wxs.mak | 578 + src/worksp/wxs/wxs.opt | 1 + src/worksp/wxutils/wxutils.dsp | 260 + src/worksp/wxutils/wxutils.dsw | 29 + src/worksp/wxutils/wxutils.mak | 589 + src/worksp/wxutils/wxutils.opt | 1 + src/worksp/wxwin/wxwin.dsp | 317 + src/worksp/wxwin/wxwin.dsw | 29 + src/worksp/wxwin/wxwin.mak | 829 ++ src/worksp/wxwin/wxwin.opt | 1 + src/wxcommon/FontDirectory.cxx | 731 + src/wxcommon/FontDirectory.h | 61 + src/wxcommon/PSDC.cxx | 2290 +++ src/wxcommon/PSDC.h | 299 + src/wxcommon/Region.cxx | 845 ++ src/wxcommon/Region.h | 124 + src/wxcommon/wb_hash.cxx | 343 + 1028 files changed, 395986 insertions(+), 19 deletions(-) create mode 100644 collects/mzlib/traceld.ss create mode 100644 collects/mzlib/traceldr.ss create mode 100644 collects/mzlib/transcr.ss create mode 100644 collects/mzlib/transcrr.ss create mode 100644 collects/mzlib/transcrs.ss create mode 100644 collects/mzlib/transcru.ss create mode 100644 collects/mzscheme/examples/README create mode 100644 collects/mzscheme/examples/bitmatrix.c create mode 100644 collects/mzscheme/examples/curses-demo.ss create mode 100644 collects/mzscheme/examples/curses.c create mode 100644 collects/mzscheme/examples/fmod.c create mode 100644 collects/mzscheme/examples/hello.c create mode 100644 collects/mzscheme/examples/helloprint.c create mode 100644 collects/mzscheme/examples/makeadder.c create mode 100644 collects/mzscheme/include/escheme.h create mode 100644 collects/mzscheme/include/ext.exp create mode 100644 collects/mzscheme/include/mzscheme.exp create mode 100644 collects/mzscheme/include/scheme.h create mode 100644 collects/mzscheme/include/schemef.h create mode 100644 collects/mzscheme/include/schemex.h create mode 100644 collects/mzscheme/include/schemexm.h create mode 100644 collects/mzscheme/include/schexn.h create mode 100644 collects/mzscheme/include/schvers.h create mode 100644 collects/mzscheme/include/sconfig.h create mode 100644 collects/mzscheme/include/stypes.h create mode 100644 collects/mzscheme/include/uconfig.h create mode 100644 collects/mzscheme/lib/mzdyn.c create mode 100644 collects/net/base64.ss create mode 100644 collects/net/base64r.ss create mode 100644 collects/net/base64s.ss create mode 100644 collects/net/cgi.ss create mode 100644 collects/net/cgir.ss create mode 100644 collects/net/cgis.ss create mode 100644 collects/net/cgiu.ss create mode 100644 collects/net/dns.ss create mode 100644 collects/net/dnsr.ss create mode 100644 collects/net/dnss.ss create mode 100644 collects/net/doc.txt create mode 100644 collects/net/head.ss create mode 100644 collects/net/headr.ss create mode 100644 collects/net/heads.ss create mode 100644 collects/net/imap.ss create mode 100644 collects/net/imapr.ss create mode 100644 collects/net/imaps.ss create mode 100644 collects/net/info.ss create mode 100644 collects/net/mail.ss create mode 100644 collects/net/mailr.ss create mode 100644 collects/net/mails.ss create mode 100644 collects/net/mailu.ss create mode 100644 collects/net/nntp.sd create mode 100644 collects/net/nntp.ss create mode 100644 collects/net/nntpr.ss create mode 100644 collects/net/nntps.ss create mode 100644 collects/net/nntpu.ss create mode 100644 collects/net/pop3.ss create mode 100644 collects/net/pop3r.ss create mode 100644 collects/net/pop3s.ss create mode 100644 collects/net/pop3u.ss create mode 100644 collects/net/smtp.ss create mode 100644 collects/net/smtpr.ss create mode 100644 collects/net/smtps.ss create mode 100644 collects/net/url.ss create mode 100644 collects/net/urlr.ss create mode 100644 collects/net/urls.ss create mode 100644 collects/net/urlu.ss create mode 100644 collects/quasiquote/qq-client.ss create mode 100644 collects/quasiquote/qq.ss create mode 100644 collects/quasiquote/qqguir.ss create mode 100644 collects/quasiquote/qqr.ss create mode 100644 collects/quasiquote/qqs.ss create mode 100644 collects/quasiquote/qqu.ss create mode 100644 collects/readline/doc.txt create mode 100644 collects/readline/info.ss create mode 100755 collects/readline/mzmake.ss create mode 100644 collects/readline/mzrl.c create mode 100644 collects/readline/pread.ss create mode 100644 collects/readline/readline.ss create mode 100644 collects/readline/rep.ss create mode 100644 collects/setup/doc.txt create mode 100644 collects/setup/info.ss create mode 100644 collects/setup/pack.ss create mode 100644 collects/setup/setup-optionr.ss create mode 100644 collects/setup/setup.ss create mode 100644 collects/setup/setupr.ss create mode 100644 collects/setup/setupsig.ss create mode 100644 collects/slatex/doc.txt create mode 100644 collects/slatex/info.ss create mode 100644 collects/slatex/slatex-code/2col.tex create mode 100644 collects/slatex/slatex-code/8pt.tex create mode 100644 collects/slatex/slatex-code/README create mode 100644 collects/slatex/slatex-code/aliases.scm create mode 100644 collects/slatex/slatex-code/batconfg.lsp create mode 100644 collects/slatex/slatex-code/batconfg.scm create mode 100644 collects/slatex/slatex-code/cfg4lsp.lsp create mode 100644 collects/slatex/slatex-code/cfg4scm.scm create mode 100644 collects/slatex/slatex-code/cltl.sty create mode 100644 collects/slatex/slatex-code/codeset.scm create mode 100644 collects/slatex/slatex-code/config.dat create mode 100644 collects/slatex/slatex-code/config.scm create mode 100644 collects/slatex/slatex-code/copying create mode 100644 collects/slatex/slatex-code/defaults.scm create mode 100644 collects/slatex/slatex-code/defun.tex create mode 100644 collects/slatex/slatex-code/fileproc.scm create mode 100644 collects/slatex/slatex-code/helpers.scm create mode 100644 collects/slatex/slatex-code/history create mode 100644 collects/slatex/slatex-code/index.tex create mode 100644 collects/slatex/slatex-code/install create mode 100644 collects/slatex/slatex-code/lerror.scm create mode 100644 collects/slatex/slatex-code/manifest create mode 100644 collects/slatex/slatex-code/margins.tex create mode 100644 collects/slatex/slatex-code/pathproc.scm create mode 100644 collects/slatex/slatex-code/peephole.scm create mode 100644 collects/slatex/slatex-code/preproc.lsp create mode 100644 collects/slatex/slatex-code/preproc.scm create mode 100644 collects/slatex/slatex-code/proctex.scm create mode 100644 collects/slatex/slatex-code/proctex2.scm create mode 100644 collects/slatex/slatex-code/s4.scm create mode 100644 collects/slatex/slatex-code/seqprocs.scm create mode 100644 collects/slatex/slatex-code/slaconfg.lsp create mode 100644 collects/slatex/slatex-code/slaconfg.scm create mode 100644 collects/slatex/slatex-code/slatex.sty create mode 100644 collects/slatex/slatex-code/slatxdoc.dvi create mode 100644 collects/slatex/slatex-code/slatxdoc.tex create mode 100644 collects/slatex/slatex-code/structs.scm create mode 100644 collects/slatex/slatex-code/tex2html.css create mode 100644 collects/slatex/slatex-code/tex2html.tex create mode 100644 collects/slatex/slatex-code/texread.scm create mode 100644 collects/slatex/slatex-code/version create mode 100644 collects/slatex/slatex-launcher.scm create mode 100644 collects/slatex/slatex.ss create mode 100644 collects/slatex/slatexsrc.ss create mode 100644 collects/slibinit/doc.txt create mode 100644 collects/slibinit/init.ss create mode 100644 collects/srpersist/doc.txt create mode 100644 collects/srpersist/info.ss create mode 100644 collects/srpersist/invoke-1.0.ss create mode 100644 collects/srpersist/invoke-2.0.ss create mode 100644 collects/srpersist/invoke-3.0.ss create mode 100644 collects/srpersist/invoke-3.5.ss create mode 100644 collects/srpersist/lib/win32/i386/srpmain.dll create mode 100644 collects/srpersist/sigs.ss create mode 100644 collects/srpersist/srpersist.ss create mode 100644 collects/srpersist/srpersistu.ss create mode 100644 collects/srpersist/tutorial.txt create mode 100644 collects/stepper/annotater.ss create mode 100644 collects/stepper/break.ss create mode 100644 collects/stepper/client-procs.ss create mode 100644 collects/stepper/debug-wrapper.ss create mode 100644 collects/stepper/doc.txt create mode 100644 collects/stepper/fake-model.ss create mode 100644 collects/stepper/info.ss create mode 100644 collects/stepper/instance.ss create mode 100644 collects/stepper/link-jr.ss create mode 100644 collects/stepper/link.ss create mode 100644 collects/stepper/marks.ss create mode 100644 collects/stepper/model.ss create mode 100644 collects/stepper/reconstructr.ss create mode 100644 collects/stepper/sharedr.ss create mode 100644 collects/stepper/sig.ss create mode 100644 collects/stepper/startup.ss create mode 100644 collects/stepper/tests/main.ss create mode 100644 collects/stepper/utils.ss create mode 100644 collects/stepper/view-controller.ss create mode 100644 collects/tests/addrhack.c create mode 100644 collects/tests/drscheme/README create mode 100644 collects/tests/drscheme/check-syntax-test.ss create mode 100644 collects/tests/drscheme/config-lang-test.ss create mode 100644 collects/tests/drscheme/drscheme-test-util.ss create mode 100644 collects/tests/drscheme/drscheme-test.ss create mode 100644 collects/tests/drscheme/event-efficency.ss create mode 100644 collects/tests/drscheme/io.ss create mode 100644 collects/tests/drscheme/language-test.ss create mode 100644 collects/tests/drscheme/launcher.ss create mode 100644 collects/tests/drscheme/line-art.ss create mode 100644 collects/tests/drscheme/menu-test.ss create mode 100644 collects/tests/drscheme/pr-144.ss create mode 100644 collects/tests/drscheme/pr-17.ss create mode 100644 collects/tests/drscheme/pr-246.ss create mode 100644 collects/tests/drscheme/pr-39.ss create mode 100644 collects/tests/drscheme/pr-46.ss create mode 100644 collects/tests/drscheme/pr-48.ss create mode 100644 collects/tests/drscheme/pr-51.dir/1.ss create mode 100644 collects/tests/drscheme/pr-51.dir/2.ss create mode 100644 collects/tests/drscheme/pr-51.ss create mode 100644 collects/tests/drscheme/pr-58.ss create mode 100644 collects/tests/drscheme/pr-80.ss create mode 100644 collects/tests/drscheme/pr-99.ss create mode 100644 collects/tests/drscheme/repl-test.ss create mode 100644 collects/tests/drscheme/sample-solutions.ss create mode 100644 collects/tests/drscheme/sig.ss create mode 100644 collects/tests/drscheme/sixlib.ss create mode 100644 collects/tests/drscheme/syncheck/basic.ss create mode 100644 collects/tests/drscheme/syncheck/circle.ss create mode 100644 collects/tests/drscheme/syncheck/generate.ss create mode 100644 collects/tests/drscheme/syncheck/lots.ss create mode 100644 collects/tests/drscheme/tool.ss create mode 100644 collects/tests/framework/info.ss create mode 100644 collects/tests/framework/key-specs.ss create mode 100644 collects/tests/framework/paren-test.ss create mode 100644 collects/tests/framework/send-sexp.ss create mode 100644 collects/tests/framework/utils.ss create mode 100644 collects/tests/info.ss create mode 100644 collects/tests/mred/auto.ss create mode 100644 collects/tests/mred/classhack.c create mode 100644 collects/tests/mred/frame-edit.ss create mode 100644 collects/tests/mred/gui-main.ss create mode 100644 collects/tests/mred/gui.ss create mode 100644 collects/tests/mred/imred.ss create mode 100644 collects/tests/mred/mediastream.ss create mode 100644 collects/tests/mred/random.ss create mode 100644 collects/tests/mred/showkey.ss create mode 100644 collects/tests/mysterx/README create mode 100644 collects/tests/mysterx/dhtmltests.ss create mode 100644 collects/tests/mysterx/mystests.ss create mode 100644 collects/tests/mysterx/src/Makefile create mode 100644 collects/tests/mysterx/src/resource.h create mode 100644 collects/tests/mysterx/src/stdafx.cxx create mode 100644 collects/tests/mysterx/src/stdafx.h create mode 100644 collects/tests/mysterx/src/testcont.bmp create mode 100644 collects/tests/mysterx/src/testcontrol.cxx create mode 100644 collects/tests/mysterx/src/testcontrol.h create mode 100644 collects/tests/mysterx/src/testcontrol.rgs create mode 100644 collects/tests/mysterx/src/testobject.cxx create mode 100644 collects/tests/mysterx/src/testobject.def create mode 100644 collects/tests/mysterx/src/testobject.idl create mode 100644 collects/tests/mysterx/src/testobject.mak create mode 100644 collects/tests/mysterx/src/testobject.rc create mode 100644 collects/tests/mysterx/src/testobjectCP.h create mode 100644 collects/tests/mzscheme/README create mode 100644 collects/tests/mzscheme/all.ss create mode 100644 collects/tests/mzscheme/basic.ss create mode 100644 collects/tests/mzscheme/censor.ss create mode 100644 collects/tests/mzscheme/chkdoc.ss create mode 100644 collects/tests/mzscheme/classd.ss create mode 100644 collects/tests/mzscheme/cmdline.ss create mode 100644 collects/tests/mzscheme/compfile.ss create mode 100644 collects/tests/mzscheme/compile.ss create mode 100644 collects/tests/mzscheme/compilex.ss create mode 100644 collects/tests/mzscheme/contmark.ss create mode 100644 collects/tests/mzscheme/date.ss create mode 100644 collects/tests/mzscheme/deep.ss create mode 100644 collects/tests/mzscheme/em-imp.ss create mode 100644 collects/tests/mzscheme/expand.ss create mode 100644 collects/tests/mzscheme/fact.ss create mode 100644 collects/tests/mzscheme/file.ss create mode 100644 collects/tests/mzscheme/function.ss create mode 100644 collects/tests/mzscheme/hashper.ss create mode 100644 collects/tests/mzscheme/image.ss create mode 100644 collects/tests/mzscheme/ktest.ss create mode 100644 collects/tests/mzscheme/loadable.ss create mode 100644 collects/tests/mzscheme/loop.ss create mode 100644 collects/tests/mzscheme/ltest.ss create mode 100644 collects/tests/mzscheme/macro.ss create mode 100644 collects/tests/mzscheme/macrolib.ss create mode 100644 collects/tests/mzscheme/makeflat.ss create mode 100644 collects/tests/mzscheme/multi-expand.ss create mode 100644 collects/tests/mzscheme/mzlib.ss create mode 100644 collects/tests/mzscheme/mzthr.ss create mode 100644 collects/tests/mzscheme/name.ss create mode 100644 collects/tests/mzscheme/namespac.ss create mode 100644 collects/tests/mzscheme/nch.ss create mode 100644 collects/tests/mzscheme/number.ss create mode 100644 collects/tests/mzscheme/numstrs.ss create mode 100644 collects/tests/mzscheme/object.ss create mode 100644 collects/tests/mzscheme/oe.ss create mode 100644 collects/tests/mzscheme/oee.ss create mode 100644 collects/tests/mzscheme/optimize.ss create mode 100644 collects/tests/mzscheme/parallel.ss create mode 100644 collects/tests/mzscheme/param.ss create mode 100644 collects/tests/mzscheme/path.ss create mode 100644 collects/tests/mzscheme/pconvert.ss create mode 100644 collects/tests/mzscheme/pretty.ss create mode 100644 collects/tests/mzscheme/quiet.ss create mode 100644 collects/tests/mzscheme/read.ss create mode 100644 collects/tests/mzscheme/stream.ss create mode 100644 collects/tests/mzscheme/struct.ss create mode 100644 collects/tests/mzscheme/structc.ss create mode 100644 collects/tests/mzscheme/syntax.ss create mode 100644 collects/tests/mzscheme/tcp.ss create mode 100644 collects/tests/mzscheme/testing.ss create mode 100644 collects/tests/mzscheme/thread.ss create mode 100644 collects/tests/mzscheme/thrport.ss create mode 100644 collects/tests/mzscheme/ttt/listlib.ss create mode 100644 collects/tests/mzscheme/ttt/tic-bang.ss create mode 100644 collects/tests/mzscheme/ttt/tic-func.ss create mode 100644 collects/tests/mzscheme/ttt/ttt.ss create mode 100644 collects/tests/mzscheme/ttt/uinc4.ss create mode 100644 collects/tests/mzscheme/ttt/veclib.ss create mode 100644 collects/tests/mzscheme/uinc.ss create mode 100644 collects/tests/mzscheme/uinc2.ss create mode 100644 collects/tests/mzscheme/uinc3.ss create mode 100644 collects/tests/mzscheme/unit.ss create mode 100644 collects/tests/mzscheme/unitsig.ss create mode 100644 collects/tests/mzscheme/will.ss create mode 100644 collects/tests/mzscheme/ztest.ss create mode 100644 collects/tests/utils/guir.ss create mode 100644 collects/tests/utils/guis.ss create mode 100644 collects/texpict/doc.txt create mode 100644 collects/texpict/mztp.sty create mode 100644 collects/texpict/render.ss create mode 100644 collects/texpict/texpict.ss create mode 100644 collects/texpict/texpictr.ss create mode 100644 collects/texpict/texpicts.ss create mode 100644 collects/typeset/doc.txt create mode 100644 collects/typeset/tool-sig.ss create mode 100644 collects/typeset/tool.ss create mode 100644 collects/typeset/utils.ss create mode 100644 collects/userspce/advancedr.ss create mode 100644 collects/userspce/basis.ss create mode 100644 collects/userspce/doc.txt create mode 100644 collects/userspce/errorr.ss create mode 100644 collects/userspce/errors.ss create mode 100644 collects/userspce/info.ss create mode 100644 collects/userspce/init-namespacer.ss create mode 100644 collects/userspce/init-paramr.ss create mode 100644 collects/userspce/interface.ss create mode 100644 collects/userspce/launcher-bootstrap.ss create mode 100644 collects/userspce/paramr.ss create mode 100644 collects/userspce/params.ss create mode 100644 collects/userspce/ricedefr.ss create mode 100644 collects/userspce/ricedefs.ss create mode 100644 collects/userspce/sig.ss create mode 100644 collects/userspce/userspce.ss create mode 100644 collects/userspce/userspcr.ss create mode 100644 collects/xml/doc.txt create mode 100644 collects/xml/info.ss create mode 100644 collects/xml/reader.ss create mode 100644 collects/xml/space.ss create mode 100644 collects/xml/structures.ss create mode 100644 collects/xml/writer.ss create mode 100644 collects/xml/xexpr.ss create mode 100644 collects/xml/xml.ss create mode 100644 collects/xml/xmlr.ss create mode 100644 collects/xml/xmls.ss create mode 100644 collects/zodiac/back.ss create mode 100644 collects/zodiac/basestr.ss create mode 100644 collects/zodiac/corelate.ss create mode 100644 collects/zodiac/doc.txt create mode 100644 collects/zodiac/info.ss create mode 100644 collects/zodiac/invoke.ss create mode 100644 collects/zodiac/link.ss create mode 100644 collects/zodiac/load.ss create mode 100644 collects/zodiac/make.ss create mode 100644 collects/zodiac/misc.ss create mode 100644 collects/zodiac/pattern.ss create mode 100644 collects/zodiac/quasi.ss create mode 100644 collects/zodiac/reader.ss create mode 100644 collects/zodiac/readstr.ss create mode 100644 collects/zodiac/scanner.ss create mode 100644 collects/zodiac/scanparm.ss create mode 100644 collects/zodiac/scanstr.ss create mode 100644 collects/zodiac/scm-core.ss create mode 100644 collects/zodiac/scm-hanc.ss create mode 100644 collects/zodiac/scm-main.ss create mode 100644 collects/zodiac/scm-obj.ss create mode 100644 collects/zodiac/scm-ou.ss create mode 100644 collects/zodiac/scm-spdy.ss create mode 100644 collects/zodiac/scm-unit.ss create mode 100644 collects/zodiac/sexp.ss create mode 100644 collects/zodiac/sigs.ss create mode 100644 collects/zodiac/x.ss create mode 100644 collects/zodiac/zsigs.ss create mode 100755 install create mode 100644 man/man1/drscheme-jr.1 create mode 100644 man/man1/drscheme.1 create mode 100644 notes/COPYING.LIB create mode 100644 notes/drscheme/HISTORY create mode 100644 notes/drscheme/OPENBUGS create mode 100644 notes/mred/FONTS create mode 100644 notes/mred/MrEd.ad create mode 100644 notes/mred/OPENBUGS create mode 100644 notes/mred/fonts12.mre create mode 100644 notes/mred/fontsall.mre create mode 100644 notes/mred/mred.fnt create mode 100644 notes/mred/mred.ini create mode 100644 notes/mrspidey/HISTORY create mode 100644 notes/mysterx/HISTORY create mode 100644 notes/mzc/OPENBUGS create mode 100644 notes/mzcom/HISTORY create mode 100644 notes/mzscheme/HISTORY create mode 100644 notes/mzscheme/OPENBUGS create mode 100644 notes/releases/53.html create mode 100644 notes/releases/releases.html create mode 100644 notes/srpersist/HISTORY create mode 100644 notes/stepper/DESIGN-NOTES create mode 100644 notes/stepper/HISTORY create mode 100644 notes/stepper/OPEN-BUGS create mode 100644 notes/teachpack/HISTORY create mode 100644 src/Makefile.in create mode 100644 src/README create mode 100644 src/a-list/A List Demo Ä.sit.hqx create mode 100644 src/a-list/ReadMe - The A List create mode 100644 src/a-list/The A List.mcp (Pro 3).sit.hqx create mode 100644 src/a-list/The A List.mcp (Pro 4).sit.hqx create mode 100644 src/a-list/The A List.mcp (Pro 5).sit.hqx create mode 100644 src/a-list/Version History - The A List create mode 100755 src/configure create mode 100644 src/cw.sit.hqx create mode 100644 src/drjava/SchemeValue.c create mode 100755 src/drjava/build.ss create mode 100644 src/drjava/file-utils.ss create mode 100644 src/drjava/gen-wrappers.ss create mode 100644 src/drjava/hello.c create mode 100644 src/drjava/java/edu/rice/cs/drj/Env$$$.java create mode 100644 src/drjava/java/edu/rice/cs/drj/ReadFromScheme.java create mode 100644 src/drjava/java/edu/rice/cs/drj/SchemeFunction.java create mode 100644 src/drjava/java/edu/rice/cs/drj/SchemeList.java create mode 100644 src/drjava/java/edu/rice/cs/drj/SchemeValue.java create mode 100644 src/drjava/java/edu/rice/cs/drj/WriteToScheme.java create mode 100644 src/drjava/mzjvm.h create mode 100644 src/mac/mred/MrEdSetup.h create mode 100644 src/mac/mred/boundary.h create mode 100644 src/mac/mred/boundary_alpha.cc create mode 100644 src/mac/mred/boundary_beta.cc create mode 100644 src/mac/mred/boundary_omega.cc create mode 100644 src/mac/mred/wxGWin.pch create mode 100644 src/mac/mred/wxspre.pch create mode 100644 src/mac/mzscheme/maccfm.h create mode 100644 src/mac/mzscheme/macconf.h create mode 100644 src/mac/mzscheme/mzpre.pch create mode 100644 src/mac/mzscheme/simpledrop.c create mode 100644 src/mac/mzscheme/simpledrop.h create mode 100644 src/mac/starter/mrstart.h create mode 100644 src/mac/starter/mzstart.h create mode 100644 src/mac/starter/starter.c create mode 100644 src/mred/GNUmakefile.in create mode 100644 src/mred/Make.env.in create mode 100644 src/mred/README create mode 100644 src/mred/gc2/GNUmakefile.in create mode 100644 src/mred/misc/checkm.c create mode 100644 src/mred/misc/dl_stub.c create mode 100644 src/mred/misc/sgilinkhack.cxx create mode 100644 src/mred/mred.cxx create mode 100644 src/mred/mred.h create mode 100644 src/mred/mredmac.cxx create mode 100644 src/mred/mredmsw.cxx create mode 100644 src/mred/mredx.cxx create mode 100644 src/mred/wrap/Makefile.in create mode 100644 src/mred/wrap/export.ss create mode 100644 src/mred/wrap/import.ss create mode 100644 src/mred/wrap/macros.ss create mode 100755 src/mred/wrap/makewrap.bat create mode 100644 src/mred/wrap/mkwrap.ss create mode 100644 src/mred/wrap/propgate.ss create mode 100644 src/mred/wxme/GNUmakefile.in create mode 100644 src/mred/wxme/wx_cgrec.cxx create mode 100644 src/mred/wxme/wx_cgrec.h create mode 100644 src/mred/wxme/wx_gcrct.h create mode 100644 src/mred/wxme/wx_keym.cxx create mode 100644 src/mred/wxme/wx_keym.h create mode 100644 src/mred/wxme/wx_madm.h create mode 100644 src/mred/wxme/wx_mbuf.cxx create mode 100644 src/mred/wxme/wx_medad.cxx create mode 100644 src/mred/wxme/wx_medad.h create mode 100644 src/mred/wxme/wx_media.cxx create mode 100644 src/mred/wxme/wx_media.h create mode 100644 src/mred/wxme/wx_medio.cxx create mode 100644 src/mred/wxme/wx_medio.h create mode 100644 src/mred/wxme/wx_medpb.h create mode 100644 src/mred/wxme/wx_mline.cxx create mode 100644 src/mred/wxme/wx_mline.h create mode 100644 src/mred/wxme/wx_mpbrd.cxx create mode 100644 src/mred/wxme/wx_mpriv.cxx create mode 100644 src/mred/wxme/wx_mpriv.h create mode 100644 src/mred/wxme/wx_msnip.cxx create mode 100644 src/mred/wxme/wx_mtype.h create mode 100644 src/mred/wxme/wx_ptreq.h create mode 100644 src/mred/wxme/wx_snip.cxx create mode 100644 src/mred/wxme/wx_snip.h create mode 100644 src/mred/wxme/wx_style.cxx create mode 100644 src/mred/wxme/wx_style.h create mode 100644 src/mred/wxs/GNUmakefile.in create mode 100644 src/mred/wxs/cb_end.xci create mode 100644 src/mred/wxs/cb_start.xci create mode 100644 src/mred/wxs/cbgen_s.xci create mode 100644 src/mred/wxs/cwrap.inc create mode 100644 src/mred/wxs/danger.tst create mode 100644 src/mred/wxs/list.xci create mode 100644 src/mred/wxs/prefix.xci create mode 100644 src/mred/wxs/range.xci create mode 100644 src/mred/wxs/vector.xci create mode 100644 src/mred/wxs/wrap.inc create mode 100644 src/mred/wxs/wxs.xci create mode 100644 src/mred/wxs/wxs_bkt.xci create mode 100644 src/mred/wxs/wxs_bmap.cxx create mode 100644 src/mred/wxs/wxs_bmap.h create mode 100644 src/mred/wxs/wxs_bmap.xc create mode 100644 src/mred/wxs/wxs_bmt.xci create mode 100644 src/mred/wxs/wxs_butn.cxx create mode 100644 src/mred/wxs/wxs_butn.h create mode 100644 src/mred/wxs/wxs_butn.xc create mode 100644 src/mred/wxs/wxs_char.xci create mode 100644 src/mred/wxs/wxs_chce.cxx create mode 100644 src/mred/wxs/wxs_chce.h create mode 100644 src/mred/wxs/wxs_chce.xc create mode 100644 src/mred/wxs/wxs_ckbx.cxx create mode 100644 src/mred/wxs/wxs_ckbx.h create mode 100644 src/mred/wxs/wxs_ckbx.xc create mode 100644 src/mred/wxs/wxs_cnvs.cxx create mode 100644 src/mred/wxs/wxs_cnvs.h create mode 100644 src/mred/wxs/wxs_cnvs.xc create mode 100644 src/mred/wxs/wxs_cnvs.xci create mode 100644 src/mred/wxs/wxs_cret.xci create mode 100644 src/mred/wxs/wxs_dc.cxx create mode 100644 src/mred/wxs/wxs_dc.h create mode 100644 src/mred/wxs/wxs_dc.xc create mode 100644 src/mred/wxs/wxs_dorf.xci create mode 100644 src/mred/wxs/wxs_draw.xci create mode 100644 src/mred/wxs/wxs_drwf.xci create mode 100644 src/mred/wxs/wxs_drws.xci create mode 100644 src/mred/wxs/wxs_eds.xci create mode 100644 src/mred/wxs/wxs_eop.xci create mode 100644 src/mred/wxs/wxs_espc.xci create mode 100644 src/mred/wxs/wxs_evnt.cxx create mode 100644 src/mred/wxs/wxs_evnt.h create mode 100644 src/mred/wxs/wxs_evnt.xc create mode 100644 src/mred/wxs/wxs_fcs.xci create mode 100644 src/mred/wxs/wxs_fram.cxx create mode 100644 src/mred/wxs/wxs_fram.h create mode 100644 src/mred/wxs/wxs_fram.xc create mode 100644 src/mred/wxs/wxs_fram.xci create mode 100644 src/mred/wxs/wxs_gage.cxx create mode 100644 src/mred/wxs/wxs_gage.h create mode 100644 src/mred/wxs/wxs_gage.xc create mode 100644 src/mred/wxs/wxs_gdi.cxx create mode 100644 src/mred/wxs/wxs_gdi.h create mode 100644 src/mred/wxs/wxs_gdi.xc create mode 100644 src/mred/wxs/wxs_glob.cxx create mode 100644 src/mred/wxs/wxs_glob.h create mode 100644 src/mred/wxs/wxs_glob.xc create mode 100644 src/mred/wxs/wxs_icol.xci create mode 100644 src/mred/wxs/wxs_ifnt.xci create mode 100644 src/mred/wxs/wxs_item.cxx create mode 100644 src/mred/wxs/wxs_item.h create mode 100644 src/mred/wxs/wxs_item.xc create mode 100644 src/mred/wxs/wxs_item.xci create mode 100644 src/mred/wxs/wxs_lbox.cxx create mode 100644 src/mred/wxs/wxs_lbox.h create mode 100644 src/mred/wxs/wxs_lbox.xc create mode 100644 src/mred/wxs/wxs_madm.cxx create mode 100644 src/mred/wxs/wxs_madm.h create mode 100644 src/mred/wxs/wxs_madm.xc create mode 100644 src/mred/wxs/wxs_madm.xci create mode 100644 src/mred/wxs/wxs_mbuf.xci create mode 100644 src/mred/wxs/wxs_mede.cxx create mode 100644 src/mred/wxs/wxs_mede.h create mode 100644 src/mred/wxs/wxs_mede.xc create mode 100644 src/mred/wxs/wxs_medi.cxx create mode 100644 src/mred/wxs/wxs_medi.h create mode 100644 src/mred/wxs/wxs_medi.xc create mode 100644 src/mred/wxs/wxs_menu.cxx create mode 100644 src/mred/wxs/wxs_menu.h create mode 100644 src/mred/wxs/wxs_menu.xc create mode 100644 src/mred/wxs/wxs_mio.cxx create mode 100644 src/mred/wxs/wxs_mio.h create mode 100644 src/mred/wxs/wxs_mio.xc create mode 100644 src/mred/wxs/wxs_misc.cxx create mode 100644 src/mred/wxs/wxs_misc.h create mode 100644 src/mred/wxs/wxs_misc.xc create mode 100644 src/mred/wxs/wxs_mpb.cxx create mode 100644 src/mred/wxs/wxs_mpb.h create mode 100644 src/mred/wxs/wxs_mpb.xc create mode 100644 src/mred/wxs/wxs_obj.cxx create mode 100644 src/mred/wxs/wxs_obj.h create mode 100644 src/mred/wxs/wxs_obj.xc create mode 100644 src/mred/wxs/wxs_ornt.xci create mode 100644 src/mred/wxs/wxs_panl.cxx create mode 100644 src/mred/wxs/wxs_panl.h create mode 100644 src/mred/wxs/wxs_panl.xc create mode 100644 src/mred/wxs/wxs_panl.xci create mode 100644 src/mred/wxs/wxs_rado.cxx create mode 100644 src/mred/wxs/wxs_rado.h create mode 100644 src/mred/wxs/wxs_rado.xc create mode 100644 src/mred/wxs/wxs_slid.cxx create mode 100644 src/mred/wxs/wxs_slid.h create mode 100644 src/mred/wxs/wxs_slid.xc create mode 100644 src/mred/wxs/wxs_snip.cxx create mode 100644 src/mred/wxs/wxs_snip.h create mode 100644 src/mred/wxs/wxs_snip.xc create mode 100644 src/mred/wxs/wxs_snip.xci create mode 100644 src/mred/wxs/wxs_styl.cxx create mode 100644 src/mred/wxs/wxs_styl.h create mode 100644 src/mred/wxs/wxs_styl.xc create mode 100644 src/mred/wxs/wxs_win.cxx create mode 100644 src/mred/wxs/wxs_win.h create mode 100644 src/mred/wxs/wxs_win.xc create mode 100644 src/mred/wxs/wxs_win.xci create mode 100644 src/mred/wxs/wxscheme.cxx create mode 100644 src/mred/wxs/wxscheme.h create mode 100644 src/mred/wxs/wxsmred.h create mode 100644 src/mysterx/Makefile create mode 100644 src/mysterx/README create mode 100644 src/mysterx/array.cxx create mode 100644 src/mysterx/browser.cxx create mode 100644 src/mysterx/comtypes.cxx create mode 100644 src/mysterx/htmlevent.cxx create mode 100644 src/mysterx/htmlutil.cxx create mode 100644 src/mysterx/htmlutil.h create mode 100644 src/mysterx/mysc/bstr.cxx create mode 100644 src/mysterx/mysc/bstr.h create mode 100644 src/mysterx/mysc/mysc.mak create mode 100644 src/mysterx/myspage/dhtmlpag.bmp create mode 100644 src/mysterx/myspage/dhtmlpage.cxx create mode 100644 src/mysterx/myspage/dhtmlpage.h create mode 100644 src/mysterx/myspage/dhtmlpage.rgs create mode 100644 src/mysterx/myspage/dhtmlpageui.htm create mode 100644 src/mysterx/myspage/event.cxx create mode 100644 src/mysterx/myspage/event.h create mode 100644 src/mysterx/myspage/event.rgs create mode 100644 src/mysterx/myspage/eventqueue.cxx create mode 100644 src/mysterx/myspage/eventqueue.h create mode 100644 src/mysterx/myspage/eventqueue.rgs create mode 100644 src/mysterx/myspage/myspage.cxx create mode 100644 src/mysterx/myspage/myspage.def create mode 100644 src/mysterx/myspage/myspage.idl create mode 100644 src/mysterx/myspage/myspage.mak create mode 100644 src/mysterx/myspage/myspage.rc create mode 100644 src/mysterx/myspage/resource.h create mode 100644 src/mysterx/myspage/stdafx.cxx create mode 100644 src/mysterx/myspage/stdafx.h create mode 100644 src/mysterx/myspage/wrapper.h create mode 100644 src/mysterx/myssink/comtypes.cxx create mode 100644 src/mysterx/myssink/comtypes.h create mode 100644 src/mysterx/myssink/myssink.cxx create mode 100644 src/mysterx/myssink/myssink.def create mode 100644 src/mysterx/myssink/myssink.idl create mode 100644 src/mysterx/myssink/myssink.mak create mode 100644 src/mysterx/myssink/myssink.rc create mode 100644 src/mysterx/myssink/myssinkps.def create mode 100644 src/mysterx/myssink/resource.h create mode 100644 src/mysterx/myssink/sink.cxx create mode 100644 src/mysterx/myssink/sink.h create mode 100644 src/mysterx/myssink/sink.rgs create mode 100644 src/mysterx/myssink/sinktbl.h create mode 100644 src/mysterx/myssink/stdafx.cxx create mode 100644 src/mysterx/myssink/stdafx.h create mode 100644 src/mysterx/mysterx.cxx create mode 100644 src/mysterx/mysterx.h create mode 100644 src/mysterx/mysterx.mak create mode 100644 src/mysterx/resource.h create mode 100644 src/mysterx/stdafx.cxx create mode 100644 src/mysterx/stdafx.h create mode 100644 src/mzcom/README create mode 100644 src/mzcom/mzcom.cxx create mode 100644 src/mzcom/mzcom.idl create mode 100644 src/mzcom/mzobj.cxx create mode 100644 src/mzcom/mzobj.h create mode 100644 src/mzcom/resource.h create mode 100644 src/mzcom/stdafx.cxx create mode 100644 src/mzcom/stdafx.h create mode 100644 src/mzscheme/Makefile.in create mode 100644 src/mzscheme/README create mode 100644 src/mzscheme/clean_ac.ss create mode 100644 src/mzscheme/cmdline.inc create mode 100644 src/mzscheme/configure.in create mode 100644 src/mzscheme/dynsrc/Makefile.in create mode 100644 src/mzscheme/dynsrc/dynexmpl.c create mode 100644 src/mzscheme/dynsrc/fixup.c create mode 100755 src/mzscheme/dynsrc/gmkmzdyn.bat create mode 100644 src/mzscheme/dynsrc/init.cc create mode 100644 src/mzscheme/dynsrc/mkmzdyn.bat create mode 100644 src/mzscheme/dynsrc/mzdyn.c create mode 100644 src/mzscheme/dynsrc/mzdyn.def create mode 100644 src/mzscheme/dynsrc/oe.c create mode 100644 src/mzscheme/dynsrc/start.c create mode 100644 src/mzscheme/gc/BCC_MAKEFILE create mode 100644 src/mzscheme/gc/EMX_MAKEFILE create mode 100644 src/mzscheme/gc/MacOS.c create mode 100644 src/mzscheme/gc/MacProjects.sit.hqx create mode 100644 src/mzscheme/gc/Mac_files/MacOS_Test_config.h create mode 100644 src/mzscheme/gc/Mac_files/MacOS_config.h create mode 100644 src/mzscheme/gc/Mac_files/dataend.c create mode 100644 src/mzscheme/gc/Mac_files/datastart.c create mode 100644 src/mzscheme/gc/Makefile.DLLs create mode 100644 src/mzscheme/gc/Makefile.dj create mode 100644 src/mzscheme/gc/Makefile.in create mode 100644 src/mzscheme/gc/NT_MAKEFILE create mode 100644 src/mzscheme/gc/OS2_MAKEFILE create mode 100644 src/mzscheme/gc/PCR-Makefile create mode 100644 src/mzscheme/gc/README create mode 100644 src/mzscheme/gc/README.Mac create mode 100644 src/mzscheme/gc/README.OS2 create mode 100644 src/mzscheme/gc/README.QUICK create mode 100644 src/mzscheme/gc/README.alpha create mode 100644 src/mzscheme/gc/README.amiga create mode 100644 src/mzscheme/gc/README.debugging create mode 100644 src/mzscheme/gc/README.dj create mode 100644 src/mzscheme/gc/README.hp create mode 100644 src/mzscheme/gc/README.linux create mode 100644 src/mzscheme/gc/README.rs6000 create mode 100644 src/mzscheme/gc/README.sgi create mode 100644 src/mzscheme/gc/README.solaris2 create mode 100644 src/mzscheme/gc/README.uts create mode 100644 src/mzscheme/gc/README.win32 create mode 100644 src/mzscheme/gc/SCoptions.amiga create mode 100644 src/mzscheme/gc/SMakefile.amiga create mode 100644 src/mzscheme/gc/WCC_MAKEFILE create mode 100644 src/mzscheme/gc/add_gc_prefix.c create mode 100644 src/mzscheme/gc/allchblk.c create mode 100644 src/mzscheme/gc/alloc.c create mode 100644 src/mzscheme/gc/alpha_mach_dep.s create mode 100644 src/mzscheme/gc/backptr.h create mode 100644 src/mzscheme/gc/barrett_diagram create mode 100644 src/mzscheme/gc/blacklst.c create mode 100755 src/mzscheme/gc/callprocs create mode 100644 src/mzscheme/gc/checksums.c create mode 100644 src/mzscheme/gc/cord/README create mode 100755 src/mzscheme/gc/cord/SCOPTIONS.amiga create mode 100644 src/mzscheme/gc/cord/SMakefile.amiga create mode 100644 src/mzscheme/gc/cord/cord.h create mode 100644 src/mzscheme/gc/cord/cordbscs.c create mode 100644 src/mzscheme/gc/cord/cordprnt.c create mode 100644 src/mzscheme/gc/cord/cordtest.c create mode 100644 src/mzscheme/gc/cord/cordxtra.c create mode 100644 src/mzscheme/gc/cord/de.c create mode 100644 src/mzscheme/gc/cord/de_cmds.h create mode 100755 src/mzscheme/gc/cord/de_win.ICO create mode 100644 src/mzscheme/gc/cord/de_win.RC create mode 100644 src/mzscheme/gc/cord/de_win.c create mode 100644 src/mzscheme/gc/cord/de_win.h create mode 100644 src/mzscheme/gc/cord/ec.h create mode 100644 src/mzscheme/gc/cord/gc.h create mode 100644 src/mzscheme/gc/cord/private/cord_pos.h create mode 100644 src/mzscheme/gc/dbg_mlc.c create mode 100644 src/mzscheme/gc/dyn_load.c create mode 100644 src/mzscheme/gc/finalize.c create mode 100644 src/mzscheme/gc/gc.h create mode 100644 src/mzscheme/gc/gc.mak create mode 100644 src/mzscheme/gc/gc.man create mode 100644 src/mzscheme/gc/gc_alloc.h create mode 100644 src/mzscheme/gc/gc_cpp.cc create mode 100644 src/mzscheme/gc/gc_cpp.h create mode 100644 src/mzscheme/gc/gc_hdrs.h create mode 100644 src/mzscheme/gc/gc_mark.h create mode 100644 src/mzscheme/gc/gc_priv.h create mode 100644 src/mzscheme/gc/gc_private.h create mode 100644 src/mzscheme/gc/gc_typed.h create mode 100644 src/mzscheme/gc/gc_watcom.asm create mode 100644 src/mzscheme/gc/gcc_support.c create mode 100644 src/mzscheme/gc/gcconfig.h create mode 100644 src/mzscheme/gc/headers.c create mode 100644 src/mzscheme/gc/if_mach.c create mode 100644 src/mzscheme/gc/if_not_there.c create mode 100644 src/mzscheme/gc/include/backptr.h create mode 100644 src/mzscheme/gc/include/cord.h create mode 100644 src/mzscheme/gc/include/ec.h create mode 100644 src/mzscheme/gc/include/gc.h create mode 100644 src/mzscheme/gc/include/gc_alloc.h create mode 100644 src/mzscheme/gc/include/gc_cpp.h create mode 100644 src/mzscheme/gc/include/gc_inl.h create mode 100644 src/mzscheme/gc/include/gc_inline.h create mode 100644 src/mzscheme/gc/include/gc_typed.h create mode 100644 src/mzscheme/gc/include/private/cord_pos.h create mode 100644 src/mzscheme/gc/include/private/gc_hdrs.h create mode 100644 src/mzscheme/gc/include/private/gc_priv.h create mode 100644 src/mzscheme/gc/include/private/gcconfig.h create mode 100644 src/mzscheme/gc/include/weakpointer.h create mode 100644 src/mzscheme/gc/irix_threads.c create mode 100644 src/mzscheme/gc/linux_threads.c create mode 100644 src/mzscheme/gc/mach_dep.c create mode 100644 src/mzscheme/gc/malloc.c create mode 100644 src/mzscheme/gc/mallocx.c create mode 100644 src/mzscheme/gc/mark.c create mode 100644 src/mzscheme/gc/mark_rts.c create mode 100644 src/mzscheme/gc/mips_sgi_mach_dep.s create mode 100644 src/mzscheme/gc/mips_ultrix_mach_dep.s create mode 100755 src/mzscheme/gc/misc.c create mode 100644 src/mzscheme/gc/new_hblk.c create mode 100644 src/mzscheme/gc/obj_map.c create mode 100644 src/mzscheme/gc/os_dep.c create mode 100644 src/mzscheme/gc/pc_excludes create mode 100644 src/mzscheme/gc/pcr_interface.c create mode 100644 src/mzscheme/gc/ptr_chck.c create mode 100644 src/mzscheme/gc/real_malloc.c create mode 100644 src/mzscheme/gc/reclaim.c create mode 100644 src/mzscheme/gc/rs6000_mach_dep.s create mode 100644 src/mzscheme/gc/setjmp_t.c create mode 100644 src/mzscheme/gc/solaris_pthreads.c create mode 100644 src/mzscheme/gc/solaris_threads.c create mode 100644 src/mzscheme/gc/solaris_threads.h create mode 100644 src/mzscheme/gc/sparc_mach_dep.s create mode 100644 src/mzscheme/gc/sparc_sunos4_mach_dep.s create mode 100644 src/mzscheme/gc/stubborn.c create mode 100644 src/mzscheme/gc/test.c create mode 100644 src/mzscheme/gc/test_cpp.cc create mode 100644 src/mzscheme/gc/threadlibs.c create mode 100644 src/mzscheme/gc/typd_mlc.c create mode 100755 src/mzscheme/gc/update_includes create mode 100644 src/mzscheme/gc/version.h create mode 100644 src/mzscheme/gc/weakpointer.h create mode 100755 src/mzscheme/gc/win32_threads.c create mode 100644 src/mzscheme/gc2/Makefile.in create mode 100644 src/mzscheme/gc2/README create mode 100644 src/mzscheme/gc2/compact.c create mode 100644 src/mzscheme/gc2/copy.c create mode 100644 src/mzscheme/gc2/ctok.lex create mode 100644 src/mzscheme/gc2/gc.h create mode 100644 src/mzscheme/gc2/gc2.c create mode 100644 src/mzscheme/gc2/gc2.h create mode 100644 src/mzscheme/gc2/noncopy.c create mode 100644 src/mzscheme/gc2/xform.ss create mode 100644 src/mzscheme/guile/Makefile.in create mode 100644 src/mzscheme/guile/NOTES create mode 100644 src/mzscheme/guile/README create mode 100644 src/mzscheme/guile/gh.h create mode 100644 src/mzscheme/guile/ghbase.h create mode 100644 src/mzscheme/guile/guile.c create mode 100644 src/mzscheme/guile/guileinc.c create mode 100755 src/mzscheme/guile/mkghsrc create mode 100644 src/mzscheme/guile/test.c create mode 100644 src/mzscheme/guile/wrap.inc create mode 100644 src/mzscheme/include/escheme.h create mode 100644 src/mzscheme/include/ext.exp create mode 100644 src/mzscheme/include/gmzwin.def create mode 100644 src/mzscheme/include/mzscheme.exp create mode 100644 src/mzscheme/include/mzwin.def create mode 100644 src/mzscheme/include/scheme.h create mode 100644 src/mzscheme/macglue.inc create mode 100644 src/mzscheme/main.c create mode 100644 src/mzscheme/oskglue.inc create mode 100644 src/mzscheme/palm/Makefile.in create mode 100644 src/mzscheme/palm/README create mode 100644 src/mzscheme/palm/debuginfo.ss create mode 100644 src/mzscheme/palm/mzpalm.h create mode 100644 src/mzscheme/palm/mzscheme.pbm create mode 100644 src/mzscheme/palm/mzscheme.rcp create mode 100644 src/mzscheme/palm/palm.c create mode 100644 src/mzscheme/palm/partition.ss create mode 100644 src/mzscheme/palm/resnum.h create mode 100644 src/mzscheme/palm/utils.c create mode 100644 src/mzscheme/sconfig.h create mode 100644 src/mzscheme/sgc/Makefile.in create mode 100644 src/mzscheme/sgc/README create mode 100644 src/mzscheme/sgc/autostat.inc create mode 100755 src/mzscheme/sgc/checkreg create mode 100644 src/mzscheme/sgc/collect.inc create mode 100644 src/mzscheme/sgc/gc.h create mode 100644 src/mzscheme/sgc/sgc.c create mode 100644 src/mzscheme/sgc/sgc.h create mode 100755 src/mzscheme/sgc/sgcdiff create mode 100644 src/mzscheme/sgc/splay.c create mode 100644 src/mzscheme/sgc/test.c create mode 100644 src/mzscheme/src/Makefile.in create mode 100644 src/mzscheme/src/bgnfloat.inc create mode 100644 src/mzscheme/src/bignum.c create mode 100644 src/mzscheme/src/bool.c create mode 100644 src/mzscheme/src/builtin.c create mode 100644 src/mzscheme/src/char.c create mode 100644 src/mzscheme/src/cmacro.inc create mode 100644 src/mzscheme/src/complex.c create mode 100644 src/mzscheme/src/cunitsig.inc create mode 100644 src/mzscheme/src/dynext.c create mode 100644 src/mzscheme/src/dynext.inc create mode 100644 src/mzscheme/src/env.c create mode 100644 src/mzscheme/src/error.c create mode 100644 src/mzscheme/src/eval.c create mode 100644 src/mzscheme/src/exnsrc.ss create mode 100644 src/mzscheme/src/file.c create mode 100644 src/mzscheme/src/fun.c create mode 100644 src/mzscheme/src/hash.c create mode 100644 src/mzscheme/src/image.c create mode 100644 src/mzscheme/src/list.c create mode 100644 src/mzscheme/src/mac_roman.inc create mode 100644 src/mzscheme/src/macro.inc create mode 100644 src/mzscheme/src/macro.ss create mode 100755 src/mzscheme/src/makeexn create mode 100755 src/mzscheme/src/makex create mode 100644 src/mzscheme/src/mkmark.ss create mode 100644 src/mzscheme/src/mzeqchk.inc create mode 100644 src/mzscheme/src/mzmark.c create mode 100644 src/mzscheme/src/mzmarksrc.c create mode 100644 src/mzscheme/src/mzsj86.c create mode 100644 src/mzscheme/src/mzstkchk.h create mode 100644 src/mzscheme/src/network.c create mode 100644 src/mzscheme/src/numarith.c create mode 100644 src/mzscheme/src/number.c create mode 100644 src/mzscheme/src/numcomp.c create mode 100644 src/mzscheme/src/nummacs.h create mode 100644 src/mzscheme/src/numstr.c create mode 100644 src/mzscheme/src/objclass.c create mode 100644 src/mzscheme/src/object.c create mode 100644 src/mzscheme/src/pc_keys.inc create mode 100644 src/mzscheme/src/port.c create mode 100644 src/mzscheme/src/portfun.c create mode 100644 src/mzscheme/src/print.c create mode 100644 src/mzscheme/src/process.c create mode 100644 src/mzscheme/src/promise.c create mode 100644 src/mzscheme/src/qqsrc.ss create mode 100644 src/mzscheme/src/random.inc create mode 100644 src/mzscheme/src/ratfloat.inc create mode 100644 src/mzscheme/src/rational.c create mode 100644 src/mzscheme/src/read.c create mode 100644 src/mzscheme/src/regexp.c create mode 100644 src/mzscheme/src/salloc.c create mode 100644 src/mzscheme/src/schapp.inc create mode 100644 src/mzscheme/src/schcpt.h create mode 100644 src/mzscheme/src/schemef.h create mode 100644 src/mzscheme/src/schemex.h create mode 100644 src/mzscheme/src/schemex.inc create mode 100644 src/mzscheme/src/schemexm.h create mode 100644 src/mzscheme/src/schexn.h create mode 100644 src/mzscheme/src/schfd.h create mode 100644 src/mzscheme/src/schgc.h create mode 100644 src/mzscheme/src/schmach.h create mode 100644 src/mzscheme/src/schminc.h create mode 100644 src/mzscheme/src/schpriv.h create mode 100644 src/mzscheme/src/schrunst.h create mode 100644 src/mzscheme/src/schvers.h create mode 100644 src/mzscheme/src/schwinfd.h create mode 100644 src/mzscheme/src/sema.c create mode 100644 src/mzscheme/src/setjmpup.c create mode 100755 src/mzscheme/src/sstoinc create mode 100644 src/mzscheme/src/sstoinc.ss create mode 100644 src/mzscheme/src/string.c create mode 100644 src/mzscheme/src/struct.c create mode 100644 src/mzscheme/src/stypes.h create mode 100644 src/mzscheme/src/symbol.c create mode 100644 src/mzscheme/src/syntax.c create mode 100755 src/mzscheme/src/sysname create mode 100644 src/mzscheme/src/tsymbol.c create mode 100644 src/mzscheme/src/type.c create mode 100644 src/mzscheme/src/unit.c create mode 100644 src/mzscheme/src/unitsig.c create mode 100644 src/mzscheme/src/unitsig.inc create mode 100644 src/mzscheme/src/unitsig.ss create mode 100644 src/mzscheme/src/vector.c create mode 100644 src/mzscheme/uconfig.h create mode 100644 src/mzscheme/utils/README create mode 100644 src/mzscheme/utils/common.pl create mode 100644 src/mzscheme/utils/parse.pl create mode 100755 src/mzscheme/utils/sigclean create mode 100644 src/mzscheme/utils/xcglue.c create mode 100644 src/mzscheme/utils/xcglue.h create mode 100755 src/mzscheme/utils/xctocc create mode 100755 src/mzscheme/utils/xctocmn create mode 100755 src/mzscheme/utils/xctosig create mode 100755 src/mzscheme/utils/xctotest create mode 100755 src/mzscheme/utils/xctotex create mode 100644 src/srpersist/Makefile create mode 100644 src/srpersist/README create mode 100644 src/srpersist/srpbitmask.tbl create mode 100644 src/srpersist/srpbuffer.cxx create mode 100644 src/srpersist/srpbuffer.h create mode 100644 src/srpersist/srpconsts.tbl create mode 100644 src/srpersist/srpersist.cxx create mode 100644 src/srpersist/srpersist.h create mode 100644 src/srpersist/srpersist.mac-make.hqx create mode 100644 src/srpersist/srpersist.mak create mode 100644 src/srpersist/srpersist.pch create mode 100644 src/srpersist/srpexns.tbl create mode 100644 src/srpersist/srpinfo.tbl create mode 100644 src/srpersist/srpprims.tbl create mode 100644 src/srpersist/srpstructs.tbl create mode 100644 src/srpersist/srptypes.cxx create mode 100644 src/srpersist/srptypes.h create mode 100644 src/worksp/README create mode 100644 src/worksp/gc/gc.dsp create mode 100644 src/worksp/gc/gc.dsw create mode 100644 src/worksp/gc/gc.mak create mode 100644 src/worksp/gc/gc.opt create mode 100644 src/worksp/mred/mred.dsp create mode 100644 src/worksp/mred/mred.dsw create mode 100755 src/worksp/mred/mred.ico create mode 100644 src/worksp/mred/mred.mak create mode 100644 src/worksp/mred/mred.opt create mode 100755 src/worksp/mred/mred.rc create mode 100644 src/worksp/mrstart/mrstart.dsp create mode 100644 src/worksp/mrstart/mrstart.dsw create mode 100755 src/worksp/mrstart/mrstart.mak create mode 100644 src/worksp/mrstart/mrstart.opt create mode 100644 src/worksp/mzcom/MzCOMCP.h create mode 100644 src/worksp/mzcom/README create mode 100644 src/worksp/mzcom/mzcom.def create mode 100644 src/worksp/mzcom/mzcom.dsp create mode 100644 src/worksp/mzcom/mzcom.dsw create mode 100644 src/worksp/mzcom/mzcom.ico create mode 100644 src/worksp/mzcom/mzcom.mak create mode 100644 src/worksp/mzcom/mzcom.ncb create mode 100644 src/worksp/mzcom/mzcom.opt create mode 100644 src/worksp/mzcom/mzcom.rc create mode 100644 src/worksp/mzcom/mzcomps.def create mode 100644 src/worksp/mzcom/mzobj.rgs create mode 100644 src/worksp/mzscheme/mzscheme.dsp create mode 100644 src/worksp/mzscheme/mzscheme.dsw create mode 100755 src/worksp/mzscheme/mzscheme.ico create mode 100644 src/worksp/mzscheme/mzscheme.mak create mode 100644 src/worksp/mzscheme/mzscheme.opt create mode 100755 src/worksp/mzscheme/mzscheme.rc create mode 100755 src/worksp/mzscheme/resource.h create mode 100644 src/worksp/mzsrc/mzsrc.dsp create mode 100644 src/worksp/mzsrc/mzsrc.dsw create mode 100644 src/worksp/mzsrc/mzsrc.mak create mode 100644 src/worksp/mzsrc/mzsrc.opt create mode 100644 src/worksp/mzstart/mzstart.dsp create mode 100644 src/worksp/mzstart/mzstart.dsw create mode 100755 src/worksp/mzstart/mzstart.mak create mode 100644 src/worksp/rebuild.bat create mode 100644 src/worksp/sgc/sgc.dsp create mode 100644 src/worksp/sgc/sgc.dsw create mode 100644 src/worksp/sgc/sgc.mak create mode 100644 src/worksp/sgc/sgc.opt create mode 100644 src/worksp/starters/mrstart.ico create mode 100644 src/worksp/starters/mzstart.ico create mode 100644 src/worksp/starters/resource.h create mode 100644 src/worksp/starters/start.rc create mode 100644 src/worksp/wxs/wxs.dsp create mode 100644 src/worksp/wxs/wxs.dsw create mode 100644 src/worksp/wxs/wxs.mak create mode 100644 src/worksp/wxs/wxs.opt create mode 100644 src/worksp/wxutils/wxutils.dsp create mode 100644 src/worksp/wxutils/wxutils.dsw create mode 100644 src/worksp/wxutils/wxutils.mak create mode 100644 src/worksp/wxutils/wxutils.opt create mode 100644 src/worksp/wxwin/wxwin.dsp create mode 100644 src/worksp/wxwin/wxwin.dsw create mode 100644 src/worksp/wxwin/wxwin.mak create mode 100644 src/worksp/wxwin/wxwin.opt create mode 100644 src/wxcommon/FontDirectory.cxx create mode 100644 src/wxcommon/FontDirectory.h create mode 100644 src/wxcommon/PSDC.cxx create mode 100644 src/wxcommon/PSDC.h create mode 100644 src/wxcommon/Region.cxx create mode 100644 src/wxcommon/Region.h create mode 100644 src/wxcommon/wb_hash.cxx diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 28a033b0..939a0972 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -21,7 +21,8 @@ [framework:keys : framework:keys^] [framework:test : framework:test^] [m : mred^]) - (link [f : frameworkc^ ((require-relative-library "frameworkc.ss") + (link [prefs-file : framework:prefs-file^ ((require-relative-library "prefs-file.ss"))] + [f : frameworkc^ ((require-relative-library "frameworkc.ss") core:string core:function core:pretty-print @@ -29,7 +30,8 @@ core:thread m framework:keys - framework:test)]) + framework:test + prefs-file)]) (export (open f))) #f mzlib:string^ diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index c89136d7..ed1e5151 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -9,7 +9,10 @@ (require-relative-library "macro.ss") (require-relative-library "tests.ss") -(Require-relative-library "guiutilss.ss") +(require-relative-library "guiutilss.ss") + +(define-signature framework:prefs-file^ + (preferences-filename)) (define-signature framework:version^ (add-spec diff --git a/collects/framework/prefs.ss b/collects/framework/prefs.ss index 36273770..3fb7fa1b 100644 --- a/collects/framework/prefs.ss +++ b/collects/framework/prefs.ss @@ -1,5 +1,6 @@ (unit/sig framework:preferences^ (import mred^ + [prefs-file : framework:prefs-file^] [exn : framework:exn^] [exit : framework:exit^] [panel : framework:panel^] @@ -8,11 +9,6 @@ (rename [-read read]) - (define preferences-filename (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [else ".mred.prefs"]))) (define default-preferences-filename (build-path (collection-path "defaults") "prefs.ss")) ;; preferences : sym -o> (union marshalled pref) @@ -211,13 +207,13 @@ (message-box "Error saving preferences" (exn-message exn)))]) - (call-with-output-file preferences-filename + (call-with-output-file prefs-file:preferences-filename (lambda (p) (mzlib:pretty-print:pretty-print (hash-table-map preferences marshall-pref) p)) 'truncate 'text))))) - (define (for-each-pref-in-file parse-pref preferences-filename) + (define (for-each-pref-in-file parse-pref prefs-file:preferences-filename) (let/ec k (let ([err (lambda (input msg) @@ -232,7 +228,7 @@ (string-length ell))) ell))]) (format "found bad pref in ~a: ~a~n~a" - preferences-filename msg s2))))]) + prefs-file:preferences-filename msg s2))))]) (let ([input (with-handlers ([(lambda (exn) #t) (lambda (exn) @@ -241,7 +237,7 @@ (format "Error reading preferences~n~a" (exn-message exn))) (k #f))]) - (call-with-input-file preferences-filename + (call-with-input-file prefs-file:preferences-filename read 'text))]) (let loop ([input input]) @@ -296,7 +292,7 @@ ;; read : -> void (define (-read) - (read-from-file-to-ht preferences-filename preferences)) + (read-from-file-to-ht prefs-file:preferences-filename preferences)) ;; read in the saved defaults. These should override the @@ -364,7 +360,8 @@ "Use separate dialog for searching" id id) - main)))) + main))) + (set! add-general-panel void)) (define (add-font-panel) (let* ([font-families-name/const @@ -536,7 +533,8 @@ #t)) (for-each (lambda (f) (f initial-font-size)) set-edit-fonts) (make-object message% "Restart to see font changes" main) - main))))) + main)))) + (set! add-font-panel void)) (define preferences-dialog #f) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 55de0a55..3aef5dc9 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -45,16 +45,22 @@ name)))] [(quit-on-close?) #t] + [(dropped-files) null] + [(get-dropped-files) (lambda () dropped-files)] [(splash-frame%) (class frame% (title) (override - [on-close - (lambda () - (when quit-on-close? - (exit)))]) + [on-drop-file + (lambda (filename) + (set! dropped-files (cons filename dropped-files)))] + [on-close + (lambda () + (when quit-on-close? + (exit)))]) (sequence (super-init title)))] [(frame) (parameterize ([current-eventspace (make-eventspace)]) (make-object splash-frame% title))] + [(_0) (send frame accept-drop-files #t)] [(bitmap-flag) (let ([len (string-length filename)]) (if (<= len 4) @@ -122,5 +128,6 @@ (set! quit-on-close? #f) (send frame show #f))]) (values + get-dropped-files shutdown-splash close-splash)))) diff --git a/collects/mzlib/traceld.ss b/collects/mzlib/traceld.ss new file mode 100644 index 00000000..34cd44ad --- /dev/null +++ b/collects/mzlib/traceld.ss @@ -0,0 +1,2 @@ + +(invoke-unit/sig (require-relative-library "traceldr.ss")) diff --git a/collects/mzlib/traceldr.ss b/collects/mzlib/traceldr.ss new file mode 100644 index 00000000..542cb0f1 --- /dev/null +++ b/collects/mzlib/traceldr.ss @@ -0,0 +1,49 @@ + +(unit/sig + () + (import) + (let ([load (current-load)] + [load-extension (current-load-extension)] + [ep (current-error-port)] + [tab ""]) + (let ([mk-chain + (lambda (load) + (lambda (filename) + (fprintf ep + "~aloading ~a at ~a~n" + tab filename (current-process-milliseconds)) + (begin0 + (let ([s tab]) + (dynamic-wind + (lambda () (set! tab (string-append " " tab))) + (lambda () + (if (regexp-match "_loader" filename) + (let ([f (load filename)]) + (lambda (sym) + (fprintf ep + "~atrying ~a's ~a~n" tab filename sym) + (let ([loader (f sym)]) + (and loader + (lambda () + (fprintf ep + "~astarting ~a's ~a at ~a~n" + tab filename sym + (current-process-milliseconds)) + (let ([s tab]) + (begin0 + (dynamic-wind + (lambda () (set! tab (string-append " " tab))) + (lambda () (loader)) + (lambda () (set! tab s))) + (fprintf ep + "~adone ~a's ~a at ~a~n" + tab filename sym + (current-process-milliseconds))))))))) + (load filename))) + (lambda () (set! tab s)))) + (fprintf ep + "~adone ~a at ~a~n" + tab filename (current-process-milliseconds)))))]) + (current-load (mk-chain load)) + (current-load-extension (mk-chain load-extension))))) + diff --git a/collects/mzlib/transcr.ss b/collects/mzlib/transcr.ss new file mode 100644 index 00000000..94061ab1 --- /dev/null +++ b/collects/mzlib/transcr.ss @@ -0,0 +1,8 @@ + +(require-library "transcru.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:transcript^ + mzlib:transcript@) diff --git a/collects/mzlib/transcrr.ss b/collects/mzlib/transcrr.ss new file mode 100644 index 00000000..6074bdc1 --- /dev/null +++ b/collects/mzlib/transcrr.ss @@ -0,0 +1,60 @@ + +(unit/sig mzlib:transcript^ + (import) + + (define-values (transcript-on transcript-off) + (let ([in #f] + [out #f] + [err #f] + [tee-out (lambda (p p2) + (make-output-port + (lambda (s) + (display s p) + (display s p2) + (flush-output p) + (flush-output p2)) + void))] + [tee-in (lambda (in out) + (let ([s null]) + (make-input-port + (lambda () + (let loop () + (if (null? s) + (begin + (let loop () + (set! s (cons (read-char in) s)) + (when (char-ready? in) + (loop))) + (set! s (reverse! s)) + (for-each + (lambda (c) (unless (eof-object? c) (write-char c out))) + s) + (flush-output out) + (loop)) + (begin0 + (car s) + (set! s (cdr s)))))) + (lambda () (char-ready? in)) + void + (lambda () (peek-char in)))))]) + (values + (lambda (file) + (when in + (error 'transcript-on "transcript is already on")) + (let ([p (open-output-file file)]) + (set! in (current-input-port)) + (set! out (current-output-port)) + (set! err (current-error-port)) + (current-output-port (tee-out out p)) + (current-error-port (tee-out err p)) + (current-input-port (tee-in in p)))) + (lambda () + (unless in + (error 'transcript-on "transcript is not on")) + (current-input-port in) + (current-output-port out) + (current-error-port err) + (set! in #f) + (set! out #f) + (set! err #f)))))) + diff --git a/collects/mzlib/transcrs.ss b/collects/mzlib/transcrs.ss new file mode 100644 index 00000000..28959948 --- /dev/null +++ b/collects/mzlib/transcrs.ss @@ -0,0 +1,4 @@ + +(define-signature mzlib:transcript^ + (transcript-on + transcript-off)) diff --git a/collects/mzlib/transcru.ss b/collects/mzlib/transcru.ss new file mode 100644 index 00000000..51dd167c --- /dev/null +++ b/collects/mzlib/transcru.ss @@ -0,0 +1,8 @@ + +(require-library "transcrs.ss") + +(begin-elaboration-time + (require-library "refer.ss")) + +(define mzlib:transcript@ (require-library-unit/sig "transcrr.ss")) + diff --git a/collects/mzscheme/examples/README b/collects/mzscheme/examples/README new file mode 100644 index 00000000..aabfdc39 --- /dev/null +++ b/collects/mzscheme/examples/README @@ -0,0 +1,27 @@ +This directory contains a few example MzScheme extensions implemented +in C: + + * hello.c - returns the string "Hello, World!". Demonstrates creating + a Scheme value. + + * fmod.c - defines the `fmod' procedure, which calculates modulo on + floating-point numbers. Demonstrates creating Scheme procedures + from C and adding top-level definitions. + + * curses.c - links MzScheme to the curses library. Demonstrates more + procedures and definitions, a little more type dispatching, and + returning multiple values. + + * makeadder.c - defines `make-adder', whch takes a number and returns + a procedure that takes another number to add to it. Demonstrates + closure creation in C, getting Scheme global values, and calling + Scheme procedures from C. + + * bitmatrix.c - implements two-dimentional bit matrixes with some + operations. Demonstrates defining a new Scheme data type, data + allocation, fancy integer type checking, general exception raising, + and registering static variables. + + * helloprint.c - prints "Hello, World!" directly to the current + output port rather than relying on the read-eval-print-loop. + Demonstrates using built-in Scheme parameter values from C. diff --git a/collects/mzscheme/examples/bitmatrix.c b/collects/mzscheme/examples/bitmatrix.c new file mode 100644 index 00000000..89109a89 --- /dev/null +++ b/collects/mzscheme/examples/bitmatrix.c @@ -0,0 +1,294 @@ +/* + + This extension Defines a new type of Scheme data: a two-dimensional + matrix of bits. + + A client using this extension would look something like this: + + (load-extension "bitmatrix.so") + (define bm (make-bit-matrix 1000 1000)) + ... + (bit-matrix-set! bm 500 500 #t) + ... + (if (bit-matrix-get bm 500 500) ...) + ... + +*/ + +#include "escheme.h" + +/* Instances of this Bitmatrix structure will be the Scheme bit matirx + values: */ +typedef struct { + Scheme_Type type; /* Every Scheme value starts with a type tag. The + format for the rest of the structure is + anything we want it to be. */ + unsigned long w, h, l; /* l = w rounded to multiple of LONG_SIZE */ + unsigned long *matrix; +} Bitmatrix; + +/* We'll get some Scheme primitives so we can calculate with numbers + taht are potentially bignums: */ +static Scheme_Object *mult, *add, *sub, *modulo, *neg; + +/* The type tag for bit matrixes, initialized with scheme_make_type */ +static Scheme_Type bitmatrix_type; + +#define LONG_SIZE 32 +#define LOG_LONG_SIZE 5 +#define LONG_SIZE_PER_BYTE 4 + +# define FIND_BIT(p) (1 << (p & (LONG_SIZE - 1))) + +/* Helper function to check whether an integer (fixnum or bignum) is + negative: */ +static int negative(Scheme_Object *o) +{ + return SCHEME_TRUEP(_scheme_apply(neg, 1, &o)); +} + +/* Scheme procedure to make a bit matrix: */ +Scheme_Object *make_bit_matrix(int argc, Scheme_Object **argv) +{ + Scheme_Object *size, *rowlength, *a[2]; + unsigned long w, h, s, l; + Bitmatrix *bm; + + /* Really fancy: we allow any kind of positive integer for + specifying the size of a bit matrix. If we get a bignum (or the + resulting matrix size is a bignum), we'll signal an out-of-memory + exception. */ + if ((!SCHEME_INTP(argv[0]) && !SCHEME_BIGNUMP(argv[0])) + || negative(argv[0])) + scheme_wrong_type("make-bit-matrix", "positive integer", 0, argc, argv); + if ((!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1])) + || (negative(argv[1]))) + scheme_wrong_type("make-bit-matrix", "positive integer", 1, argc, argv); + + a[0] = argv[0]; + a[1] = scheme_make_integer(LONG_SIZE - 1); + /* Apply the Scheme `add' procedure to argv[0] and argv[1]. Note the + "_" in "_scheme_apply"; that's a lot faster than "scheme_apply", + and we know that no continuation jumps will occur (although it + would be fine if one did. */ + a[0] = _scheme_apply(add, 2, a); + a[1] = scheme_make_integer(LONG_SIZE); + a[1] = _scheme_apply(modulo, 2, a); + a[0] = _scheme_apply(sub, 2, a); + rowlength = a[0]; + a[1] = argv[1]; + size = _scheme_apply(mult, 2, a); + if (SCHEME_BIGNUMP(size)) + /* Use scheme_raise_exn to raise exceptions. The first argument + describes the tye of the exception. After an exception-specific + number of Scheme values (none in this case), the rest of the + arguments are like printf. */ + scheme_raise_exn(MZEXN_MISC_OUT_OF_MEMORY, "make-bit-matrix: out of memory"); + + s = SCHEME_INT_VAL(size); + w = SCHEME_INT_VAL(argv[0]); + h = SCHEME_INT_VAL(argv[1]); + l = SCHEME_INT_VAL(rowlength); + + /* Malloc the bit matrix structure. Since we use scheme_malloc, the + bit matrix value is GC-able. */ + bm = (Bitmatrix *)scheme_malloc(sizeof(Bitmatrix)); + bm->type = bitmatrix_type; + + /* Try to allocate the bit matrix. Handle failure gracefully. Note + that we use scheme_malloc_atomic since the allocated memory will + never contain pointers to GC-allocated memory. */ + s = ((s + LONG_SIZE - 1) >> LOG_LONG_SIZE); + bm->matrix = (unsigned long *)scheme_malloc_fail_ok(scheme_malloc_atomic, + sizeof(long) * s); + if (!bm->matrix) + scheme_raise_exn(MZEXN_MISC_OUT_OF_MEMORY, "make-bit-matrix: out of memory"); + + bm->w = w; + bm->h = h; + bm->l = l; + + /* Init matirx to all 0s: */ + while (s--) + bm->matrix[s] = 0; + + return (Scheme_Object *)bm; +} + +/* Internal utility function for error-checking with a fancy error + message: */ +static void range_check_one(char *name, char *which, + int l, int h, int startpos, + int argc, Scheme_Object **argv) +{ + int bad1; + + if (SCHEME_BIGNUMP(argv[startpos])) { + bad1 = 1; + } else { + int v = SCHEME_INT_VAL(argv[startpos]); + bad1 = ((v < l) || (v > h)); + } + + if (bad1) { + /* A mismatch exception requires one Scheme value, so we provide + it before the printf string: */ + scheme_raise_exn(MZEXN_APPLICATION_MISMATCH, + argv[startpos], + "%s: %s index %s is not in the range [%d,%d]%s", + name, which, + scheme_make_provided_string(argv[startpos], 1, NULL), + l, h, + scheme_make_args_string("other ", startpos, argc, argv)); + } +} + +/* Internal utility function that implements most of the work of the + get- and set- Scheme procedures: */ +static Scheme_Object *do_bit_matrix(char *name, int get, int argc, Scheme_Object **argv) +{ + Bitmatrix *bm; + unsigned long x, y, p, v, m; + + if (SCHEME_TYPE(argv[0]) != bitmatrix_type) + scheme_wrong_type(name, "bit-matrix", 0, argc, argv); + if (!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1])) + scheme_wrong_type(name, "integer", 1, argc, argv); + if (!SCHEME_INTP(argv[2]) && !SCHEME_BIGNUMP(argv[2])) + scheme_wrong_type(name, "integer", 2, argc, argv); + + /* After checking that argv[0] has te bitmatrix_type tag, we can safely perform + a cast to Bitmatrix*: */ + bm = (Bitmatrix *)argv[0]; + + range_check_one(name, "first", 0, bm->w - 1, 1, argc, argv); + range_check_one(name, "second", 0, bm->h - 1, 2, argc, argv); + + x = SCHEME_INT_VAL(argv[1]); + y = SCHEME_INT_VAL(argv[2]); + + p = y * bm->l + x; + m = FIND_BIT(p); + v = bm->matrix[p >> LOG_LONG_SIZE]; + if (get) { + return (v & m) ? scheme_true : scheme_false; + } else { + if (SCHEME_TRUEP(argv[3])) + bm->matrix[p >> LOG_LONG_SIZE] = (v | m); + else + bm->matrix[p >> LOG_LONG_SIZE] = (v - (v & m)); + return scheme_void; + } +} + +/* Scheme procedure: get a bit from the matrix */ +Scheme_Object *bit_matrix_get(int argc, Scheme_Object **argv) +{ + return do_bit_matrix("bit-matrix-get", 1, argc, argv); +} + +/* Scheme procedure: set a bit in the matrix */ +Scheme_Object *bit_matrix_set(int argc, Scheme_Object **argv) +{ + return do_bit_matrix("bit-matrix-set!", 0, argc, argv); +} + +/* Scheme procedure: invert the whole matrix */ +Scheme_Object *bit_matrix_invert(int argc, Scheme_Object **argv) +{ + Bitmatrix *bm; + unsigned long i; + + if (SCHEME_TYPE(argv[0]) != bitmatrix_type) + scheme_wrong_type("bit-matrix-invert!", "bit-matrix", 0, argc, argv); + + bm = (Bitmatrix *)argv[0]; + + i = (bm->l * bm->h) >> LOG_LONG_SIZE; + while (i--) + bm->matrix[i] = ~bm->matrix[i]; + + return scheme_void; +} + +/* Scheme procedure: clear the whole matrix */ +Scheme_Object *bit_matrix_clear(int argc, Scheme_Object **argv) +{ + char *name = "bit-matrix-clear!"; + Bitmatrix *bm; + unsigned long i; + + if (SCHEME_TYPE(argv[0]) != bitmatrix_type) + scheme_wrong_type(name, "bit-matrix", 0, argc, argv); + + bm = (Bitmatrix *)argv[0]; + + i = (bm->l * bm->h) >> LOG_LONG_SIZE; + while (i--) + bm->matrix[i] = 0; + + return scheme_void; +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + /* Define our new primitives: */ + + scheme_add_global("make-bit-matrix", + scheme_make_prim_w_arity(make_bit_matrix, + "make-bit-matrix", + 2, 2), + env); + + scheme_add_global("bit-matrix-get", + scheme_make_prim_w_arity(bit_matrix_get, + "bit-matrix-get", + 3, 3), + env); + + scheme_add_global("bit-matrix-set!", + scheme_make_prim_w_arity(bit_matrix_set, + "bit-matrix-set!", + 4, 4), + env); + + scheme_add_global("bit-matrix-invert!", + scheme_make_prim_w_arity(bit_matrix_invert, + "bit-matrix-invert!", + 1, 1), + env); + + scheme_add_global("bit-matrix-clear!", + scheme_make_prim_w_arity(bit_matrix_clear, + "bit-matrix-clear!", + 1, 1), + env); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + bitmatrix_type = scheme_make_type(""); + + /* Get some Scheme primitives. Conservative garbage collection sees + any local variables we use within a function, but we have to register + static variables: */ + + scheme_register_extension_global(&mult, sizeof(Scheme_Object*)); + mult = scheme_lookup_global(scheme_intern_symbol("#%*"), env); + + scheme_register_extension_global(&add, sizeof(Scheme_Object*)); + add = scheme_lookup_global(scheme_intern_symbol("#%+"), env); + + scheme_register_extension_global(&sub, sizeof(Scheme_Object*)); + sub = scheme_lookup_global(scheme_intern_symbol("#%-"), env); + + scheme_register_extension_global(&modulo, sizeof(Scheme_Object*)); + modulo = scheme_lookup_global(scheme_intern_symbol("#%modulo"), env); + + scheme_register_extension_global(&neg, sizeof(Scheme_Object*)); + neg = scheme_lookup_global(scheme_intern_symbol("#%negative?"), env); + + return scheme_reload(env); +} diff --git a/collects/mzscheme/examples/curses-demo.ss b/collects/mzscheme/examples/curses-demo.ss new file mode 100644 index 00000000..299e7e52 --- /dev/null +++ b/collects/mzscheme/examples/curses-demo.ss @@ -0,0 +1,23 @@ + +; Uses the curses.so extension. Run with +; mzscheme -r curses-demo.ss + +; To get append-extension-suffix, shich add .so or .ddl, as +; approrpiate for the current platform: +(require-library "file.ss" "dynext") + +; Load the curses extension +(load-extension (append-extension-suffix "curses")) + +; Screen is initialize. Let's go! +(move 10 10) +(put "Hello, World!") +(put #\newline) +(put "Hit any key to continue.") +(refresh) + +(get) + + + + diff --git a/collects/mzscheme/examples/curses.c b/collects/mzscheme/examples/curses.c new file mode 100644 index 00000000..f92ab10b --- /dev/null +++ b/collects/mzscheme/examples/curses.c @@ -0,0 +1,124 @@ +/* + Extension that uses the curses library. + + Link the extension to the curses library like this: + mzc --ld hello.so hello.o -lcurses + + For obvious reasons, this library doesn't interact well + with MzScheme's read-eval-print loop. The example file + curses-demo.ss demos this extension. +*/ + +#include "escheme.h" +#include + +/**************************************************/ + +static Scheme_Object *sch_clear(int argc, Scheme_Object **argv) +{ + clear(); +} + +static Scheme_Object *sch_put(int argc, Scheme_Object **argv) +{ + /* Puts a char or string on the screen */ + if (SCHEME_CHARP(argv[0])) + addch(SCHEME_CHAR_VAL(argv[0])); + else if (SCHEME_STRINGP(argv[0])) + addstr(SCHEME_STR_VAL(argv[0])); + else + scheme_wrong_type("put", "character or string", 0, argc, argv); + + return scheme_void; +} + +static Scheme_Object *sch_get(int argc, Scheme_Object **argv) +{ + /* Gets keyboard input */ + int c = getch(); + return scheme_make_character(c); +} + +static Scheme_Object *sch_move(int argc, Scheme_Object **argv) +{ + /* Move the output cursor */ + if (!SCHEME_INTP(argv[0])) + scheme_wrong_type("move", "exact integer", 0, argc, argv); + if (!SCHEME_INTP(argv[1])) + scheme_wrong_type("move", "exact integer", 1, argc, argv); + + move(SCHEME_INT_VAL(argv[0]), SCHEME_INT_VAL(argv[0])); + + return scheme_void; +} + +static Scheme_Object *sch_get_size(int argc, Scheme_Object **argv) +{ + /* Returns two values */ + int w, h; + Scheme_Object *a[2]; + + w = getmaxx(stdscr); + h = getmaxy(stdscr); + + a[0] = scheme_make_integer(w); + a[1] = scheme_make_integer(h); + return scheme_values(1, a); +} + +static Scheme_Object *sch_refresh(int argc, Scheme_Object **argv) +{ + refresh(); + return scheme_void; +} + +/**************************************************/ + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + scheme_add_global("clear", + scheme_make_prim_w_arity(sch_clear, + "clear", + 0, 0), + env); + scheme_add_global("put", + scheme_make_prim_w_arity(sch_put, + "put", + 1, 1), + env); + scheme_add_global("get", + scheme_make_prim_w_arity(sch_get, + "get", + 0, 0), + env); + scheme_add_global("move", + scheme_make_prim_w_arity(sch_move, + "move", + 2, 2), + env); + scheme_add_global("get-size", + scheme_make_prim_w_arity(sch_get_size, + "get-size", + 0, 0), + env); + + scheme_add_global("refresh", + scheme_make_prim_w_arity(sch_refresh, + "refresh", + 0, 0), + env); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + /* The first time we're loaded, initialize the screen: */ + initscr(); + cbreak(); + noecho(); + atexit(endwin); + + /* Then do the usual stuff: */ + return scheme_reload(env); +} diff --git a/collects/mzscheme/examples/fmod.c b/collects/mzscheme/examples/fmod.c new file mode 100644 index 00000000..c2500c40 --- /dev/null +++ b/collects/mzscheme/examples/fmod.c @@ -0,0 +1,59 @@ +/* + Extension that defines fmod, modulo on floating-point numbers. + The extension is equivalent to Scheme source of them form: + (define (fmod a b) ...) +*/ + +#include "escheme.h" +#include + +/**************************************************/ + +/* Every C implementation of a Scheme function takes argc and an array + of Scheme_Object* values for argv, and returns a Scheme_Object*: */ +static Scheme_Object *sch_fmod(int argc, Scheme_Object **argv) +{ + /* Because we'll use scheme_make_prim_w_arity, MzScheme will + have already checked that we're getting the right number of + arguments. */ + Scheme_Object *a = argv[0], *b = argv[1]; + double v; + + /* Make sure we got real numbers, and complain if not: */ + if (!SCHEME_REALP(a)) + scheme_wrong_type("fmod", "real number", 0, argc, argv); + /* 1st arg wrong ----^ */ + if (!SCHEME_REALP(b)) + scheme_wrong_type("fmod", "real number", 1, argc, argv); + /* 2nd arg wrong ----^ */ + + /* Convert the Scheme numbers to double-precision floating point + numbers, and compute fmod: */ + v = fmod(scheme_real_to_double(a), + scheme_real_to_double(b)); + + /* Return the result, packaging it as a Scheme value: */ + return scheme_make_double(v); +} + +/**************************************************/ + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + /* Package the C implementation of fmod into a Scheme procedure + value: */ + Scheme_Object *proc; + proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2); + /* Requires at least two args ------^ ^ */ + /* Accepts no more than two args ---| */ + + /* Define `fmod' as a global :*/ + scheme_add_global("fmod", proc, env); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + return scheme_reload(env); +} diff --git a/collects/mzscheme/examples/hello.c b/collects/mzscheme/examples/hello.c new file mode 100644 index 00000000..ccc8dc6d --- /dev/null +++ b/collects/mzscheme/examples/hello.c @@ -0,0 +1,24 @@ +/* + MzScheme extension example that returns the string "Hello, world!" + when loaded. + + Compile with: + mzc --cc hello.c + mzc --ld hello.so hello.o + And load with + (load-extension "hello.so") +*/ + +#include "escheme.h" + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + /* When the extension is loaded, return a Scheme string: */ + return scheme_make_string("Hello, world!"); +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + /* First load is same as every load: */ + return scheme_reload(env); +} diff --git a/collects/mzscheme/examples/helloprint.c b/collects/mzscheme/examples/helloprint.c new file mode 100644 index 00000000..a205dc33 --- /dev/null +++ b/collects/mzscheme/examples/helloprint.c @@ -0,0 +1,27 @@ +/* Like hello.c, but prints to the current output port and returns + (void). */ + +#include "escheme.h" + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + /* Make the string: */ + Scheme_Object *hw = scheme_make_string("Hello, World!\n"); + + /* Display it: */ + scheme_display(hw, scheme_get_param(scheme_config, MZCONFIG_OUTPUT_PORT)); + + /* Why not just + printf("Hello, World!\n"); + ? That would write to stdout, which may or may not be the same as + the current output port. But sometimes printf() is what you + want. */ + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + /* First load is same as every load: */ + return scheme_reload(env); +} diff --git a/collects/mzscheme/examples/makeadder.c b/collects/mzscheme/examples/makeadder.c new file mode 100644 index 00000000..deaab089 --- /dev/null +++ b/collects/mzscheme/examples/makeadder.c @@ -0,0 +1,59 @@ +/* + Defines make-adder: + (define (make-adder n) + (lambda (m) (+ m n))) + which illustrates closure-creation, looking up Scheme + definitions, and calling Scheme procedures from C. +*/ + +#include "escheme.h" + +/* The inner lambda, which must close over `n'. A closure function is + like a regular Scheme-procedure function, except that it takes an + extra argument containing the closure data. The closre data can be + any format that we want. */ +static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv) +{ + /* We only close over one value, so our closure data reprsentation + is just thaht value: */ + Scheme_Object *n = (Scheme_Object *)closure_data; + Scheme_Object *plus; + Scheme_Object *a[2]; + + plus = scheme_lookup_global(scheme_intern_symbol("+"), + scheme_get_env(scheme_config)); + + /* return the result of summing m and n: */ + a[0] = n; + a[1] = argv[0]; /* m */ + return _scheme_apply(plus, 2, a); + + /* Actually, that's not quite right. In the Scheme code, (+ m n) is + a tail call. The following would be better: + return _scheme_tail_apply(plus, 2, a); */ +} + +static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv) +{ + return scheme_make_closed_prim_w_arity(sch_inner, + argv[0], + "adder", + 1, 1); +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + scheme_add_global("make-adder", + scheme_make_prim_w_arity(sch_make_adder, + "make-adder", + 1, 1), + env); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + /* First load is same as every load: */ + return scheme_reload(env); +} diff --git a/collects/mzscheme/include/escheme.h b/collects/mzscheme/include/escheme.h new file mode 100644 index 00000000..554bdfa2 --- /dev/null +++ b/collects/mzscheme/include/escheme.h @@ -0,0 +1,44 @@ +/* + MzScheme + Copyright (c) 1995 Matthew Flatt + All rights reserved. + + Please see the full copyright in the documentation. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file should be included by MzScheme dynamically-loaded + extenstion files */ + +#ifndef E_SCHEME_H +#define E_SCHEME_H + +#define SCHEME_DIRECT_EMBEDDED 0 + +#include "scheme.h" + +#ifdef CODEFRAGMENT_DYNAMIC_LOAD +#pragma export on +#endif + +#ifdef __cplusplus +extern "C" +{ +#endif + +extern Scheme_Object *scheme_initialize(Scheme_Env *global_env); +extern Scheme_Object *scheme_reload(Scheme_Env *global_env); + +#ifdef __cplusplus +}; +#endif + +#ifdef CODEFRAGMENT_DYNAMIC_LOAD +#pragma export off +#endif + +#endif /* ! E_SCHEME_H */ + diff --git a/collects/mzscheme/include/ext.exp b/collects/mzscheme/include/ext.exp new file mode 100644 index 00000000..9183c921 --- /dev/null +++ b/collects/mzscheme/include/ext.exp @@ -0,0 +1,4 @@ +#! .. +scheme_initialize_internal +scheme_initialize +scheme_reload diff --git a/collects/mzscheme/include/mzscheme.exp b/collects/mzscheme/include/mzscheme.exp new file mode 100644 index 00000000..5c9669eb --- /dev/null +++ b/collects/mzscheme/include/mzscheme.exp @@ -0,0 +1,311 @@ +#!.. +scheme_init_jmpup_buf +scheme_setjmpup_relative +scheme_longjmpup +scheme_reset_jmpup_buf +scheme_clear_escape +scheme_make_config +scheme_branch_config +scheme_new_param +scheme_param_config +scheme_register_parameter +scheme_get_env +scheme_current_process +scheme_fuel_counter +scheme_thread +scheme_thread_w_manager +scheme_kill_thread +scheme_break_thread +scheme_process_block +scheme_swap_process +scheme_weak_suspend_thread +scheme_weak_resume_thread +scheme_block_until +scheme_in_main_thread +scheme_tls_allocate +scheme_tls_set +scheme_tls_get +scheme_make_manager +scheme_add_managed +scheme_remove_managed +scheme_close_managed +scheme_signal_error +scheme_raise_exn +scheme_warning +scheme_wrong_count +scheme_case_lambda_wrong_count +scheme_wrong_type +scheme_arg_mismatch +scheme_wrong_return_arity +scheme_unbound_global +scheme_dynamic_wind +scheme_make_type +scheme_install_type_reader +scheme_install_type_writer +scheme_eof +scheme_null +scheme_true +scheme_false +scheme_void +scheme_undefined +scheme_tail_call_waiting +scheme_multiple_values +scheme_eval +scheme_eval_multi +scheme_eval_compiled +scheme_eval_compiled_multi +_scheme_eval_compiled +_scheme_eval_compiled_multi +scheme_apply +scheme_apply_multi +scheme_apply_eb +scheme_apply_multi_eb +scheme_apply_to_list +scheme_eval_string +scheme_eval_string_multi +scheme_eval_string_all +_scheme_apply_known_closed_prim +_scheme_apply_known_closed_prim_multi +_scheme_apply_closed_prim +_scheme_apply_closed_prim_multi +scheme_values +scheme_check_one_value +scheme_tail_apply +scheme_tail_apply_no_copy +scheme_tail_apply_to_list +scheme_tail_eval_expr +scheme_set_tail_buffer_size +scheme_force_value +scheme_set_cont_mark +scheme_push_continuation_frame +scheme_pop_continuation_frame +scheme_temp_dec_mark_depth +scheme_temp_inc_mark_depth +scheme_current_continuation_marks +scheme_do_eval +GC_malloc +GC_malloc_atomic +GC_malloc_stubborn +GC_malloc_uncollectable +scheme_malloc_eternal +scheme_end_stubborn_change +scheme_calloc +scheme_strdup +scheme_strdup_eternal +scheme_malloc_fail_ok +scheme_weak_reference +scheme_weak_reference_indirect +scheme_unweak_reference +scheme_add_finalizer +scheme_add_finalizer_once +scheme_add_scheme_finalizer +scheme_add_scheme_finalizer_once +scheme_register_finalizer +scheme_remove_all_finalization +scheme_dont_gc_ptr +scheme_gc_ptr_ok +scheme_collect_garbage +scheme_hash_table +scheme_add_to_table +scheme_change_in_table +scheme_lookup_in_table +scheme_bucket_from_table +scheme_make_prim +scheme_make_noneternal_prim +scheme_make_closed_prim +scheme_make_prim_w_arity +scheme_make_folding_prim +scheme_make_noneternal_prim_w_arity +scheme_make_closed_prim_w_arity +scheme_make_folding_closed_prim +scheme_make_closure +scheme_make_pair +scheme_make_string +scheme_make_sized_string +scheme_make_sized_offset_string +scheme_make_immutable_sized_string +scheme_make_string_without_copying +scheme_alloc_string +scheme_append_string +scheme_make_vector +scheme_make_integer_value +scheme_make_integer_value_from_unsigned +scheme_make_double +scheme_make_char +scheme_make_promise +scheme_make_promise_from_thunk +scheme_make_sema +scheme_post_sema +scheme_wait_sema +scheme_char_constants +scheme_get_int_val +scheme_get_unsigned_int_val +scheme_real_to_double +scheme_get_proc_name +scheme_make_bignum +scheme_make_bignum_from_unsigned +scheme_bignum_to_double +scheme_bignum_from_double +scheme_bignum_to_string +scheme_read_bignum +scheme_bignum_normalize +scheme_double_to_int +scheme_make_rational +scheme_rational_to_double +scheme_rational_from_double +scheme_rational_normalize +scheme_rational_numerator +scheme_rational_denominator +scheme_make_complex +scheme_complex_normalize +scheme_complex_real_part +scheme_complex_imaginary_part +scheme_is_exact +scheme_is_inexact +scheme_expand +scheme_compile +scheme_make_promise_value +scheme_read +scheme_write +scheme_display +scheme_write_w_max +scheme_display_w_max +scheme_write_string +scheme_write_offset_string +scheme_write_to_string +scheme_display_to_string +scheme_write_to_string_w_max +scheme_display_to_string_w_max +scheme_debug_print +scheme_flush_output +scheme_format +scheme_printf +scheme_getc +scheme_peekc +scheme_ungetc +scheme_char_ready +scheme_peekc_is_ungetc +scheme_need_wakeup +scheme_get_chars +scheme_tell +scheme_output_tell +scheme_tell_line +scheme_count_lines +scheme_close_input_port +scheme_close_output_port +scheme_are_all_chars_ready +scheme_make_port_type +scheme_make_input_port +scheme_make_output_port +scheme_make_file_input_port +scheme_make_named_file_input_port +scheme_make_file_output_port +scheme_make_string_input_port +scheme_make_sized_string_input_port +scheme_make_string_output_port +scheme_get_string_output +scheme_get_sized_string_output +scheme_pipe +scheme_file_exists +scheme_directory_exists +scheme_expand_filename +scheme_os_getcwd +scheme_os_setcwd +scheme_getdrive +scheme_split_pathname +scheme_build_pathname +scheme_alloc_fdset_array +scheme_init_fdset_array +scheme_get_fdset +scheme_fdzero +scheme_fdset +scheme_fdclr +scheme_fdisset +scheme_add_fd_handle +scheme_add_fd_eventmask +scheme_return_eof_for_error +scheme_make_namespace +scheme_add_namespace_option +scheme_add_global +scheme_add_global_constant +scheme_add_global_keyword +scheme_remove_global +scheme_remove_global_constant +scheme_add_global_symbol +scheme_remove_global_symbol +scheme_add_global_constant_symbol +scheme_set_keyword +scheme_make_envunbox +scheme_lookup_global +scheme_global_bucket +scheme_set_global_bucket +scheme_intern_symbol +scheme_intern_exact_symbol +scheme_make_symbol +scheme_make_exact_symbol +scheme_symbol_name +scheme_symbol_name_and_size +scheme_symbol_val +scheme_make_struct_values +scheme_make_struct_names +scheme_make_struct_type +scheme_make_struct_instance +scheme_is_struct_instance +scheme_struct_ref +scheme_struct_set +scheme_is_subclass +scheme_is_implementation +scheme_is_interface_extension +scheme_is_a +scheme_get_class_name +scheme_get_interface_name +scheme_make_object +scheme_make_uninited_object +scheme_find_ivar +scheme_make_class +scheme_add_method +scheme_add_method_w_arity +scheme_made_class +scheme_class_to_interface +scheme_make_class_assembly +scheme_create_class +scheme_make_interface_assembly +scheme_create_interface +scheme_apply_generic_data +scheme_get_generic_data +scheme_invoke_unit +scheme_assemble_compound_unit +scheme_make_compound_unit +scheme_get_unit_name +scheme_eq +scheme_eqv +scheme_equal +scheme_build_list +scheme_list_length +scheme_proper_list_length +scheme_alloc_list +scheme_map_1 +scheme_car +scheme_cdr +scheme_cadr +scheme_caddr +scheme_vector_to_list +scheme_list_to_vector +scheme_append +scheme_box +scheme_unbox +scheme_set_box +scheme_make_weak_box +scheme_load +scheme_load_extension +scheme_register_extension_global +scheme_get_milliseconds +scheme_get_process_milliseconds +scheme_rep +scheme_banner +scheme_version +scheme_check_proc_arity +scheme_make_provided_string +scheme_make_args_string +scheme_no_dumps +scheme_system_library_subpath diff --git a/collects/mzscheme/include/scheme.h b/collects/mzscheme/include/scheme.h new file mode 100644 index 00000000..a28785e8 --- /dev/null +++ b/collects/mzscheme/include/scheme.h @@ -0,0 +1,1317 @@ +/* + MzScheme + Copyright (c) 1995-2000 Matthew Flatt + All rights reserved. + + Please see the full copyright in the documentation. + + Originally based on: + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#ifndef SCHEME_H +#define SCHEME_H + +/* The next line is used and set during installation: */ +#define INCLUDE_WITHOUT_PATHS + +/*========================================================================*/ +/* configuration */ +/*========================================================================*/ + +/* The configuration is not intended to be adjusted here. Instead, + modify sconfig.h. The code below simply draws a few more + configuration conclusions and a few extra macros based on those + settings. */ + +#ifdef INCLUDE_WITHOUT_PATHS +# include "sconfig.h" +#else +# include "../sconfig.h" +#endif + +#if defined(__MWERKS__) +# ifdef MZSCHEME_USES_NEAR_GLOBALS +# pragma far_data off +# endif +#endif + +#define AGRESSIVE_ZERO_FOR_GC +#define AGRESSIVE_ZERO_TB + +#if SGC_STD_DEBUGGING +# ifndef USE_SENORA_GC +# define USE_SENORA_GC +# endif +# define USE_MEMORY_TRACING +#endif + +#ifdef MZ_PRECISE_GC +# define MUST_REGISTER_GLOBALS +# define MZTAG_REQUIRED +# undef UNIX_IMAGE_DUMPS +#endif + +#ifdef USE_SENORA_GC +# define MUST_REGISTER_GLOBALS +# undef UNIX_IMAGE_DUMPS +#endif + +#ifdef USE_SINGLE_FLOATS +# define MZ_USE_SINGLE_FLOATS +#endif + +#ifdef MZ_PRECISE_GC +# define MZ_HASH_KEY_EX short keyex; +#else +# define MZ_HASH_KEY_EX /**/ +#endif + +#ifdef PALMOS_STUFF +# include +typedef long FILE; +# define _LINUX_TYPES_H /* Blocks types.h */ +#endif + +#ifndef SCHEME_DIRECT_EMBEDDED +# define SCHEME_DIRECT_EMBEDDED 1 +#endif + +#ifndef MSC_IZE +# define MSC_IZE(x) x +#endif + +#ifdef SIGSET_IS_SIGNAL +# define MZ_SIGSET(s, f) signal(s, f) +#else +# define MZ_SIGSET(s, f) sigset(s, f) +#endif + +#include +#include +#include +#include +#include +#include + +#ifdef PALMOS_STUFF +typedef jmpbuf jmp_buf[1]; +#endif + +#ifdef __cplusplus +extern "C" +{ +#endif + +/*========================================================================*/ +/* basic Scheme values */ +/*========================================================================*/ + +typedef short Scheme_Type; + +/* MzScheme values have the type `Scheme_Object *'. + The actual Scheme_Object structure only defines a few variants. + The important thing is that all `Scheme_Object *'s start with + a Scheme_Type field. + + The structures are defined here, instead of in a private header, so + that macros can provide quick access. Of course, don't access the + fields of these structures directly; use the macros instead. */ + +typedef struct Scheme_Object +{ + Scheme_Type type; /* Anything that starts with a type field + can be a Scheme_Object */ + + /* For precise GC, the keyex field is used for all object types to + store a hash key extension. The low bit is not used for this + purpose, though. For string and pair values in all variants of + MzScheme, the low bit is set to 1 to indicate that the string is + immutable. */ + short keyex; + + union + { + struct { char *string_val; int tag_val; } str_val; + struct { void *ptr1, *ptr2; } two_ptr_val; + struct { int int1; int int2; } two_int_val; + struct { void *ptr; int pint; } ptr_int_val; + struct { void *ptr; long pint; } ptr_long_val; + struct { struct Scheme_Object *car, *cdr; } pair_val; + struct { struct Scheme_Env *env; struct Scheme_Object *code; } closure_val; + struct { short len; short *vec; } svector_val; + } u; +} Scheme_Object; + +/* Scheme_Small_Object is used for several types of MzScheme values: */ +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + union { + char char_val; + Scheme_Object *ptr_value; + long int_val; + Scheme_Object *ptr_val; + } u; +} Scheme_Small_Object; + +/* A floating-point number: */ +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + double double_val; +} Scheme_Double; + +#ifdef MZ_USE_SINGLE_FLOATS +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + float float_val; +} Scheme_Float; +#endif + +typedef struct Scheme_Symbol { + Scheme_Type type; + MZ_HASH_KEY_EX + int len; + char s[1]; +} Scheme_Symbol; + +typedef struct Scheme_Vector { + Scheme_Type type; + MZ_HASH_KEY_EX + int size; + Scheme_Object *els[1]; +} Scheme_Vector; + + +/* This file defines all the built-in types */ +#ifdef INCLUDE_WITHOUT_PATHS +# include "stypes.h" +#else +# include "../src/stypes.h" +#endif + + +#define SAME_PTR(a, b) ((a) == (b)) +#define NOT_SAME_PTR(a, b) ((a) != (b)) + +#define SAME_OBJ(a, b) SAME_PTR(a, b) +#define NOT_SAME_OBJ(a, b) NOT_SAME_PTR(a, b) + +#define SAME_TYPE(a, b) ((Scheme_Type)(a) == (Scheme_Type)(b)) +#define NOT_SAME_TYPE(a, b) ((Scheme_Type)(a) != (Scheme_Type)(b)) + +# define SCHEME_TYPE(obj) (SCHEME_INTP(obj)?(Scheme_Type)scheme_integer_type:(obj)->type) +# define _SCHEME_TYPE(obj) ((obj)->type) /* unsafe version */ + +/*========================================================================*/ +/* basic Scheme predicates */ +/*========================================================================*/ + +#define SCHEME_CHARP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_type) + +#define SCHEME_INTP(obj) (((long)obj) & 0x1) +#define SCHEME_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_double_type) +#ifdef MZ_USE_SINGLE_FLOATS +# define SCHEME_FLTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_float_type) +# define SCHEME_FLOATP(obj) (SCHEME_FLTP(obj) || SCHEME_DBLP(obj)) +#else +# define SCHEME_FLTP SCHEME_DBLP +# define SCHEME_FLOATP SCHEME_DBLP +#endif +#define SCHEME_BIGNUMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_bignum_type) +#define SCHEME_RATIONALP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_rational_type) +#define SCHEME_COMPLEXP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_complex_izi_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type))) +#define SCHEME_COMPLEX_IZIP(obj) (SCHEME_TYPE(obj) == scheme_complex_izi_type) +#define SCHEME_EXACT_INTEGERP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type)) +#define SCHEME_EXACT_REALP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type) || (_SCHEME_TYPE(obj) == scheme_rational_type)) +#define SCHEME_REALP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_izi_type))) +#define SCHEME_NUMBERP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type))) + +#define SCHEME_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_string_type) +#define SCHEME_MUTABLE_STRINGP(obj) (SCHEME_STRINGP(obj) && !((obj)->keyex & 0x1)) +#define SCHEME_SYMBOLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_symbol_type) + +#define SCHEME_BOOLP(obj) (SAME_OBJ(obj, scheme_true) || SAME_OBJ(obj, scheme_false)) +#define SCHEME_FALSEP(obj) SAME_OBJ((obj), scheme_false) +#define SCHEME_TRUEP(obj) (!SCHEME_FALSEP(obj)) +#define SCHEME_EOFP(obj) SAME_OBJ((obj), scheme_eof) +#define SCHEME_VOIDP(obj) SAME_OBJ((obj), scheme_void) + +#define SCHEME_NULLP(obj) SAME_OBJ(obj, scheme_null) +#define SCHEME_PAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_pair_type) +#define SCHEME_MUTABLE_PAIRP(obj) (SCHEME_PAIRP(obj) && !((obj)->keyex & 0x1)) +#define SCHEME_LISTP(obj) (SCHEME_NULLP(obj) || SCHEME_PAIRP(obj)) + +#define SCHEME_BOXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_box_type) + +#define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type) + +#define SCHEME_VECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type) + +#define SCHEME_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) +#define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type) + +#define SCHEME_INPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type) +#define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type) + +#define SCHEME_PROMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_promise_type) + +#define SCHEME_PROCESSP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_process_type) +#define SCHEME_MANAGERP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_manager_type) +#define SCHEME_SEMAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type) + + +#define SCHEME_CONFIGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_config_type) +#define SCHEME_NAMESPACEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_namespace_type) +#define SCHEME_WEAKP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_weak_box_type) + + +/*========================================================================*/ +/* basic Scheme accessors */ +/*========================================================================*/ + +#define SCHEME_CHAR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.char_val) +#define SCHEME_INT_VAL(obj) (((long)(obj))>>1) +#define SCHEME_DBL_VAL(obj) (((Scheme_Double *)(obj))->double_val) +#ifdef MZ_USE_SINGLE_FLOATS +# define SCHEME_FLT_VAL(obj) (((Scheme_Float *)(obj))->float_val) +# define SCHEME_FLOAT_VAL(obj) (SCHEME_DBLP(obj) ? SCHEME_DBL_VAL(obj) : SCHEME_FLT_VAL(obj)) +#else +# define SCHEME_FLT_VAL SCHEME_DBL_VAL +# define SCHEME_FLOAT_VAL SCHEME_DBL_VAL +#endif + +#define SCHEME_STR_VAL(obj) ((obj)->u.str_val.string_val) +#define SCHEME_STRTAG_VAL(obj) ((obj)->u.str_val.tag_val) +#define SCHEME_STRLEN_VAL(obj) ((obj)->u.str_val.tag_val) +#define SCHEME_SYM_VAL(obj) (((Scheme_Symbol *)(obj))->s) +#define SCHEME_SYM_LEN(obj) (((Scheme_Symbol *)(obj))->len) + +#define SCHEME_SYMSTR_OFFSET(obj) ((unsigned long)SCHEME_SYM_VAL(obj)-(unsigned long)(obj)) + +#define SCHEME_BOX_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val) + +#define SCHEME_CAR(obj) ((obj)->u.pair_val.car) +#define SCHEME_CDR(obj) ((obj)->u.pair_val.cdr) + +#define SCHEME_CADR(obj) (SCHEME_CAR (SCHEME_CDR (obj))) +#define SCHEME_CAAR(obj) (SCHEME_CAR (SCHEME_CAR (obj))) +#define SCHEME_CDDR(obj) (SCHEME_CDR (SCHEME_CDR (obj))) + +#define SCHEME_VEC_SIZE(obj) (((Scheme_Vector *)(obj))->size) +#define SCHEME_VEC_ELS(obj) (((Scheme_Vector *)(obj))->els) +#define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj) + +#ifdef MZ_PRECISE_GC +# define SCHEME_ENVBOX_VAL(obj) SCHEME_PTR_VAL(obj) +#else +# define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj))) +#endif +#define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj) + +#define SCHEME_PTR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val) +#define SCHEME_PTR1_VAL(obj) ((obj)->u.two_ptr_val.ptr1) +#define SCHEME_PTR2_VAL(obj) ((obj)->u.two_ptr_val.ptr2) +#define SCHEME_IPTR_VAL(obj) ((obj)->u.ptr_int_val.ptr) +#define SCHEME_LPTR_VAL(obj) ((obj)->u.ptr_long_val.ptr) +#define SCHEME_INT1_VAL(obj) ((obj)->u.two_int_val.int1) +#define SCHEME_INT2_VAL(obj) ((obj)->u.two_int_val.int2) +#define SCHEME_PINT_VAL(obj) ((obj)->u.ptr_int_val.pint) +#define SCHEME_PLONG_VAL(obj) ((obj)->u.ptr_long_val.pint) + + +#define SCHEME_SET_STRING_IMMUTABLE(obj) (((obj)->keyex |= 0x1)) +#define SCHEME_SET_PAIR_IMMUTABLE(obj) (((obj)->keyex |= 0x1)) + +/*========================================================================*/ +/* fast basic Scheme constructor macros */ +/*========================================================================*/ + +#define scheme_make_integer(i) ((Scheme_Object *)((((long)i) << 1) | 0x1)) +#define scheme_make_character(ch) (scheme_char_constants[(unsigned char)(ch)]) + +/*========================================================================*/ +/* procedure values */ +/*========================================================================*/ + +/* Constants for flags in Scheme_Primitive_[Closed]_Proc. + Do not use them directly. */ +#define SCHEME_PRIM_IS_FOLDING 1 +#define SCHEME_PRIM_IS_PRIMITIVE 2 +#define SCHEME_PRIM_IS_STRUCT_PROC 4 +#define SCHEME_PRIM_IS_STRUCT_SETTER 8 +#define SCHEME_PRIM_IS_PARAMETER 16 +#define SCHEME_PRIM_IS_STRUCT_GETTER 32 +#define SCHEME_PRIM_IS_STRUCT_PRED 64 +#define SCHEME_PRIM_IS_STRUCT_CONSTR 128 +#define SCHEME_PRIM_IS_MULTI_RESULT 256 +#define SCHEME_PRIM_IS_GENERIC 512 +#define SCHEME_PRIM_IS_USER_PARAMETER 1024 + +typedef struct Scheme_Object * +(Scheme_Prim)(int argc, struct Scheme_Object *argv[]); + +typedef struct Scheme_Object * +(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]); + +typedef struct Scheme_Object * +(Scheme_Method_Prim)(struct Scheme_Object *o, + int argc, struct Scheme_Object *argv[]); + +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + short flags; /* keep flags at same place as in closed */ + Scheme_Prim *prim_val; + const char *name; + short mina, maxa; +} Scheme_Primitive_Proc; + +typedef struct { + Scheme_Primitive_Proc p; + short minr, maxr; +} Scheme_Prim_W_Result_Arity; + +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + short flags; /* keep flags at same place as in unclosed */ + Scheme_Closed_Prim *prim_val; + void *data; + const char *name; + short mina, maxa; /* mina == -2 => maxa is negated case count and + record is a Scheme_Closed_Case_Primitive_Proc */ +} Scheme_Closed_Primitive_Proc; + +typedef struct { + Scheme_Closed_Primitive_Proc p; + short minr, maxr; +} Scheme_Closed_Prim_W_Result_Arity; + +typedef struct { + Scheme_Closed_Primitive_Proc p; + short *cases; +} Scheme_Closed_Case_Primitive_Proc; + +#define _scheme_fill_prim_closure(rec, cfunc, dt, nm, amin, amax) \ + ((rec)->type = scheme_closed_prim_type, \ + (rec)->prim_val = cfunc, \ + (rec)->data = (void *)(dt), \ + (rec)->name = nm, \ + (rec)->mina = amin, \ + (rec)->maxa = amax, \ + rec) + +#define _scheme_fill_prim_case_closure(rec, cfunc, dt, nm, ccount, cses) \ + ((rec)->p.type = scheme_closed_prim_type, \ + (rec)->p.prim_val = cfunc, \ + (rec)->p.data = (void *)(dt), \ + (rec)->p.name = nm, \ + (rec)->p.mina = -2, \ + (rec)->p.maxa = -(ccount), \ + (rec)->cases = cses, \ + rec) + +#define SCHEME_PROCP(obj) (SCHEME_PRIMP(obj) || SCHEME_CLSD_PRIMP(obj) || SCHEME_CLOSUREP(obj) || SCHEME_CONTP(obj) || SCHEME_ECONTP(obj)) +#define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type) +#define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type) +#define SCHEME_CLSD_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type) +#define SCHEME_CONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_type) +#define SCHEME_ECONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type) +#define SCHEME_STRUCT_PROCP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)obj)->flags & SCHEME_PRIM_IS_STRUCT_PROC)) +#define SCHEME_GENERICP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)obj)->flags & SCHEME_PRIM_IS_GENERIC)) +#define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_linked_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type)) + +#define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val) +#define SCHEME_CLSD_PRIM(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->prim_val) +#define SCHEME_CLSD_PRIM_DATA(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->data) +#define SCHEME_CLOS_ENV(obj) ((obj)->u.closure_val.env) +#define SCHEME_CLOS_CODE(obj) ((obj)->u.closure_val.code) + +/* Type readers & writers for compiled code data */ +typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); +typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj); + + +/*========================================================================*/ +/* hash tables and environments */ +/*========================================================================*/ + +typedef struct Scheme_Bucket +{ + Scheme_Type type; + MZ_HASH_KEY_EX + void *val; + char *key; +} Scheme_Bucket; + +typedef struct Scheme_Hash_Table +{ + Scheme_Type type; + MZ_HASH_KEY_EX + int size, count, step; + Scheme_Bucket **buckets; + char has_constants, forever, weak; + void (*make_hash_indices)(void *v, long *h1, long *h2); + int (*compare)(void *v1, void *v2); +#ifdef MZ_REAL_THREADS + void *mutex; +#endif +} Scheme_Hash_Table; + +/* Hash tablekey types, used with scheme_hash_table */ +enum { + SCHEME_hash_string, + SCHEME_hash_ptr, + SCHEME_hash_weak_ptr +}; + +typedef struct Scheme_Env +{ + Scheme_Type type; /* scheme_namespace_type */ + MZ_HASH_KEY_EX + short no_keywords; /* only low-bit used; rest is hash key for precise gc */ + Scheme_Hash_Table *globals; + Scheme_Hash_Table *loaded_libraries; + struct Scheme_Comp_Env *init; /* initial compilation environment */ +} Scheme_Env; + +#define SCHEME_VAR_BUCKET(obj) ((Scheme_Bucket *)(obj)) + +/*========================================================================*/ +/* setjmpup (continuation) support */ +/*========================================================================*/ + +#ifdef USE_MZ_SETJMP +typedef long mz_jmp_buf[8]; +#else +# define mz_jmp_buf jmp_buf +#endif + +/* Like setjmp & longjmp, but you can jmp to a deeper stack position */ +/* Intialize a Scheme_Jumpup_Buf record before using it */ +typedef struct Scheme_Jumpup_Buf { + void *stack_from, *stack_copy; + long stack_size, stack_max_size; + struct Scheme_Jumpup_Buf *cont; + mz_jmp_buf buf; +#ifdef MZ_PRECISE_GC + void *gc_var_stack; + void *external_stack; +#endif +} Scheme_Jumpup_Buf; + +typedef struct Scheme_Continuation_Jump_State { + struct Scheme_Escaping_Cont *jumping_to_continuation; + union { + Scheme_Object **vals; + Scheme_Object *val; + } u; + short num_vals; + short is_kill; +} Scheme_Continuation_Jump_State; + +/* Although it's really an integer, it seems beneficial to declare the + mark position counter as a poiner, perhaps due to locality effects. */ +#define MZ_MARK_POS_TYPE char* +#define MZ_MARK_STACK_TYPE char* + +typedef struct Scheme_Cont_Frame_Data { + MZ_MARK_POS_TYPE cont_mark_pos; + MZ_MARK_STACK_TYPE cont_mark_stack; +} Scheme_Cont_Frame_Data; + +/*========================================================================*/ +/* threads */ +/*========================================================================*/ + +typedef void Scheme_Close_Manager_Client(Scheme_Object *o, void *data); +#ifdef MZ_PRECISE_GC +typedef struct Scheme_Object Scheme_Manager_Reference; +#else +typedef struct Scheme_Manager *Scheme_Manager_Reference; +#endif + +typedef struct Scheme_Manager Scheme_Manager; + +/* The Scheme_Process structure represents a MzScheme thread. */ + +typedef struct Scheme_Process { + Scheme_Type type; + MZ_HASH_KEY_EX + + struct Scheme_Process *next; + struct Scheme_Process *prev; + + mz_jmp_buf error_buf; + Scheme_Continuation_Jump_State cjs; + + struct Scheme_Config *config; + + Scheme_Object **runstack; + Scheme_Object **runstack_start; + long runstack_size; + struct Scheme_Saved_Stack *runstack_saved; + Scheme_Object **runstack_tmp_keep; + + MZ_MARK_POS_TYPE cont_mark_pos; /* depth of the continuation chain */ + MZ_MARK_STACK_TYPE cont_mark_stack; /* current mark stack position */ + struct Scheme_Cont_Mark **cont_mark_stack_segments; + int cont_mark_seg_count; + + long engine_weight; + + void *stack_start, *stack_end; + Scheme_Jumpup_Buf jmpup_buf; +#ifdef MZ_REAL_THREADS + void *thread; +# ifdef MZ_USE_LINUX_PTHREADS + int jump_on_signal; + mz_jmp_buf signal_buf; +# endif +#endif + + void *cc_start; + long *cc_ok; + long *ec_ok; + struct Scheme_Dynamic_Wind *dw; + + int running; + + struct Scheme_Process *nester, *nestee; + + float sleep_time; /* blocker has starting sleep time */ + int block_descriptor; + Scheme_Object *blocker; /* semaphore or port */ + int (*block_check)(Scheme_Object *blocker); + void (*block_needs_wakeup)(Scheme_Object *blocker, void *fds); + short ran_some; + + short overflow_set; + struct Scheme_Overflow *overflow; + mz_jmp_buf overflow_buf; + + struct Scheme_Comp_Env *current_local_env; + + /* These are used to lock in values during `read': */ + char quick_can_read_compiled; + char quick_can_read_pipe_quote; + char quick_can_read_box; + char quick_can_read_graph; + char quick_case_sens; + char quick_square_brackets_are_parens; + char quick_curly_braces_are_parens; + char quick_read_decimal_inexact; + + /* Used during `display' and `write': */ + char *print_buffer; + long print_position; + long print_allocated; + long print_maxlen; + Scheme_Object *print_port; + mz_jmp_buf print_escape; + + char exn_raised; + char error_invoked; + char err_val_str_invoked; + + Scheme_Object *(*overflow_k)(void); + Scheme_Object *overflow_reply; + Scheme_Jumpup_Buf overflow_cont; + + Scheme_Object **tail_buffer; + int tail_buffer_size; + + union { + struct { + Scheme_Object *wait_expr; + } eval; + struct { + Scheme_Object *tail_rator; + Scheme_Object **tail_rands; + int tail_num_rands; + } apply; + struct { + Scheme_Object **array; + int count; + } multiple; + struct { + void *p1, *p2, *p3, *p4; + long i1, i2, i3; + } k; + } ku; + + short suspend_break; + short external_break; + +#ifdef MZ_REAL_THREADS + Scheme_Object *done_sema; + long fuel_counter; +# define scheme_fuel_counter (scheme_current_process->fuel_counter) +# define scheme_stack_boundary ((unsigned long)scheme_current_process->stack_end) +#endif + + Scheme_Object *list_stack; + int list_stack_pos; + + Scheme_Object **vector_memory; + int vector_memory_size, vector_memory_count; + + long block_start_sleep; + + int eof_on_error; /* For port operations */ + +#ifdef AGRESSIVE_ZERO_TB + int tail_buffer_set; +#endif + + /* MzScheme client can use: */ + void (*on_kill)(struct Scheme_Process *p); + void *kill_data; + + /* MzScheme use only: */ + void (*private_on_kill)(struct Scheme_Process *p); + void *private_kill_data; + + void **user_tls; + int user_tls_size; + + struct Scheme_Process_Manager_Hop *mr_hop; + Scheme_Manager_Reference *mref; +} Scheme_Process; + +#if !SCHEME_DIRECT_EMBEDDED +# ifdef MZ_REAL_THREADS +# define scheme_current_process (scheme_get_current_process()) +# else +# ifdef LINK_EXTENSIONS_BY_TABLE +# define scheme_current_process (*scheme_current_process_ptr) +# endif +# endif +#endif + +/*========================================================================*/ +/* parameters */ +/*========================================================================*/ + +enum { + MZCONFIG_ENV, + MZCONFIG_INPUT_PORT, + MZCONFIG_OUTPUT_PORT, + MZCONFIG_ERROR_PORT, + + MZCONFIG_ENABLE_BREAK, + + MZCONFIG_ERROR_DISPLAY_HANDLER, + MZCONFIG_ERROR_PRINT_VALUE_HANDLER, + + MZCONFIG_EXIT_HANDLER, + + MZCONFIG_EXN_HANDLER, + MZCONFIG_INIT_EXN_HANDLER, + + MZCONFIG_EVAL_HANDLER, + MZCONFIG_LOAD_HANDLER, + + MZCONFIG_PRINT_HANDLER, + MZCONFIG_PROMPT_READ_HANDLER, + + MZCONFIG_CAN_READ_GRAPH, + MZCONFIG_CAN_READ_COMPILED, + MZCONFIG_CAN_READ_BOX, + MZCONFIG_CAN_READ_PIPE_QUOTE, + MZCONFIG_READ_DECIMAL_INEXACT, + + MZCONFIG_PRINT_GRAPH, + MZCONFIG_PRINT_STRUCT, + MZCONFIG_PRINT_BOX, + MZCONFIG_PRINT_VEC_SHORTHAND, + + MZCONFIG_CASE_SENS, + MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, + MZCONFIG_CURLY_BRACES_ARE_PARENS, + + MZCONFIG_ERROR_PRINT_WIDTH, + + MZCONFIG_ERROR_ESCAPE_HANDLER, + + MZCONFIG_ALLOW_SET_UNDEFINED, + MZCONFIG_COND_AUTO_ELSE, + + MZCONFIG_MANAGER, + + MZCONFIG_USE_COMPILED_KIND, + + MZCONFIG_LOAD_DIRECTORY, + + MZCONFIG_COLLECTION_PATHS, + + MZCONFIG_PORT_PRINT_HANDLER, + + MZCONFIG_REQUIRE_COLLECTION, + + MZCONFIG_LOAD_EXTENSION_HANDLER, + + MZCONFIG_CURRENT_DIRECTORY, + + MZCONFIG_RANDOM_STATE, + + __MZCONFIG_BUILTIN_COUNT__ +}; + + +typedef struct Scheme_Config { + Scheme_Type type; + MZ_HASH_KEY_EX + Scheme_Hash_Table *extensions; + Scheme_Object *configs[1]; +} Scheme_Config; + +#define scheme_set_param(c, pos, o) ((c)->configs[pos] = (o)) +#define scheme_get_param(c, pos) ((c)->configs[pos]) + +/*========================================================================*/ +/* ports */ +/*========================================================================*/ + +typedef struct Scheme_Input_Port +{ + Scheme_Type type; + MZ_HASH_KEY_EX + short closed; + Scheme_Object *sub_type; + Scheme_Manager_Reference *mref; + void *port_data; + int (*getc_fun) (struct Scheme_Input_Port *port); + int (*peekc_fun) (struct Scheme_Input_Port *port); + int (*char_ready_fun) (struct Scheme_Input_Port *port); + void (*close_fun) (struct Scheme_Input_Port *port); + void (*need_wakeup_fun)(struct Scheme_Input_Port *, void *); + Scheme_Object *read_handler; + char *name; + unsigned char *ungotten; + int ungotten_count, ungotten_allocated; + long position, lineNumber, charsSinceNewline; + int count_lines; +#ifdef MZ_REAL_THREADS + Scheme_Object *sema; +#endif +} Scheme_Input_Port; + +typedef struct Scheme_Output_Port +{ + Scheme_Type type; + MZ_HASH_KEY_EX + short closed; + Scheme_Object *sub_type; + Scheme_Manager_Reference *mref; + void *port_data; + void (*write_string_fun)(char *str, long d, long len, struct Scheme_Output_Port *); + void (*close_fun) (struct Scheme_Output_Port *); + long pos; + Scheme_Object *display_handler; + Scheme_Object *write_handler; + Scheme_Object *print_handler; +#ifdef MZ_REAL_THREADS + Scheme_Object *sema; +#endif +} Scheme_Output_Port; + +#define SCHEME_INPORT_VAL(obj) (((Scheme_Input_Port *)(obj))->port_data) +#define SCHEME_OUTPORT_VAL(obj) (((Scheme_Output_Port *)(obj))->port_data) +#define SCHEME_IPORT_NAME(obj) (((Scheme_Input_Port *)obj)->name) + +/*========================================================================*/ +/* classes and units */ +/*========================================================================*/ + +typedef struct { + Scheme_Type type; + MZ_HASH_KEY_EX + struct Scheme_Object *sclass; + /* The following fields are only here for instances of classes + created with scheme_make_class(): */ + void *primdata; + short primflag; + short inited; +} Scheme_Class_Object; + +#define SCHEME_OBJP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_object_type) +#define SCHEME_CLASSP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_class_type) +#define SCHEME_INTERFACEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_interface_type) +#define SCHEME_DIVARP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_delayed_ivar_type) +#define SCHEME_GENDATAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_generic_data_type) +#define SCHEME_UNITP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_unit_type) + +#define SCHEME_OBJ_CLASS(obj) ((Scheme_Object *)((Scheme_Class_Object *)(obj))->sclass) +#define SCHEME_OBJ_DATA(obj) (((Scheme_Class_Object *)(obj))->primdata) +#define SCHEME_OBJ_FLAG(obj) (((Scheme_Class_Object *)(obj))->primflag) + +/*========================================================================*/ +/* units */ +/*========================================================================*/ + +typedef struct Scheme_Unit { + Scheme_Type type; /* scheme_unit_type */ + MZ_HASH_KEY_EX + short num_imports; /* num expected import args */ + short num_exports; /* num exported vars */ + Scheme_Object **exports; /* names of exported */ + Scheme_Object **export_debug_names; /* internal names; NULL => no debugging */ + Scheme_Object *(*init_func)(Scheme_Object **boxes, Scheme_Object **anchors, + struct Scheme_Unit *m, + void *debug_request); + Scheme_Object *data; +} Scheme_Unit; + +typedef void Scheme_Instance_Init_Proc(Scheme_Object **init_boxes, + Scheme_Object **extract_boxes, + Scheme_Object *super_init, + int argc, + Scheme_Object **argv, + Scheme_Object *instance, + void *data); + +#define SCHEME_UNITP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_unit_type) + +/*========================================================================*/ +/* exceptions */ +/*========================================================================*/ + +/* This file includes the MZEXN constants */ +#ifdef INCLUDE_WITHOUT_PATHS +# include "schexn.h" +#else +# include "../src/schexn.h" +#endif + +/*========================================================================*/ +/* evaluation */ +/*========================================================================*/ + +/* Exploit the fact that these should never be dereferenced: */ +#ifndef FIRST_TWO_BYTES_ARE_LEGAL_ADDRESSES +# define MZ_EVAL_WAITING_CONSTANT ((Scheme_Object *)0x2) +# define MZ_APPLY_WAITING_CONSTANT ((Scheme_Object *)0x4) +# define MZ_MULTIPLE_VALUES_CONSTANT ((Scheme_Object *)0x6) +#endif + +#ifdef MZ_EVAL_WAITING_CONSTANT +# define SCHEME_EVAL_WAITING MZ_EVAL_WAITING_CONSTANT +# define SCHEME_TAIL_CALL_WAITING MZ_APPLY_WAITING_CONSTANT +# define SCHEME_MULTIPLE_VALUES MZ_MULTIPLE_VALUES_CONSTANT +#else +# define SCHEME_TAIL_CALL_WAITING scheme_tail_call_waiting +# define SCHEME_EVAL_WAITING scheme_eval_waiting +# define SCHEME_MULTIPLE_VALUES scheme_multiple_values +#endif + +#define SCHEME_ASSERT(expr,msg) ((expr) ? 1 : (scheme_signal_error(msg), 0)) + +#define scheme_eval_wait_expr (scheme_current_process->ku.eval.wait_expr) +#define scheme_tail_rator (scheme_current_process->ku.apply.tail_rator) +#define scheme_tail_num_rands (scheme_current_process->ku.apply.tail_num_rands) +#define scheme_tail_rands (scheme_current_process->ku.apply.tail_rands) +#define scheme_overflow_k (scheme_current_process->overflow_k) +#define scheme_overflow_reply (scheme_current_process->overflow_reply) +#define scheme_overflow_cont (scheme_current_process->overflow_cont) + +#define scheme_error_buf (scheme_current_process->error_buf) +#define scheme_jumping_to_continuation (scheme_current_process->cjs.jumping_to_continuation) +#define scheme_config (scheme_current_process->config) + +#define scheme_multiple_count (scheme_current_process->ku.multiple.count) +#define scheme_multiple_array (scheme_current_process->ku.multiple.array) + +#define scheme_setjmpup(b, base, s) scheme_setjmpup_relative(b, base, s, NULL) + +#ifdef MZ_REAL_THREADS +#define scheme_do_eval(r,n,e,f) scheme_do_eval_w_process(r,n,e,f,scheme_current_process) +#else +#define scheme_do_eval_w_process(r,n,e,f,p) scheme_do_eval(r,n,e,f) +#endif +#ifdef MZ_REAL_THREADS +#define scheme_apply(r,n,a) scheme_apply_wp(r,n,a,scheme_current_process) +#define scheme_apply_multi(r,n,a) scheme_apply_multi_wp(r,n,a,scheme_current_process) +#define scheme_apply_eb(r,n,a) scheme_apply_eb_wp(r,n,a,scheme_current_process) +#define scheme_apply_multi_eb(r,n,a) scheme_apply_multi_eb_wp(r,n,a,scheme_current_process) +#else +#define scheme_apply_wp(r,n,a,p) scheme_apply(r,n,a) +#define scheme_apply_multi_wp(r,n,a,p) scheme_apply_multi(r,n,a) +#define scheme_apply_eb_wp(r,n,a,p) scheme_apply_eb(r,n,a) +#define scheme_apply_multi_eb_wp(r,n,a,p) scheme_apply_multi_eb(r,n,a) +#endif + +#define _scheme_apply(r,n,rs) scheme_do_eval(r,n,rs,1) +#define _scheme_apply_multi(r,n,rs) scheme_do_eval(r,n,rs,-1) +#define _scheme_apply_wp(r,n,rs,p) scheme_do_eval_w_process(r,n,rs,1,p) +#define _scheme_apply_multi_wp(r,n,rs,p) scheme_do_eval_w_process(r,n,rs,-1,p) +#define _scheme_tail_apply scheme_tail_apply +#define _scheme_tail_apply_wp scheme_tail_apply_wp + +#define _scheme_tail_eval scheme_tail_eval +#define _scheme_tail_eval_wp scheme_tail_eval_wp + +#define _scheme_direct_apply_primitive_multi(prim, argc, argv) \ + (((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv)) +#define _scheme_direct_apply_primitive(prim, argc, argv) \ + scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv)) +#define _scheme_direct_apply_closed_primitive_multi(prim, argc, argv) \ + (((Scheme_Closed_Primitive_Proc *)prim)->prim_val(((Scheme_Closed_Primitive_Proc *)prim)->data, argc, argv)) +#define _scheme_direct_apply_closed_primitive(prim, argc, argv) \ + scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv)) + +#define _scheme_force_value(v) ((v == SCHEME_TAIL_CALL_WAITING) ? scheme_force_value(v) : v) + +#ifdef AGRESSIVE_ZERO_TB +#define scheme_tail_apply_buffer_wp(n, p) ((p)->tail_buffer_set = n, (p)->tail_buffer) +#else +#define scheme_tail_apply_buffer_wp(n, p) ((p)->tail_buffer) +#endif +#define scheme_tail_apply_buffer(n) scheme_tail_apply_buffer_wp(n, scheme_current_process) + +#define _scheme_tail_apply_no_copy_wp_tcw(f, n, args, p, tcw) (p->ku.apply.tail_rator = f, p->ku.apply.tail_rands = args, p->ku.apply.tail_num_rands = n, tcw) +#define _scheme_tail_apply_no_copy_wp(f, n, args, p) _scheme_tail_apply_no_copy_wp_tcw(f, n, args, p, SCHEME_TAIL_CALL_WAITING) +#define _scheme_tail_apply_no_copy(f, n, args) _scheme_tail_apply_no_copy_wp(f, n, args, scheme_current_process) + +#ifndef MZ_REAL_THREADS +# define scheme_process_block_w_process(t,p) scheme_process_block(t) +#else +# define scheme_process_block(t) scheme_process_block_w_process(t,scheme_current_process) +#endif + +#ifndef MZ_REAL_THREADS +# if !SCHEME_DIRECT_EMBEDDED +# ifdef LINK_EXTENSIONS_BY_TABLE +# define scheme_fuel_counter (*scheme_fuel_counter_ptr) +# endif +# else +extern int scheme_fuel_counter; +# endif +#endif + +#ifdef MZ_REAL_THREADS +# define _scheme_check_for_break_wp(penalty, p) \ + { if (((p)->fuel_counter -= penalty) <= 0) scheme_process_block_w_process(0, p); } +#else +# define _scheme_check_for_break_wp(penalty, p) \ + { if ((scheme_fuel_counter -= penalty) <= 0) scheme_process_block_w_process(0, p); } +#endif +#define _scheme_check_for_break(penalty) _scheme_check_for_break_wp(penalty, scheme_current_process) + +#if SCHEME_DIRECT_EMBEDDED +extern Scheme_Object *scheme_eval_waiting; +#define scheme_tail_eval(obj) \ + (scheme_eval_wait_expr = obj, SCHEME_EVAL_WAITING) +#endif + +#define scheme_break_waiting(p) (p->external_break) + +#ifndef USE_MZ_SETJMP +# ifdef JMP_BUF_IS_JMPBUF +# define scheme_longjmp(b, v) longjmp(&b, v) +# define scheme_setjmp(b) setjmp(&b) +# else +# define scheme_longjmp(b, v) longjmp(b, v) +# define scheme_setjmp(b) setjmp(b) +# endif +#endif + +/*========================================================================*/ +/* memory management macros */ +/*========================================================================*/ + +/* Allocation */ +#define scheme_alloc_object() \ + ((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Object))) +#define scheme_alloc_small_object() \ + ((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Small_Object))) +#define scheme_alloc_stubborn_object() \ + ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Object))) +#define scheme_alloc_stubborn_small_object() \ + ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Small_Object))) +#define scheme_alloc_eternal_object() \ + ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Object))) +#define scheme_alloc_eternal_small_object() \ + ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Small_Object))) + +#ifdef SCHEME_NO_GC +void *scheme_malloc(size_t size); +# define scheme_malloc_atomic scheme_malloc +# define scheme_malloc_stubborn scheme_malloc +# define scheme_malloc_uncollectable scheme_malloc +#else +# define scheme_malloc GC_malloc +# define scheme_malloc_atomic GC_malloc_atomic +# ifdef MZ_PRECISE_GC +# define scheme_malloc_stubborn scheme_malloc +# else +# define scheme_malloc_stubborn GC_malloc_stubborn +# endif +# define scheme_malloc_uncollectable GC_malloc_uncollectable +#endif + +#ifdef USE_MEMORY_TRACING +# define USE_TAGGED_ALLOCATION +# define MEMORY_COUNTING_ON +#endif + +#ifdef MZ_PRECISE_GC +# ifdef INCLUDE_WITHOUT_PATHS +# include "gc2.h" +# else +# include "../gc2/gc2.h" +# endif +# define scheme_malloc_tagged GC_malloc_one_tagged +# define scheme_malloc_array_tagged GC_malloc_array_tagged +# define scheme_malloc_atomic_tagged GC_malloc_atomic_tagged +# define scheme_malloc_stubborn_tagged GC_malloc_one_tagged +# define scheme_malloc_eternal_tagged GC_malloc_atomic_uncollectable +# define scheme_malloc_uncollectable_tagged >> error << +# define scheme_malloc_envunbox GC_malloc_one_tagged +# define scheme_malloc_weak GC_malloc_weak +# define scheme_malloc_weak_tagged GC_malloc_one_weak_tagged +# define scheme_malloc_allow_interior GC_malloc_allow_interior +#else +# ifdef USE_TAGGED_ALLOCATION +extern void *scheme_malloc_tagged(size_t); +# define scheme_malloc_array_tagged scheme_malloc +extern void *scheme_malloc_atomic_tagged(size_t); +extern void *scheme_malloc_stubborn_tagged(size_t); +extern void *scheme_malloc_eternal_tagged(size_t); +extern void *scheme_malloc_uncollectable_tagged(size_t); +extern void *scheme_malloc_envunbox(size_t); +# else +# define scheme_malloc_tagged scheme_malloc +# define scheme_malloc_array_tagged scheme_malloc +# define scheme_malloc_atomic_tagged scheme_malloc_atomic +# define scheme_malloc_stubborn_tagged scheme_malloc_stubborn +# define scheme_malloc_eternal_tagged scheme_malloc_eternal +# define scheme_malloc_uncollectable_tagged scheme_malloc_uncollectable +# define scheme_malloc_envunbox scheme_malloc +# endif +# define scheme_malloc_allow_interior scheme_malloc +#endif + + +#ifdef MZ_PRECISE_GC +# define MZ_CWVR(x) (GC_variable_stack = __gc_var_stack__, x) +# define MZ_DECL_VAR_REG(size) void *__gc_var_stack__[size+2]; \ + __gc_var_stack__[0] = GC_variable_stack; \ + __gc_var_stack__[1] = (void *)size; +# define MZ_VAR_REG(x, v) (__gc_var_stack__[x+2] = (void *)&(v)) +# define MZ_ARRAY_VAR_REG(x, v, l) (__gc_var_stack__[x+2] = (void *)0, \ + __gc_var_stack__[x+3] = (void *)&(v), \ + __gc_var_stack__[x+4] = (void *)l) +#else +# define MZ_CWVR(x) x +# define MZ_DECL_VAR_REG(size) /* empty */ +# define MZ_VAR_REG(x, v) /* empty */ +# define MZ_ARRAY_VAR_REG(x, v, l) /* empty */ +#endif + +/*========================================================================*/ +/* embedding configuration and hooks */ +/*========================================================================*/ + +#if SCHEME_DIRECT_EMBEDDED + +#if defined(_IBMR2) +extern long scheme_stackbottom; +#endif + +extern int scheme_defining_primitives; + +/* These flags must be set before MzScheme is started: */ +extern int scheme_case_sensitive; /* Defaults to 0 */ +extern int scheme_no_keywords; /* Defaults to 0 */ +extern int scheme_allow_set_undefined; /* Defaults to 0 */ +extern int scheme_escape_continuations_only; /* Defaults to 0 */ +extern int scheme_allow_cond_auto_else; /* Defaults to 1 */ +extern int scheme_square_brackets_are_parens; /* Defaults to 1 */ +extern int scheme_curly_braces_are_parens; /* Defaults to 1 */ +extern int scheme_hash_percent_syntax_only; /* Defaults to 0 */ +#ifdef GC_MIGHT_USE_REGISTERED_STATICS +extern int GC_use_registered_statics; /* Defaults to 0 */ +#endif +extern int scheme_binary_mode_stdio; /* Windows-MacOS-specific. Defaults to 0 */ + +#ifdef MZ_REAL_THREADS +Scheme_Process *scheme_get_current_process(); +# define scheme_current_process (SCHEME_GET_CURRENT_PROCESS()) +#else +extern Scheme_Process *scheme_current_process; +#endif +extern Scheme_Process *scheme_first_process; + +/* Set these global hooks (optionally): */ +extern void (*scheme_exit)(int v); +extern void (*scheme_console_printf)(char *str, ...); +extern void (*scheme_console_output)(char *str, long len); +extern void (*scheme_sleep)(float seconds, void *fds); +extern void (*scheme_notify_multithread)(int on); +extern void (*scheme_wakeup_on_input)(void *fds); +extern int (*scheme_check_for_break)(void); +#ifdef MZ_PRECISE_GC +extern void *(*scheme_get_external_stack_val)(void); +extern void (*scheme_set_external_stack_val)(void *); +#endif +#ifdef USE_WIN32_THREADS +extern void (*scheme_suspend_main_thread)(void); +int scheme_set_in_main_thread(void); +void scheme_restore_nonmain_thread(void); +#endif +#ifdef MAC_FILE_SYSTEM +extern long scheme_creator_id; +#endif +#ifdef MACINTOSH_EVENTS +extern void (*scheme_handle_aewait_event)(EventRecord *e); +#endif + +extern Scheme_Object *(*scheme_make_stdin)(void); +extern Scheme_Object *(*scheme_make_stdout)(void); +extern Scheme_Object *(*scheme_make_stderr)(void); + +void scheme_set_banner(char *s); +Scheme_Object *scheme_set_exec_cmd(char *s); + +/* Initialization */ +Scheme_Env *scheme_basic_env(void); + +#ifdef USE_MSVC_MD_LIBRARY +void GC_pre_init(void); +#endif + +void scheme_check_threads(void); +void scheme_wake_up(void); + +/* image dump enabling startup: */ +int scheme_image_main(int argc, char **argv); +extern int (*scheme_actual_main)(int argc, char **argv); + +/* GC registration: */ +void scheme_register_static(void *ptr, long size); +#if defined(MUST_REGISTER_GLOBALS) || defined(GC_MIGHT_USE_REGISTERED_STATICS) +# define MZ_REGISTER_STATIC(x) scheme_register_static((void *)&x, sizeof(x)) +#else +# define MZ_REGISTER_STATIC(x) /* empty */ +#endif + +void scheme_setup_forced_exit(void); + +void scheme_start_atomic(void); +void scheme_end_atomic(void); + +#endif /* SCHEME_DIRECT_EMBEDDED */ + +/*========================================================================*/ +/* FFI functions */ +/*========================================================================*/ + +/* If MzScheme is being empbedded, then we just include the + prototypes. Otherwise, we may include a function-table definition + instead, plus macros that map the usual name to table lookups. */ + +#if SCHEME_DIRECT_EMBEDDED + +/* All functions & global constants prototyped here */ +#ifdef INCLUDE_WITHOUT_PATHS +# include "schemef.h" +#else +# include "../src/schemef.h" +#endif + +#else + +#ifdef LINK_EXTENSIONS_BY_TABLE +/* Constants and function prototypes as function pointers in a struct: */ +# ifdef INCLUDE_WITHOUT_PATHS +# include "schemex.h" +# else +# include "../src/schemex.h" +# endif + +extern Scheme_Extension_Table *scheme_extension_table; + +/* Macro mapping names to record access */ +# ifdef INCLUDE_WITHOUT_PATHS +# include "schemexm.h" +# else +# include "../src/schemexm.h" +# endif + +#else + +/* Not LINK_EXTENSIONS_BY_TABLE */ +# ifdef INCLUDE_WITHOUT_PATHS +# include "schemef.h" +# else +# include "../src/schemef.h" +# endif + +#endif + +#endif + +/*========================================================================*/ +/* misc flags */ +/*========================================================================*/ + +/* For use with scheme_symbol_name_and_size: */ +#define SNF_FOR_TS 0x1 +#define SNF_PIPE_QUOTE 0x2 +#define SNF_NO_PIPE_QUOTE 0x4 + +/* For use with scheme_make_struct_values et al.: */ +#define SCHEME_STRUCT_NO_TYPE 0x01 +#define SCHEME_STRUCT_NO_CONSTR 0x02 +#define SCHEME_STRUCT_NO_PRED 0x04 +#define SCHEME_STRUCT_NO_GET 0x08 +#define SCHEME_STRUCT_NO_SET 0x10 + +/*========================================================================*/ +/* file descriptors */ +/*========================================================================*/ + +#if defined(DETECT_WIN32_CONSOLE_STDIN) || defined(WINDOWS_PROCESSES) +# ifndef NO_STDIO_THREADS +# define USE_FAR_MZ_FDCALLS +# endif +#endif +#ifdef USE_DYNAMIC_FDSET_SIZE +# define USE_FAR_MZ_FDCALLS +#endif +#ifdef USE_BEOS_PORT_THREADS +# define USE_FAR_MZ_FDCALLS +#endif + +#ifdef USE_FAR_MZ_FDCALLS +# define MZ_GET_FDSET(p, n) scheme_get_fdset(p, n) +# define MZ_FD_ZERO(p) scheme_fdzero(p) +# define MZ_FD_SET(n, p) scheme_fdset(p, n) +# define MZ_FD_CLR(n, p) scheme_fdclr(p, n) +# define MZ_FD_ISSET(n, p) scheme_fdisset(p, n) +#else +# define MZ_GET_FDSET(p, n) ((void *)(((fd_set *)p) + n)) +# define MZ_FD_ZERO(p) FD_ZERO(p) +# define MZ_FD_SET(n, p) FD_SET(n, p) +# define MZ_FD_CLR(n, p) FD_CLR(n, p) +# define MZ_FD_ISSET(n, p) FD_ISSET(n, p) +#endif + +#ifdef __cplusplus +}; +#endif + +#if defined(__MWERKS__) +# ifdef MZSCHEME_USES_NEAR_GLOBALS +# pragma far_data reset +# endif +#endif + +#endif /* ! SCHEME_H */ + diff --git a/collects/mzscheme/include/schemef.h b/collects/mzscheme/include/schemef.h new file mode 100644 index 00000000..65a9fe13 --- /dev/null +++ b/collects/mzscheme/include/schemef.h @@ -0,0 +1,677 @@ +/* + MzScheme + Copyright (c) 1995-2000 Matthew Flatt + All rights reserved. + + Please see the full copyright in the documentation. + + Originally based on: + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* MzScheme function prototypes */ +/* Macros generally shouldn't go in this file; it is used both to + prototype functions, and as a parsing source for + declaring scheme_extension_table */ + +/* The scheme_extension_table "parser" is picky; don't leave a space + between a function name and it's opening parameter parenthesis. */ + +/* After this START tag, all comments should start & end on same line */ + +/* START */ + +/*========================================================================*/ +/* setjmpup (continuations) */ +/*========================================================================*/ + +void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b); +int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base, + void *start, Scheme_Jumpup_Buf *cont); +void scheme_longjmpup(Scheme_Jumpup_Buf *b); +void scheme_reset_jmpup_buf(Scheme_Jumpup_Buf *b); + +#ifdef USE_MZ_SETJMP +int scheme_setjmp(mz_jmp_buf b); +void scheme_longjmp(mz_jmp_buf b, int v); +#endif + +void scheme_clear_escape(void); + +/*========================================================================*/ +/* parameters */ +/*========================================================================*/ + +Scheme_Object *scheme_make_config(Scheme_Config *base); +Scheme_Object *scheme_branch_config(void); +int scheme_new_param(void); + +Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + Scheme_Prim *check, char *expected, + int isbool); +Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which); +Scheme_Env *scheme_get_env(Scheme_Config *config); + +/*========================================================================*/ +/* threads */ +/*========================================================================*/ + +#ifdef MZ_REAL_THREADS +Scheme_Process *scheme_get_current_process(); +#else +#ifndef LINK_EXTENSIONS_BY_TABLE +extern Scheme_Process *scheme_current_process; +extern int scheme_fuel_counter; +#else +extern Scheme_Process **scheme_current_process_ptr; +extern int *scheme_fuel_counter_ptr; +#endif +#endif + +#ifndef NO_SCHEME_THREADS +Scheme_Object *scheme_thread(Scheme_Object *thunk, Scheme_Config *config); +Scheme_Object *scheme_thread_w_manager(Scheme_Object *thunk, Scheme_Config *config, + Scheme_Manager *mgr); +void scheme_kill_thread(Scheme_Process *p); +#endif +void scheme_break_thread(Scheme_Process *p); + +#ifndef MZ_REAL_THREADS +void scheme_process_block(float sleep_time); +void scheme_swap_process(Scheme_Process *process); +#else +void scheme_process_block_w_process(float sleep_time, Scheme_Process *p); +#endif + +void scheme_weak_suspend_thread(Scheme_Process *p); +void scheme_weak_resume_thread(Scheme_Process *p); + +int scheme_block_until(int (*f)(Scheme_Object *), void (*fdfd)(Scheme_Object *, void *), void *, float); + +int scheme_in_main_thread(void); + +int scheme_tls_allocate(); +void scheme_tls_set(int pos, void *v); +void *scheme_tls_get(int pos); + +Scheme_Manager *scheme_make_manager(Scheme_Manager *); +Scheme_Manager_Reference *scheme_add_managed(Scheme_Manager *m, Scheme_Object *o, + Scheme_Close_Manager_Client *f, void *data, + int strong); +void scheme_remove_managed(Scheme_Manager_Reference *m, Scheme_Object *o); +void scheme_close_managed(Scheme_Manager *m); + +/*========================================================================*/ +/* error handling */ +/*========================================================================*/ + +void scheme_signal_error(char *msg, ...); +void scheme_raise_exn(int exnid, ...); +void scheme_warning(char *msg, ...); + +void scheme_wrong_count(const char *name, int minc, int maxc, int argc, + Scheme_Object **argv); +void scheme_case_lambda_wrong_count(const char *name, int argc, + Scheme_Object **argv, int count, ...); +void scheme_wrong_type(const char *name, const char *expected, + int which, int argc, + Scheme_Object **argv); +void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o); +void scheme_wrong_return_arity(const char *where, + int expected, int got, + Scheme_Object **argv, + const char *context_detail, ...); +void scheme_unbound_global(Scheme_Object *name) ; + +Scheme_Object *scheme_dynamic_wind(void (*pre)(void *), + Scheme_Object *(*act)(void *), + void (*post)(void *), + Scheme_Object *(*jmp_handler)(void *), + void *data); + +/*========================================================================*/ +/* types */ +/*========================================================================*/ + +Scheme_Type scheme_make_type(const char *name); + +/* Type readers & writers for compiled code data */ +void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f); +void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f); + +/*========================================================================*/ +/* constants */ +/*========================================================================*/ + +extern Scheme_Object scheme_eof[1]; +extern Scheme_Object scheme_null[1]; +extern Scheme_Object scheme_true[1]; +extern Scheme_Object scheme_false[1]; +extern Scheme_Object scheme_void[1]; +extern Scheme_Object scheme_undefined[1]; +extern Scheme_Object *scheme_tail_call_waiting; +extern Scheme_Object *scheme_multiple_values; + +/*========================================================================*/ +/* evaluation */ +/*========================================================================*/ + +Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env); +Scheme_Object *scheme_eval_multi(Scheme_Object *obj, Scheme_Env *env); +Scheme_Object *scheme_eval_compiled(Scheme_Object *obj); +Scheme_Object *scheme_eval_compiled_multi(Scheme_Object *obj); +Scheme_Object *_scheme_eval_compiled(Scheme_Object *obj); +Scheme_Object *_scheme_eval_compiled_multi(Scheme_Object *obj); +#ifndef MZ_REAL_THREADS +Scheme_Object *scheme_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *scheme_apply_multi(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *scheme_apply_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *scheme_apply_multi_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +#else +Scheme_Object *scheme_apply_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *scheme_apply_multi_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *scheme_apply_eb_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *scheme_apply_multi_eb_wp(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +#endif +Scheme_Object *scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *argss); +Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env); +Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env); +Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int all); + +Scheme_Object *_scheme_apply_known_closed_prim(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator, int argc, + Scheme_Object **argv); + +Scheme_Object *scheme_values(int c, Scheme_Object **v); + +Scheme_Object *scheme_check_one_value(Scheme_Object *v); + +/* Tail calls - only use these when you're writing new functions/syntax */ +Scheme_Object *scheme_tail_apply(Scheme_Object *f, int n, Scheme_Object **arg); +Scheme_Object *scheme_tail_apply_no_copy(Scheme_Object *f, int n, Scheme_Object **arg); +Scheme_Object *scheme_tail_apply_to_list(Scheme_Object *f, Scheme_Object *l); + +Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj); + +void scheme_set_tail_buffer_size(int s); +Scheme_Object *scheme_force_value(Scheme_Object *); + +void scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val); +void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *); +void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *); +void scheme_temp_dec_mark_depth(); +void scheme_temp_inc_mark_depth(); + +Scheme_Object *scheme_current_continuation_marks(void); + +/* Internal */ +#ifndef MZ_REAL_THREADS +Scheme_Object *scheme_do_eval(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); +#else +Scheme_Object *scheme_do_eval_w_process(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val, Scheme_Process *p); +#endif + +/*========================================================================*/ +/* memory management */ +/*========================================================================*/ + +/* The core allocator functions depend on the GC. Macros in scheme.h */ +/* map to the apporpriate core allocation function. */ + +#ifndef SCHEME_NO_GC +# ifndef SCHEME_NO_GC_PROTO +void *GC_malloc(size_t size_in_bytes); +void *GC_malloc_atomic(size_t size_in_bytes); +# ifdef MZ_PRECISE_GC +void *GC_malloc_one_tagged(size_t size_in_bytes); +void *GC_malloc_atomic_uncollectable(size_t size_in_bytes); +void *GC_malloc_array_tagged(size_t size_in_bytes); +# else +void *GC_malloc_stubborn(size_t size_in_bytes); +void *GC_malloc_uncollectable(size_t size_in_bytes); +# endif +# endif +#endif + +void *scheme_malloc_eternal(size_t n); +void scheme_end_stubborn_change(void *p); + +void *scheme_calloc(size_t num, size_t size); + +char *scheme_strdup(const char *str); +char *scheme_strdup_eternal(const char *str); + +void *scheme_malloc_fail_ok(void *(*f)(size_t), size_t); + +void scheme_weak_reference(void **p); +void scheme_weak_reference_indirect(void **p, void *v); +void scheme_unweak_reference(void **p); +void scheme_add_finalizer(void *p, void (*f)(void *p, void *data), void *data); +void scheme_add_finalizer_once(void *p, void (*f)(void *p, void *data), void *data); +void scheme_add_scheme_finalizer(void *p, void (*f)(void *p, void *data), void *data); +void scheme_add_scheme_finalizer_once(void *p, void (*f)(void *p, void *data), void *data); +void scheme_register_finalizer(void *p, + void (*f)(void *p, void *data), void *data, + void (**oldf)(void *p, void *data), + void **olddata); +void scheme_remove_all_finalization(void *p); + +void scheme_dont_gc_ptr(void *p); +void scheme_gc_ptr_ok(void *p); + +void scheme_collect_garbage(void); + +/*========================================================================*/ +/* hash tables */ +/*========================================================================*/ + +Scheme_Hash_Table *scheme_hash_table(int size, int type, + int w_const, int forever); +void scheme_add_to_table(Scheme_Hash_Table *table, const char *key, void *val, int); +void scheme_change_in_table(Scheme_Hash_Table *table, const char *key, void *new_val); +void *scheme_lookup_in_table(Scheme_Hash_Table *table, const char *key); +Scheme_Bucket *scheme_bucket_from_table(Scheme_Hash_Table *table, const char *key); + +/*========================================================================*/ +/* basic Scheme value constructors */ +/*========================================================================*/ + +Scheme_Object *scheme_make_prim(Scheme_Prim *prim); +Scheme_Object *scheme_make_noneternal_prim(Scheme_Prim *prim); +Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data); +Scheme_Object *scheme_make_prim_w_arity(Scheme_Prim *prim, const char *name, + short mina, short maxa); +Scheme_Object *scheme_make_folding_prim(Scheme_Prim *prim, + const char *name, + short mina, short maxa, + short functional); +Scheme_Object *scheme_make_noneternal_prim_w_arity(Scheme_Prim *prim, + const char *name, + short mina, short maxa); +Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim, + void *data, const char *name, + short mina, short maxa); +Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim, + void *data, const char *name, + short mina, short maxa, + short functional); + +Scheme_Object *scheme_make_closure(Scheme_Env *env, Scheme_Object *code); +Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr); +Scheme_Object *scheme_make_string(const char *chars); +Scheme_Object *scheme_make_sized_string(char *chars, long len, int copy); +Scheme_Object *scheme_make_sized_offset_string(char *chars, long d, long len, int copy); +Scheme_Object *scheme_make_immutable_sized_string(char *chars, long len, int copy); +Scheme_Object *scheme_make_string_without_copying(char *chars); +Scheme_Object *scheme_alloc_string(int size, char fill); +Scheme_Object *scheme_append_string(Scheme_Object *, Scheme_Object *); +Scheme_Object *scheme_make_vector(int size, Scheme_Object *fill); +Scheme_Object *scheme_make_integer_value(long i); +Scheme_Object *scheme_make_integer_value_from_unsigned(unsigned long i); +Scheme_Object *scheme_make_double(double d); +#ifdef MZ_USE_SINGLE_FLOATS +Scheme_Object *scheme_make_float(float f) ; +#endif +Scheme_Object *scheme_make_char(char ch); +Scheme_Object *scheme_make_promise(Scheme_Object *expr, Scheme_Env *env); +Scheme_Object *scheme_make_promise_from_thunk(Scheme_Object *expr); +#ifndef NO_SCHEME_THREADS +Scheme_Object *scheme_make_sema(long v); +void scheme_post_sema(Scheme_Object *o); +int scheme_wait_sema(Scheme_Object *o, int just_try); +#endif +extern Scheme_Object **scheme_char_constants; + +int scheme_get_int_val(Scheme_Object *o, long *v); +int scheme_get_unsigned_int_val(Scheme_Object *o, unsigned long *v); + +double scheme_real_to_double(Scheme_Object *r); + +const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error); + +/*========================================================================*/ +/* bignums */ +/*========================================================================*/ + +Scheme_Object *scheme_make_bignum(long v); +Scheme_Object *scheme_make_bignum_from_unsigned(unsigned long v); +double scheme_bignum_to_double(const Scheme_Object *n); +Scheme_Object *scheme_bignum_from_double(double d); +#ifdef MZ_USE_SINGLE_FLOATS +float scheme_bignum_to_float(const Scheme_Object *n); +Scheme_Object *scheme_bignum_from_float(float d); +#else +# define scheme_bignum_to_float scheme_bignum_to_double +# define scheme_bignum_from_float scheme_bignum_from_double +#endif +char *scheme_bignum_to_string(const Scheme_Object *n, int radix); +Scheme_Object *scheme_read_bignum(const char *str, int offset, int radix); +Scheme_Object *scheme_bignum_normalize(const Scheme_Object *n); + +long scheme_double_to_int(const char *where, double d) ; + +/*========================================================================*/ +/* rationals */ +/*========================================================================*/ + +Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Scheme_Object *d); +double scheme_rational_to_double(const Scheme_Object *n); +Scheme_Object *scheme_rational_from_double(double d); +#ifdef MZ_USE_SINGLE_FLOATS +float scheme_rational_to_float(const Scheme_Object *n); +Scheme_Object *scheme_rational_from_float(float d); +#else +# define scheme_rational_to_float scheme_rational_to_double +# define scheme_rational_from_float scheme_rational_from_double +#endif +Scheme_Object *scheme_rational_normalize(const Scheme_Object *n); +Scheme_Object *scheme_rational_numerator(const Scheme_Object *n); +Scheme_Object *scheme_rational_denominator(const Scheme_Object *n); + +/*========================================================================*/ +/* complexes */ +/*========================================================================*/ + +Scheme_Object *scheme_make_complex(const Scheme_Object *r, const Scheme_Object *i); +Scheme_Object *scheme_complex_normalize(const Scheme_Object *n); +Scheme_Object *scheme_complex_real_part(const Scheme_Object *n); +Scheme_Object *scheme_complex_imaginary_part(const Scheme_Object *n); + +/* Exact/inexact: */ +int scheme_is_exact(Scheme_Object *n); +int scheme_is_inexact(Scheme_Object *n); + +/*========================================================================*/ +/* macros, syntax, and compilation */ +/*========================================================================*/ + +Scheme_Object *scheme_expand(Scheme_Object *form, Scheme_Env *env); + +Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable); +Scheme_Object *scheme_make_promise_value(Scheme_Object *compiled_expr); + +/*========================================================================*/ +/* ports */ +/*========================================================================*/ + +Scheme_Object *scheme_read(Scheme_Object *port); +void scheme_write(Scheme_Object *obj, Scheme_Object *port); +void scheme_display(Scheme_Object *obj, Scheme_Object *port); +void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl); +void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl); +void scheme_write_string(const char *str, long len, Scheme_Object *port); +void scheme_write_offset_string(const char *str, long d, long len, Scheme_Object *port); +char *scheme_write_to_string(Scheme_Object *obj, long *len); +char *scheme_display_to_string(Scheme_Object *obj, long *len); +char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl); +char *scheme_display_to_string_w_max(Scheme_Object *obj, long *len, long maxl); +void scheme_debug_print(Scheme_Object *obj); +void scheme_flush_output(Scheme_Object *port); + +char *scheme_format(char *format, int flen, int argc, Scheme_Object **argv, int *rlen); +void scheme_printf(char *format, int flen, int argc, Scheme_Object **argv); + +int scheme_getc(Scheme_Object *port); +int scheme_peekc(Scheme_Object *port); +void scheme_ungetc(int ch, Scheme_Object *port); +int scheme_char_ready(Scheme_Object *port); +int scheme_peekc_is_ungetc(Scheme_Object *port); +void scheme_need_wakeup(Scheme_Object *port, void *fds); +long scheme_get_chars(Scheme_Object *port, long size, char *buffer, int offset); +long scheme_tell(Scheme_Object *port); +long scheme_output_tell(Scheme_Object *port); +long scheme_tell_line(Scheme_Object *port); +void scheme_count_lines(Scheme_Object *port); +void scheme_close_input_port(Scheme_Object *port); +void scheme_close_output_port(Scheme_Object *port); +int scheme_are_all_chars_ready(Scheme_Object *port); + +Scheme_Object *scheme_make_port_type(const char *name); +Scheme_Input_Port *scheme_make_input_port(Scheme_Object *subtype, void *data, + int (*getc_fun)(Scheme_Input_Port*), + int (*peekc_fun)(Scheme_Input_Port*), + int (*char_ready_fun) + (Scheme_Input_Port*), + void (*close_fun) + (Scheme_Input_Port*), + void (*need_wakeup_fun) + (Scheme_Input_Port*, void *), + int must_close); +Scheme_Output_Port *scheme_make_output_port(Scheme_Object *subtype, + void *data, + void (*write_string_fun) + (char*, long, long, Scheme_Output_Port*), + void (*close_fun) + (Scheme_Output_Port*), + int must_close); + +Scheme_Object *scheme_make_file_input_port(FILE *fp); +Scheme_Object *scheme_make_named_file_input_port(FILE *fp, const char *filename); +Scheme_Object *scheme_make_file_output_port(FILE *fp); + +Scheme_Object *scheme_make_string_input_port(const char *str); +Scheme_Object *scheme_make_sized_string_input_port(const char *str, long len); +Scheme_Object *scheme_make_string_output_port(); +char *scheme_get_string_output(Scheme_Object *); +char *scheme_get_sized_string_output(Scheme_Object *, int *len); + +void scheme_pipe(Scheme_Object **write, Scheme_Object **read); + +int scheme_file_exists(char *filename); +int scheme_directory_exists(char *dirname); +char *scheme_expand_filename(char* filename, int ilen, char *errorin, int *ex); + +char *scheme_os_getcwd(char *buf, int buflen, int *actlen, int noexn); +int scheme_os_setcwd(char *buf, int noexn); +char *scheme_getdrive(void); + +Scheme_Object *scheme_split_pathname(const char *path, int len, Scheme_Object **base, int *isdir); +Scheme_Object *scheme_build_pathname(int argc, Scheme_Object **argv); + +void *scheme_alloc_fdset_array(int count, int permanent); +void *scheme_init_fdset_array(void *fdarray, int count); +void *scheme_get_fdset(void *fdarray, int pos); +void scheme_fdzero(void *fd); +void scheme_fdset(void *fd, int pos); +void scheme_fdclr(void *fd, int pos); +int scheme_fdisset(void *fd, int pos); +void scheme_add_fd_handle(void *h, void *fds, int repost); +void scheme_add_fd_eventmask(void *fds, int mask); + +int scheme_return_eof_for_error(); + +/*========================================================================*/ +/* namespace/environment */ +/*========================================================================*/ + +Scheme_Object *scheme_make_namespace(int argc, Scheme_Object *argv[]); +void scheme_add_namespace_option(Scheme_Object *key, void (*f)(Scheme_Env *)); + +void scheme_add_global(const char *name, Scheme_Object *val, Scheme_Env *env); +void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env); +void scheme_add_global_keyword(const char *name, Scheme_Object *v, Scheme_Env *env); +void scheme_remove_global(const char *name, Scheme_Env *env); +void scheme_remove_global_constant(const char *name, Scheme_Env *env); + +void scheme_add_global_symbol(Scheme_Object *name, Scheme_Object *val, + Scheme_Env *env); +void scheme_remove_global_symbol(Scheme_Object *name, Scheme_Env *env); +void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); + +void scheme_set_keyword(Scheme_Object *name, Scheme_Env *env); + +Scheme_Object *scheme_make_envunbox(Scheme_Object *value); + +Scheme_Object *scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env); +Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env); + +void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val, + int set_undef); + +/*========================================================================*/ +/* symbols */ +/*========================================================================*/ + +Scheme_Object *scheme_intern_symbol(const char *name); +Scheme_Object *scheme_intern_exact_symbol(const char *name, int len); +Scheme_Object *scheme_make_symbol(const char *name); /* Make uninterned */ +Scheme_Object *scheme_make_exact_symbol(const char *name, int len); /* Exact case */ +const char *scheme_symbol_name(Scheme_Object *sym); +const char *scheme_symbol_name_and_size(Scheme_Object *sym, int *l, int flags); +char *scheme_symbol_val(Scheme_Object *sym); + +/*========================================================================*/ +/* structs */ +/*========================================================================*/ + +Scheme_Object **scheme_make_struct_values(Scheme_Object *struct_type, + Scheme_Object **names, + int count, int flags); +Scheme_Object **scheme_make_struct_names(Scheme_Object *base, + Scheme_Object *field_names, + int flags, int *count_out); +Scheme_Object *scheme_make_struct_type(Scheme_Object *base, + Scheme_Object *parent, + int num_fields); +Scheme_Object *scheme_make_struct_instance(Scheme_Object *stype, + int argc, + Scheme_Object **argv); +int scheme_is_struct_instance(Scheme_Object *type, Scheme_Object *v); +Scheme_Object *scheme_struct_ref(Scheme_Object *s, int pos); +void scheme_struct_set(Scheme_Object *s, int pos, Scheme_Object *v); + +/*========================================================================*/ +/* objects */ +/*========================================================================*/ + +#ifndef NO_OBJECT_SYSTEM + +int scheme_is_subclass(Scheme_Object *sub, Scheme_Object *parent); +int scheme_is_implementation(Scheme_Object *cl, Scheme_Object *in); +int scheme_is_interface_extension(Scheme_Object *n1, Scheme_Object *n2); +int scheme_is_a(Scheme_Object *obj, Scheme_Object *sclass); +const char *scheme_get_class_name(Scheme_Object *cl, int *len); +const char *scheme_get_interface_name(Scheme_Object *cl, int *len); + +Scheme_Object *scheme_make_object(Scheme_Object *sclass, + int argc, Scheme_Object **argv); +Scheme_Object *scheme_make_uninited_object(Scheme_Object *sclass); + +Scheme_Object *scheme_find_ivar(Scheme_Object *obj, Scheme_Object *sym, int force); + + +/* OLD class-making interface (Still used by xctocc) */ +Scheme_Object *scheme_make_class(const char *name, Scheme_Object *sup, + Scheme_Method_Prim *init, int num_methods); +void scheme_add_method(Scheme_Object *cl, const char *name, + Scheme_Method_Prim *f); +void scheme_add_method_w_arity(Scheme_Object *cl, const char *name, + Scheme_Method_Prim *f, int mina, int maxa); +void scheme_made_class(Scheme_Object *cl); +Scheme_Object *scheme_class_to_interface(Scheme_Object *cl, char *name); + +/* NEW class-making interface */ +struct Scheme_Class_Assembly *scheme_make_class_assembly(const char *name, int n_interfaces, + int n_public, Scheme_Object **names, + int n_override, Scheme_Object **onames, + int n_inh, Scheme_Object **inheritd, + int n_ren, Scheme_Object **renames, + int mina, int maxa, + Scheme_Instance_Init_Proc *initproc); +Scheme_Object *scheme_create_class(struct Scheme_Class_Assembly *a, void *data, + Scheme_Object *super, Scheme_Object **interfaces); + +struct Scheme_Interface_Assembly *scheme_make_interface_assembly(const char *name, int n_supers, + int n_names, + Scheme_Object **names); +Scheme_Object *scheme_create_interface(struct Scheme_Interface_Assembly *a, + Scheme_Object **supers); + +Scheme_Object *scheme_apply_generic_data(Scheme_Object *gdata, + Scheme_Object *sobj, int force); +Scheme_Object *scheme_get_generic_data(Scheme_Object *cl, + Scheme_Object *name); +#endif + +/*========================================================================*/ +/* units */ +/*========================================================================*/ + +Scheme_Object *scheme_invoke_unit(Scheme_Object *functor, int num_ins, + Scheme_Object **ins, Scheme_Object **anchors, + int tail, int multi); + +Scheme_Object *scheme_assemble_compound_unit(Scheme_Object *imports, + Scheme_Object *links, + Scheme_Object *exports); +Scheme_Object *scheme_make_compound_unit(Scheme_Object *data_in, + Scheme_Object **subs_in); + +const char *scheme_get_unit_name(Scheme_Object *cl, int *len); + +/*========================================================================*/ +/* utilities */ +/*========================================================================*/ + +int scheme_eq(Scheme_Object *obj1, Scheme_Object *obj2); +int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2); +int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2); + +Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv); + +int scheme_list_length(Scheme_Object *list); +int scheme_proper_list_length(Scheme_Object *list); + +Scheme_Object *scheme_alloc_list(int size); +Scheme_Object *scheme_map_1(Scheme_Object *(*f)(Scheme_Object*), + Scheme_Object *l); + +Scheme_Object *scheme_car(Scheme_Object *pair); +Scheme_Object *scheme_cdr(Scheme_Object *pair); +Scheme_Object *scheme_cadr(Scheme_Object *pair); +Scheme_Object *scheme_caddr(Scheme_Object *pair); + +Scheme_Object *scheme_vector_to_list(Scheme_Object *vec); +Scheme_Object *scheme_list_to_vector(Scheme_Object *list); + +Scheme_Object *scheme_append(Scheme_Object *lstx, Scheme_Object *lsty); + +Scheme_Object *scheme_box(Scheme_Object *v); +Scheme_Object *scheme_unbox(Scheme_Object *obj); +void scheme_set_box(Scheme_Object *b, Scheme_Object *v); + +Scheme_Object *scheme_make_weak_box(Scheme_Object *v); + +Scheme_Object *scheme_load(const char *file); +Scheme_Object *scheme_load_extension(const char *filename, Scheme_Env *env); +void scheme_register_extension_global(void *ptr, long size); + +long scheme_get_milliseconds(void); +long scheme_get_process_milliseconds(void); + +void scheme_rep(void); +char *scheme_banner(void); +char *scheme_version(void); + +int scheme_check_proc_arity(const char *where, int a, + int which, int argc, Scheme_Object **argv); + +char *scheme_make_provided_string(Scheme_Object *o, int count, int *len); +char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, long *len); + +void scheme_no_dumps(char *why); + +const char *scheme_system_library_subpath(); diff --git a/collects/mzscheme/include/schemex.h b/collects/mzscheme/include/schemex.h new file mode 100644 index 00000000..63140f14 --- /dev/null +++ b/collects/mzscheme/include/schemex.h @@ -0,0 +1,559 @@ +/* + MzScheme + Copyright (c) 1995-2000 Matthew Flatt + All rights reserved. + + Please see the full copyright in the documentation. + + Originally based on: + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* MzScheme function prototypes */ +/* Macros generally shouldn't go in this file; it is used both to + prototype functions, and as a parsing source for + declaring scheme_extension_table */ + +/* The scheme_extension_table "parser" is picky; don't leave a space + between a function name and it's opening parameter parenthesis. */ + +/* After this START tag, all comments should start & end on same line */ + +typedef struct { +/*========================================================================*/ +/* setjmpup (continuations) */ +/*========================================================================*/ +void (*scheme_init_jmpup_buf)(Scheme_Jumpup_Buf *b); +int (*scheme_setjmpup_relative)(Scheme_Jumpup_Buf *b, void *base, + void *start, Scheme_Jumpup_Buf *cont); +void (*scheme_longjmpup)(Scheme_Jumpup_Buf *b); +void (*scheme_reset_jmpup_buf)(Scheme_Jumpup_Buf *b); +#ifdef USE_MZ_SETJMP +int (*scheme_setjmp)(mz_jmp_buf b); +void (*scheme_longjmp)(mz_jmp_buf b, int v); +#endif +void (*scheme_clear_escape)(void); +/*========================================================================*/ +/* parameters */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_config)(Scheme_Config *base); +Scheme_Object *(*scheme_branch_config)(void); +int (*scheme_new_param)(void); +Scheme_Object *(*scheme_param_config)(char *name, Scheme_Object *pos, + int argc, Scheme_Object **argv, + int arity, + Scheme_Prim *check, char *expected, + int isbool); +Scheme_Object *(*scheme_register_parameter)(Scheme_Prim *function, char *name, int which); +Scheme_Env *(*scheme_get_env)(Scheme_Config *config); +/*========================================================================*/ +/* threads */ +/*========================================================================*/ +#ifdef MZ_REAL_THREADS +Scheme_Process *(*scheme_get_current_process)(); +#else +#ifndef LINK_EXTENSIONS_BY_TABLE +Scheme_Process *scheme_current_process; +int scheme_fuel_counter; +#else +Scheme_Process **scheme_current_process_ptr; +int *scheme_fuel_counter_ptr; +#endif +#endif +#ifndef NO_SCHEME_THREADS +Scheme_Object *(*scheme_thread)(Scheme_Object *thunk, Scheme_Config *config); +Scheme_Object *(*scheme_thread_w_manager)(Scheme_Object *thunk, Scheme_Config *config, + Scheme_Manager *mgr); +void (*scheme_kill_thread)(Scheme_Process *p); +#endif +void (*scheme_break_thread)(Scheme_Process *p); +#ifndef MZ_REAL_THREADS +void (*scheme_process_block)(float sleep_time); +void (*scheme_swap_process)(Scheme_Process *process); +#else +void (*scheme_process_block_w_process)(float sleep_time, Scheme_Process *p); +#endif +void (*scheme_weak_suspend_thread)(Scheme_Process *p); +void (*scheme_weak_resume_thread)(Scheme_Process *p); +int (*scheme_block_until)(int (*f)(Scheme_Object *), void (*fdfd)(Scheme_Object *, void *), void *, float); +int (*scheme_in_main_thread)(void); +int (*scheme_tls_allocate)(); +void (*scheme_tls_set)(int pos, void *v); +void *(*scheme_tls_get)(int pos); +Scheme_Manager *(*scheme_make_manager)(Scheme_Manager *); +Scheme_Manager_Reference *(*scheme_add_managed)(Scheme_Manager *m, Scheme_Object *o, + Scheme_Close_Manager_Client *f, void *data, + int strong); +void (*scheme_remove_managed)(Scheme_Manager_Reference *m, Scheme_Object *o); +void (*scheme_close_managed)(Scheme_Manager *m); +/*========================================================================*/ +/* error handling */ +/*========================================================================*/ +void (*scheme_signal_error)(char *msg, ...); +void (*scheme_raise_exn)(int exnid, ...); +void (*scheme_warning)(char *msg, ...); +void (*scheme_wrong_count)(const char *name, int minc, int maxc, int argc, + Scheme_Object **argv); +void (*scheme_case_lambda_wrong_count)(const char *name, int argc, + Scheme_Object **argv, int count, ...); +void (*scheme_wrong_type)(const char *name, const char *expected, + int which, int argc, + Scheme_Object **argv); +void (*scheme_arg_mismatch)(const char *name, const char *msg, Scheme_Object *o); +void (*scheme_wrong_return_arity)(const char *where, + int expected, int got, + Scheme_Object **argv, + const char *context_detail, ...); +void (*scheme_unbound_global)(Scheme_Object *name) ; +Scheme_Object *(*scheme_dynamic_wind)(void (*pre)(void *), + Scheme_Object *(*act)(void *), + void (*post)(void *), + Scheme_Object *(*jmp_handler)(void *), + void *data); +/*========================================================================*/ +/* types */ +/*========================================================================*/ +Scheme_Type (*scheme_make_type)(const char *name); +/* Type readers & writers for compiled code data */ +void (*scheme_install_type_reader)(Scheme_Type type, Scheme_Type_Reader f); +void (*scheme_install_type_writer)(Scheme_Type type, Scheme_Type_Writer f); +/*========================================================================*/ +/* constants */ +/*========================================================================*/ +Scheme_Object *scheme_eof; +Scheme_Object *scheme_null; +Scheme_Object *scheme_true; +Scheme_Object *scheme_false; +Scheme_Object *scheme_void; +Scheme_Object *scheme_undefined; +Scheme_Object *scheme_tail_call_waiting; +Scheme_Object *scheme_multiple_values; +/*========================================================================*/ +/* evaluation */ +/*========================================================================*/ +Scheme_Object *(*scheme_eval)(Scheme_Object *obj, Scheme_Env *env); +Scheme_Object *(*scheme_eval_multi)(Scheme_Object *obj, Scheme_Env *env); +Scheme_Object *(*scheme_eval_compiled)(Scheme_Object *obj); +Scheme_Object *(*scheme_eval_compiled_multi)(Scheme_Object *obj); +Scheme_Object *(*_scheme_eval_compiled)(Scheme_Object *obj); +Scheme_Object *(*_scheme_eval_compiled_multi)(Scheme_Object *obj); +#ifndef MZ_REAL_THREADS +Scheme_Object *(*scheme_apply)(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *(*scheme_apply_multi)(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *(*scheme_apply_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +Scheme_Object *(*scheme_apply_multi_eb)(Scheme_Object *rator, int num_rands, Scheme_Object **rands); +#else +Scheme_Object *(*scheme_apply_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *(*scheme_apply_multi_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *(*scheme_apply_eb_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +Scheme_Object *(*scheme_apply_multi_eb_wp)(Scheme_Object *rator, int num_rands, Scheme_Object **rands, + Scheme_Process *p); +#endif +Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *argss); +Scheme_Object *(*scheme_eval_string)(const char *str, Scheme_Env *env); +Scheme_Object *(*scheme_eval_string_multi)(const char *str, Scheme_Env *env); +Scheme_Object *(*scheme_eval_string_all)(const char *str, Scheme_Env *env, int all); +Scheme_Object *(*_scheme_apply_known_closed_prim)(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *(*_scheme_apply_known_closed_prim_multi)(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *(*_scheme_apply_closed_prim)(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *(*_scheme_apply_closed_prim_multi)(Scheme_Object *rator, int argc, + Scheme_Object **argv); +Scheme_Object *(*scheme_values)(int c, Scheme_Object **v); +Scheme_Object *(*scheme_check_one_value)(Scheme_Object *v); +/* Tail calls - only use these when you're writing new functions/syntax */ +Scheme_Object *(*scheme_tail_apply)(Scheme_Object *f, int n, Scheme_Object **arg); +Scheme_Object *(*scheme_tail_apply_no_copy)(Scheme_Object *f, int n, Scheme_Object **arg); +Scheme_Object *(*scheme_tail_apply_to_list)(Scheme_Object *f, Scheme_Object *l); +Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj); +void (*scheme_set_tail_buffer_size)(int s); +Scheme_Object *(*scheme_force_value)(Scheme_Object *); +void (*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val); +void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *); +void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *); +void (*scheme_temp_dec_mark_depth)(); +void (*scheme_temp_inc_mark_depth)(); +Scheme_Object *(*scheme_current_continuation_marks)(void); +/* Internal */ +#ifndef MZ_REAL_THREADS +Scheme_Object *(*scheme_do_eval)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val); +#else +Scheme_Object *(*scheme_do_eval_w_process)(Scheme_Object *obj, int _num_rands, Scheme_Object **rands, int val, Scheme_Process *p); +#endif +/*========================================================================*/ +/* memory management */ +/*========================================================================*/ +/* The core allocator functions depend on the GC. Macros in scheme.h */ +/* map to the apporpriate core allocation function. */ +#ifndef SCHEME_NO_GC +# ifndef SCHEME_NO_GC_PROTO +void *(*GC_malloc)(size_t size_in_bytes); +void *(*GC_malloc_atomic)(size_t size_in_bytes); +# ifdef MZ_PRECISE_GC +void *(*GC_malloc_one_tagged)(size_t size_in_bytes); +void *(*GC_malloc_atomic_uncollectable)(size_t size_in_bytes); +void *(*GC_malloc_array_tagged)(size_t size_in_bytes); +# else +void *(*GC_malloc_stubborn)(size_t size_in_bytes); +void *(*GC_malloc_uncollectable)(size_t size_in_bytes); +# endif +# endif +#endif +void *(*scheme_malloc_eternal)(size_t n); +void (*scheme_end_stubborn_change)(void *p); +void *(*scheme_calloc)(size_t num, size_t size); +char *(*scheme_strdup)(const char *str); +char *(*scheme_strdup_eternal)(const char *str); +void *(*scheme_malloc_fail_ok)(void *(*f)(size_t), size_t); +void (*scheme_weak_reference)(void **p); +void (*scheme_weak_reference_indirect)(void **p, void *v); +void (*scheme_unweak_reference)(void **p); +void (*scheme_add_finalizer)(void *p, void (*f)(void *p, void *data), void *data); +void (*scheme_add_finalizer_once)(void *p, void (*f)(void *p, void *data), void *data); +void (*scheme_add_scheme_finalizer)(void *p, void (*f)(void *p, void *data), void *data); +void (*scheme_add_scheme_finalizer_once)(void *p, void (*f)(void *p, void *data), void *data); +void (*scheme_register_finalizer)(void *p, + void (*f)(void *p, void *data), void *data, + void (**oldf)(void *p, void *data), + void **olddata); +void (*scheme_remove_all_finalization)(void *p); +void (*scheme_dont_gc_ptr)(void *p); +void (*scheme_gc_ptr_ok)(void *p); +void (*scheme_collect_garbage)(void); +/*========================================================================*/ +/* hash tables */ +/*========================================================================*/ +Scheme_Hash_Table *(*scheme_hash_table)(int size, int type, + int w_const, int forever); +void (*scheme_add_to_table)(Scheme_Hash_Table *table, const char *key, void *val, int); +void (*scheme_change_in_table)(Scheme_Hash_Table *table, const char *key, void *new_val); +void *(*scheme_lookup_in_table)(Scheme_Hash_Table *table, const char *key); +Scheme_Bucket *(*scheme_bucket_from_table)(Scheme_Hash_Table *table, const char *key); +/*========================================================================*/ +/* basic Scheme value constructors */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_prim)(Scheme_Prim *prim); +Scheme_Object *(*scheme_make_noneternal_prim)(Scheme_Prim *prim); +Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data); +Scheme_Object *(*scheme_make_prim_w_arity)(Scheme_Prim *prim, const char *name, + short mina, short maxa); +Scheme_Object *(*scheme_make_folding_prim)(Scheme_Prim *prim, + const char *name, + short mina, short maxa, + short functional); +Scheme_Object *(*scheme_make_noneternal_prim_w_arity)(Scheme_Prim *prim, + const char *name, + short mina, short maxa); +Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim, + void *data, const char *name, + short mina, short maxa); +Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim, + void *data, const char *name, + short mina, short maxa, + short functional); +Scheme_Object *(*scheme_make_closure)(Scheme_Env *env, Scheme_Object *code); +Scheme_Object *(*scheme_make_pair)(Scheme_Object *car, Scheme_Object *cdr); +Scheme_Object *(*scheme_make_string)(const char *chars); +Scheme_Object *(*scheme_make_sized_string)(char *chars, long len, int copy); +Scheme_Object *(*scheme_make_sized_offset_string)(char *chars, long d, long len, int copy); +Scheme_Object *(*scheme_make_immutable_sized_string)(char *chars, long len, int copy); +Scheme_Object *(*scheme_make_string_without_copying)(char *chars); +Scheme_Object *(*scheme_alloc_string)(int size, char fill); +Scheme_Object *(*scheme_append_string)(Scheme_Object *, Scheme_Object *); +Scheme_Object *(*scheme_make_vector)(int size, Scheme_Object *fill); +Scheme_Object *(*scheme_make_integer_value)(long i); +Scheme_Object *(*scheme_make_integer_value_from_unsigned)(unsigned long i); +Scheme_Object *(*scheme_make_double)(double d); +#ifdef MZ_USE_SINGLE_FLOATS +Scheme_Object *(*scheme_make_float)(float f) ; +#endif +Scheme_Object *(*scheme_make_char)(char ch); +Scheme_Object *(*scheme_make_promise)(Scheme_Object *expr, Scheme_Env *env); +Scheme_Object *(*scheme_make_promise_from_thunk)(Scheme_Object *expr); +#ifndef NO_SCHEME_THREADS +Scheme_Object *(*scheme_make_sema)(long v); +void (*scheme_post_sema)(Scheme_Object *o); +int (*scheme_wait_sema)(Scheme_Object *o, int just_try); +#endif +Scheme_Object **scheme_char_constants; +int (*scheme_get_int_val)(Scheme_Object *o, long *v); +int (*scheme_get_unsigned_int_val)(Scheme_Object *o, unsigned long *v); +double (*scheme_real_to_double)(Scheme_Object *r); +const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error); +/*========================================================================*/ +/* bignums */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_bignum)(long v); +Scheme_Object *(*scheme_make_bignum_from_unsigned)(unsigned long v); +double (*scheme_bignum_to_double)(const Scheme_Object *n); +Scheme_Object *(*scheme_bignum_from_double)(double d); +#ifdef MZ_USE_SINGLE_FLOATS +float (*scheme_bignum_to_float)(const Scheme_Object *n); +Scheme_Object *(*scheme_bignum_from_float)(float d); +#else +# define scheme_bignum_to_float scheme_bignum_to_double +# define scheme_bignum_from_float scheme_bignum_from_double +#endif +char *(*scheme_bignum_to_string)(const Scheme_Object *n, int radix); +Scheme_Object *(*scheme_read_bignum)(const char *str, int offset, int radix); +Scheme_Object *(*scheme_bignum_normalize)(const Scheme_Object *n); +long (*scheme_double_to_int)(const char *where, double d) ; +/*========================================================================*/ +/* rationals */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_rational)(const Scheme_Object *r, const Scheme_Object *d); +double (*scheme_rational_to_double)(const Scheme_Object *n); +Scheme_Object *(*scheme_rational_from_double)(double d); +#ifdef MZ_USE_SINGLE_FLOATS +float (*scheme_rational_to_float)(const Scheme_Object *n); +Scheme_Object *(*scheme_rational_from_float)(float d); +#else +# define scheme_rational_to_float scheme_rational_to_double +# define scheme_rational_from_float scheme_rational_from_double +#endif +Scheme_Object *(*scheme_rational_normalize)(const Scheme_Object *n); +Scheme_Object *(*scheme_rational_numerator)(const Scheme_Object *n); +Scheme_Object *(*scheme_rational_denominator)(const Scheme_Object *n); +/*========================================================================*/ +/* complexes */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_complex)(const Scheme_Object *r, const Scheme_Object *i); +Scheme_Object *(*scheme_complex_normalize)(const Scheme_Object *n); +Scheme_Object *(*scheme_complex_real_part)(const Scheme_Object *n); +Scheme_Object *(*scheme_complex_imaginary_part)(const Scheme_Object *n); +/* Exact/inexact: */ +int (*scheme_is_exact)(Scheme_Object *n); +int (*scheme_is_inexact)(Scheme_Object *n); +/*========================================================================*/ +/* macros, syntax, and compilation */ +/*========================================================================*/ +Scheme_Object *(*scheme_expand)(Scheme_Object *form, Scheme_Env *env); +Scheme_Object *(*scheme_compile)(Scheme_Object *form, Scheme_Env *env, int writeable); +Scheme_Object *(*scheme_make_promise_value)(Scheme_Object *compiled_expr); +/*========================================================================*/ +/* ports */ +/*========================================================================*/ +Scheme_Object *(*scheme_read)(Scheme_Object *port); +void (*scheme_write)(Scheme_Object *obj, Scheme_Object *port); +void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port); +void (*scheme_write_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl); +void (*scheme_display_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl); +void (*scheme_write_string)(const char *str, long len, Scheme_Object *port); +void (*scheme_write_offset_string)(const char *str, long d, long len, Scheme_Object *port); +char *(*scheme_write_to_string)(Scheme_Object *obj, long *len); +char *(*scheme_display_to_string)(Scheme_Object *obj, long *len); +char *(*scheme_write_to_string_w_max)(Scheme_Object *obj, long *len, long maxl); +char *(*scheme_display_to_string_w_max)(Scheme_Object *obj, long *len, long maxl); +void (*scheme_debug_print)(Scheme_Object *obj); +void (*scheme_flush_output)(Scheme_Object *port); +char *(*scheme_format)(char *format, int flen, int argc, Scheme_Object **argv, int *rlen); +void (*scheme_printf)(char *format, int flen, int argc, Scheme_Object **argv); +int (*scheme_getc)(Scheme_Object *port); +int (*scheme_peekc)(Scheme_Object *port); +void (*scheme_ungetc)(int ch, Scheme_Object *port); +int (*scheme_char_ready)(Scheme_Object *port); +int (*scheme_peekc_is_ungetc)(Scheme_Object *port); +void (*scheme_need_wakeup)(Scheme_Object *port, void *fds); +long (*scheme_get_chars)(Scheme_Object *port, long size, char *buffer, int offset); +long (*scheme_tell)(Scheme_Object *port); +long (*scheme_output_tell)(Scheme_Object *port); +long (*scheme_tell_line)(Scheme_Object *port); +void (*scheme_count_lines)(Scheme_Object *port); +void (*scheme_close_input_port)(Scheme_Object *port); +void (*scheme_close_output_port)(Scheme_Object *port); +int (*scheme_are_all_chars_ready)(Scheme_Object *port); +Scheme_Object *(*scheme_make_port_type)(const char *name); +Scheme_Input_Port *(*scheme_make_input_port)(Scheme_Object *subtype, void *data, + int (*getc_fun)(Scheme_Input_Port*), + int (*peekc_fun)(Scheme_Input_Port*), + int (*char_ready_fun) + (Scheme_Input_Port*), + void (*close_fun) + (Scheme_Input_Port*), + void (*need_wakeup_fun) + (Scheme_Input_Port*, void *), + int must_close); +Scheme_Output_Port *(*scheme_make_output_port)(Scheme_Object *subtype, + void *data, + void (*write_string_fun) + (char*, long, long, Scheme_Output_Port*), + void (*close_fun) + (Scheme_Output_Port*), + int must_close); +Scheme_Object *(*scheme_make_file_input_port)(FILE *fp); +Scheme_Object *(*scheme_make_named_file_input_port)(FILE *fp, const char *filename); +Scheme_Object *(*scheme_make_file_output_port)(FILE *fp); +Scheme_Object *(*scheme_make_string_input_port)(const char *str); +Scheme_Object *(*scheme_make_sized_string_input_port)(const char *str, long len); +Scheme_Object *(*scheme_make_string_output_port)(); +char *(*scheme_get_string_output)(Scheme_Object *); +char *(*scheme_get_sized_string_output)(Scheme_Object *, int *len); +void (*scheme_pipe)(Scheme_Object **write, Scheme_Object **read); +int (*scheme_file_exists)(char *filename); +int (*scheme_directory_exists)(char *dirname); +char *(*scheme_expand_filename)(char* filename, int ilen, char *errorin, int *ex); +char *(*scheme_os_getcwd)(char *buf, int buflen, int *actlen, int noexn); +int (*scheme_os_setcwd)(char *buf, int noexn); +char *(*scheme_getdrive)(void); +Scheme_Object *(*scheme_split_pathname)(const char *path, int len, Scheme_Object **base, int *isdir); +Scheme_Object *(*scheme_build_pathname)(int argc, Scheme_Object **argv); +void *(*scheme_alloc_fdset_array)(int count, int permanent); +void *(*scheme_init_fdset_array)(void *fdarray, int count); +void *(*scheme_get_fdset)(void *fdarray, int pos); +void (*scheme_fdzero)(void *fd); +void (*scheme_fdset)(void *fd, int pos); +void (*scheme_fdclr)(void *fd, int pos); +int (*scheme_fdisset)(void *fd, int pos); +void (*scheme_add_fd_handle)(void *h, void *fds, int repost); +void (*scheme_add_fd_eventmask)(void *fds, int mask); +int (*scheme_return_eof_for_error)(); +/*========================================================================*/ +/* namespace/environment */ +/*========================================================================*/ +Scheme_Object *(*scheme_make_namespace)(int argc, Scheme_Object *argv[]); +void (*scheme_add_namespace_option)(Scheme_Object *key, void (*f)(Scheme_Env *)); +void (*scheme_add_global)(const char *name, Scheme_Object *val, Scheme_Env *env); +void (*scheme_add_global_constant)(const char *name, Scheme_Object *v, Scheme_Env *env); +void (*scheme_add_global_keyword)(const char *name, Scheme_Object *v, Scheme_Env *env); +void (*scheme_remove_global)(const char *name, Scheme_Env *env); +void (*scheme_remove_global_constant)(const char *name, Scheme_Env *env); +void (*scheme_add_global_symbol)(Scheme_Object *name, Scheme_Object *val, + Scheme_Env *env); +void (*scheme_remove_global_symbol)(Scheme_Object *name, Scheme_Env *env); +void (*scheme_add_global_constant_symbol)(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); +void (*scheme_set_keyword)(Scheme_Object *name, Scheme_Env *env); +Scheme_Object *(*scheme_make_envunbox)(Scheme_Object *value); +Scheme_Object *(*scheme_lookup_global)(Scheme_Object *symbol, Scheme_Env *env); +Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env); +void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val, + int set_undef); +/*========================================================================*/ +/* symbols */ +/*========================================================================*/ +Scheme_Object *(*scheme_intern_symbol)(const char *name); +Scheme_Object *(*scheme_intern_exact_symbol)(const char *name, int len); +Scheme_Object *(*scheme_make_symbol)(const char *name); /* Make uninterned */ +Scheme_Object *(*scheme_make_exact_symbol)(const char *name, int len); /* Exact case */ +const char *(*scheme_symbol_name)(Scheme_Object *sym); +const char *(*scheme_symbol_name_and_size)(Scheme_Object *sym, int *l, int flags); +char *(*scheme_symbol_val)(Scheme_Object *sym); +/*========================================================================*/ +/* structs */ +/*========================================================================*/ +Scheme_Object **(*scheme_make_struct_values)(Scheme_Object *struct_type, + Scheme_Object **names, + int count, int flags); +Scheme_Object **(*scheme_make_struct_names)(Scheme_Object *base, + Scheme_Object *field_names, + int flags, int *count_out); +Scheme_Object *(*scheme_make_struct_type)(Scheme_Object *base, + Scheme_Object *parent, + int num_fields); +Scheme_Object *(*scheme_make_struct_instance)(Scheme_Object *stype, + int argc, + Scheme_Object **argv); +int (*scheme_is_struct_instance)(Scheme_Object *type, Scheme_Object *v); +Scheme_Object *(*scheme_struct_ref)(Scheme_Object *s, int pos); +void (*scheme_struct_set)(Scheme_Object *s, int pos, Scheme_Object *v); +/*========================================================================*/ +/* objects */ +/*========================================================================*/ +#ifndef NO_OBJECT_SYSTEM +int (*scheme_is_subclass)(Scheme_Object *sub, Scheme_Object *parent); +int (*scheme_is_implementation)(Scheme_Object *cl, Scheme_Object *in); +int (*scheme_is_interface_extension)(Scheme_Object *n1, Scheme_Object *n2); +int (*scheme_is_a)(Scheme_Object *obj, Scheme_Object *sclass); +const char *(*scheme_get_class_name)(Scheme_Object *cl, int *len); +const char *(*scheme_get_interface_name)(Scheme_Object *cl, int *len); +Scheme_Object *(*scheme_make_object)(Scheme_Object *sclass, + int argc, Scheme_Object **argv); +Scheme_Object *(*scheme_make_uninited_object)(Scheme_Object *sclass); +Scheme_Object *(*scheme_find_ivar)(Scheme_Object *obj, Scheme_Object *sym, int force); +/* OLD class-making interface (Still used by xctocc) */ +Scheme_Object *(*scheme_make_class)(const char *name, Scheme_Object *sup, + Scheme_Method_Prim *init, int num_methods); +void (*scheme_add_method)(Scheme_Object *cl, const char *name, + Scheme_Method_Prim *f); +void (*scheme_add_method_w_arity)(Scheme_Object *cl, const char *name, + Scheme_Method_Prim *f, int mina, int maxa); +void (*scheme_made_class)(Scheme_Object *cl); +Scheme_Object *(*scheme_class_to_interface)(Scheme_Object *cl, char *name); +/* NEW class-making interface */ +struct Scheme_Class_Assembly *(*scheme_make_class_assembly)(const char *name, int n_interfaces, + int n_public, Scheme_Object **names, + int n_override, Scheme_Object **onames, + int n_inh, Scheme_Object **inheritd, + int n_ren, Scheme_Object **renames, + int mina, int maxa, + Scheme_Instance_Init_Proc *initproc); +Scheme_Object *(*scheme_create_class)(struct Scheme_Class_Assembly *a, void *data, + Scheme_Object *super, Scheme_Object **interfaces); +struct Scheme_Interface_Assembly *(*scheme_make_interface_assembly)(const char *name, int n_supers, + int n_names, + Scheme_Object **names); +Scheme_Object *(*scheme_create_interface)(struct Scheme_Interface_Assembly *a, + Scheme_Object **supers); +Scheme_Object *(*scheme_apply_generic_data)(Scheme_Object *gdata, + Scheme_Object *sobj, int force); +Scheme_Object *(*scheme_get_generic_data)(Scheme_Object *cl, + Scheme_Object *name); +#endif +/*========================================================================*/ +/* units */ +/*========================================================================*/ +Scheme_Object *(*scheme_invoke_unit)(Scheme_Object *functor, int num_ins, + Scheme_Object **ins, Scheme_Object **anchors, + int tail, int multi); +Scheme_Object *(*scheme_assemble_compound_unit)(Scheme_Object *imports, + Scheme_Object *links, + Scheme_Object *exports); +Scheme_Object *(*scheme_make_compound_unit)(Scheme_Object *data_in, + Scheme_Object **subs_in); +const char *(*scheme_get_unit_name)(Scheme_Object *cl, int *len); +/*========================================================================*/ +/* utilities */ +/*========================================================================*/ +int (*scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2); +int (*scheme_eqv)(Scheme_Object *obj1, Scheme_Object *obj2); +int (*scheme_equal)(Scheme_Object *obj1, Scheme_Object *obj2); +Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv); +int (*scheme_list_length)(Scheme_Object *list); +int (*scheme_proper_list_length)(Scheme_Object *list); +Scheme_Object *(*scheme_alloc_list)(int size); +Scheme_Object *(*scheme_map_1)(Scheme_Object *(*f)(Scheme_Object*), + Scheme_Object *l); +Scheme_Object *(*scheme_car)(Scheme_Object *pair); +Scheme_Object *(*scheme_cdr)(Scheme_Object *pair); +Scheme_Object *(*scheme_cadr)(Scheme_Object *pair); +Scheme_Object *(*scheme_caddr)(Scheme_Object *pair); +Scheme_Object *(*scheme_vector_to_list)(Scheme_Object *vec); +Scheme_Object *(*scheme_list_to_vector)(Scheme_Object *list); +Scheme_Object *(*scheme_append)(Scheme_Object *lstx, Scheme_Object *lsty); +Scheme_Object *(*scheme_box)(Scheme_Object *v); +Scheme_Object *(*scheme_unbox)(Scheme_Object *obj); +void (*scheme_set_box)(Scheme_Object *b, Scheme_Object *v); +Scheme_Object *(*scheme_make_weak_box)(Scheme_Object *v); +Scheme_Object *(*scheme_load)(const char *file); +Scheme_Object *(*scheme_load_extension)(const char *filename, Scheme_Env *env); +void (*scheme_register_extension_global)(void *ptr, long size); +long (*scheme_get_milliseconds)(void); +long (*scheme_get_process_milliseconds)(void); +void (*scheme_rep)(void); +char *(*scheme_banner)(void); +char *(*scheme_version)(void); +int (*scheme_check_proc_arity)(const char *where, int a, + int which, int argc, Scheme_Object **argv); +char *(*scheme_make_provided_string)(Scheme_Object *o, int count, int *len); +char *(*scheme_make_args_string)(char *s, int which, int argc, Scheme_Object **argv, long *len); +void (*scheme_no_dumps)(char *why); +const char *(*scheme_system_library_subpath)(); +#ifndef SCHEME_EX_INLINE +} Scheme_Extension_Table; +#endif diff --git a/collects/mzscheme/include/schemexm.h b/collects/mzscheme/include/schemexm.h new file mode 100644 index 00000000..a3d35992 --- /dev/null +++ b/collects/mzscheme/include/schemexm.h @@ -0,0 +1,371 @@ +#define scheme_init_jmpup_buf (scheme_extension_table->scheme_init_jmpup_buf) +#define scheme_setjmpup_relative (scheme_extension_table->scheme_setjmpup_relative) +#define scheme_longjmpup (scheme_extension_table->scheme_longjmpup) +#define scheme_reset_jmpup_buf (scheme_extension_table->scheme_reset_jmpup_buf) +#ifdef USE_MZ_SETJMP +#define scheme_setjmp (scheme_extension_table->scheme_setjmp) +#define scheme_longjmp (scheme_extension_table->scheme_longjmp) +#endif +#define scheme_clear_escape (scheme_extension_table->scheme_clear_escape) +#define scheme_make_config (scheme_extension_table->scheme_make_config) +#define scheme_branch_config (scheme_extension_table->scheme_branch_config) +#define scheme_new_param (scheme_extension_table->scheme_new_param) +#define scheme_param_config (scheme_extension_table->scheme_param_config) +#define scheme_register_parameter (scheme_extension_table->scheme_register_parameter) +#define scheme_get_env (scheme_extension_table->scheme_get_env) +#ifdef MZ_REAL_THREADS +#define scheme_get_current_process (scheme_extension_table->scheme_get_current_process) +#else +#ifndef LINK_EXTENSIONS_BY_TABLE +#define scheme_current_process (scheme_extension_table->scheme_current_process) +#define scheme_fuel_counter (scheme_extension_table->scheme_fuel_counter) +#else +#define scheme_current_process_ptr (scheme_extension_table->scheme_current_process_ptr) +#define scheme_fuel_counter_ptr (scheme_extension_table->scheme_fuel_counter_ptr) +#endif +#endif +#ifndef NO_SCHEME_THREADS +#define scheme_thread (scheme_extension_table->scheme_thread) +#define scheme_thread_w_manager (scheme_extension_table->scheme_thread_w_manager) +#define scheme_kill_thread (scheme_extension_table->scheme_kill_thread) +#endif +#define scheme_break_thread (scheme_extension_table->scheme_break_thread) +#ifndef MZ_REAL_THREADS +#define scheme_process_block (scheme_extension_table->scheme_process_block) +#define scheme_swap_process (scheme_extension_table->scheme_swap_process) +#else +#define scheme_process_block_w_process (scheme_extension_table->scheme_process_block_w_process) +#endif +#define scheme_weak_suspend_thread (scheme_extension_table->scheme_weak_suspend_thread) +#define scheme_weak_resume_thread (scheme_extension_table->scheme_weak_resume_thread) +#define scheme_block_until (scheme_extension_table->scheme_block_until) +#define scheme_in_main_thread (scheme_extension_table->scheme_in_main_thread) +#define scheme_tls_allocate (scheme_extension_table->scheme_tls_allocate) +#define scheme_tls_set (scheme_extension_table->scheme_tls_set) +#define scheme_tls_get (scheme_extension_table->scheme_tls_get) +#define scheme_make_manager (scheme_extension_table->scheme_make_manager) +#define scheme_add_managed (scheme_extension_table->scheme_add_managed) +#define scheme_remove_managed (scheme_extension_table->scheme_remove_managed) +#define scheme_close_managed (scheme_extension_table->scheme_close_managed) +#define scheme_signal_error (scheme_extension_table->scheme_signal_error) +#define scheme_raise_exn (scheme_extension_table->scheme_raise_exn) +#define scheme_warning (scheme_extension_table->scheme_warning) +#define scheme_wrong_count (scheme_extension_table->scheme_wrong_count) +#define scheme_case_lambda_wrong_count (scheme_extension_table->scheme_case_lambda_wrong_count) +#define scheme_wrong_type (scheme_extension_table->scheme_wrong_type) +#define scheme_arg_mismatch (scheme_extension_table->scheme_arg_mismatch) +#define scheme_wrong_return_arity (scheme_extension_table->scheme_wrong_return_arity) +#define scheme_unbound_global (scheme_extension_table->scheme_unbound_global) +#define scheme_dynamic_wind (scheme_extension_table->scheme_dynamic_wind) +#define scheme_make_type (scheme_extension_table->scheme_make_type) +#define scheme_install_type_reader (scheme_extension_table->scheme_install_type_reader) +#define scheme_install_type_writer (scheme_extension_table->scheme_install_type_writer) +#define scheme_eof (scheme_extension_table->scheme_eof) +#define scheme_null (scheme_extension_table->scheme_null) +#define scheme_true (scheme_extension_table->scheme_true) +#define scheme_false (scheme_extension_table->scheme_false) +#define scheme_void (scheme_extension_table->scheme_void) +#define scheme_undefined (scheme_extension_table->scheme_undefined) +#define scheme_tail_call_waiting (scheme_extension_table->scheme_tail_call_waiting) +#define scheme_multiple_values (scheme_extension_table->scheme_multiple_values) +#define scheme_eval (scheme_extension_table->scheme_eval) +#define scheme_eval_multi (scheme_extension_table->scheme_eval_multi) +#define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled) +#define scheme_eval_compiled_multi (scheme_extension_table->scheme_eval_compiled_multi) +#define _scheme_eval_compiled (scheme_extension_table->_scheme_eval_compiled) +#define _scheme_eval_compiled_multi (scheme_extension_table->_scheme_eval_compiled_multi) +#ifndef MZ_REAL_THREADS +#define scheme_apply (scheme_extension_table->scheme_apply) +#define scheme_apply_multi (scheme_extension_table->scheme_apply_multi) +#define scheme_apply_eb (scheme_extension_table->scheme_apply_eb) +#define scheme_apply_multi_eb (scheme_extension_table->scheme_apply_multi_eb) +#else +#define scheme_apply_wp (scheme_extension_table->scheme_apply_wp) +#define scheme_apply_multi_wp (scheme_extension_table->scheme_apply_multi_wp) +#define scheme_apply_eb_wp (scheme_extension_table->scheme_apply_eb_wp) +#define scheme_apply_multi_eb_wp (scheme_extension_table->scheme_apply_multi_eb_wp) +#endif +#define scheme_apply_to_list (scheme_extension_table->scheme_apply_to_list) +#define scheme_eval_string (scheme_extension_table->scheme_eval_string) +#define scheme_eval_string_multi (scheme_extension_table->scheme_eval_string_multi) +#define scheme_eval_string_all (scheme_extension_table->scheme_eval_string_all) +#define _scheme_apply_known_closed_prim (scheme_extension_table->_scheme_apply_known_closed_prim) +#define _scheme_apply_known_closed_prim_multi (scheme_extension_table->_scheme_apply_known_closed_prim_multi) +#define _scheme_apply_closed_prim (scheme_extension_table->_scheme_apply_closed_prim) +#define _scheme_apply_closed_prim_multi (scheme_extension_table->_scheme_apply_closed_prim_multi) +#define scheme_values (scheme_extension_table->scheme_values) +#define scheme_check_one_value (scheme_extension_table->scheme_check_one_value) +#define scheme_tail_apply (scheme_extension_table->scheme_tail_apply) +#define scheme_tail_apply_no_copy (scheme_extension_table->scheme_tail_apply_no_copy) +#define scheme_tail_apply_to_list (scheme_extension_table->scheme_tail_apply_to_list) +#define scheme_tail_eval_expr (scheme_extension_table->scheme_tail_eval_expr) +#define scheme_set_tail_buffer_size (scheme_extension_table->scheme_set_tail_buffer_size) +#define scheme_force_value (scheme_extension_table->scheme_force_value) +#define scheme_set_cont_mark (scheme_extension_table->scheme_set_cont_mark) +#define scheme_push_continuation_frame (scheme_extension_table->scheme_push_continuation_frame) +#define scheme_pop_continuation_frame (scheme_extension_table->scheme_pop_continuation_frame) +#define scheme_temp_dec_mark_depth (scheme_extension_table->scheme_temp_dec_mark_depth) +#define scheme_temp_inc_mark_depth (scheme_extension_table->scheme_temp_inc_mark_depth) +#define scheme_current_continuation_marks (scheme_extension_table->scheme_current_continuation_marks) +#ifndef MZ_REAL_THREADS +#define scheme_do_eval (scheme_extension_table->scheme_do_eval) +#else +#define scheme_do_eval_w_process (scheme_extension_table->scheme_do_eval_w_process) +#endif +#ifndef SCHEME_NO_GC +# ifndef SCHEME_NO_GC_PROTO +#define GC_malloc (scheme_extension_table->GC_malloc) +#define GC_malloc_atomic (scheme_extension_table->GC_malloc_atomic) +# ifdef MZ_PRECISE_GC +#define GC_malloc_one_tagged (scheme_extension_table->GC_malloc_one_tagged) +#define GC_malloc_atomic_uncollectable (scheme_extension_table->GC_malloc_atomic_uncollectable) +#define GC_malloc_array_tagged (scheme_extension_table->GC_malloc_array_tagged) +# else +#define GC_malloc_stubborn (scheme_extension_table->GC_malloc_stubborn) +#define GC_malloc_uncollectable (scheme_extension_table->GC_malloc_uncollectable) +# endif +# endif +#endif +#define scheme_malloc_eternal (scheme_extension_table->scheme_malloc_eternal) +#define scheme_end_stubborn_change (scheme_extension_table->scheme_end_stubborn_change) +#define scheme_calloc (scheme_extension_table->scheme_calloc) +#define scheme_strdup (scheme_extension_table->scheme_strdup) +#define scheme_strdup_eternal (scheme_extension_table->scheme_strdup_eternal) +#define scheme_malloc_fail_ok (scheme_extension_table->scheme_malloc_fail_ok) +#define scheme_weak_reference (scheme_extension_table->scheme_weak_reference) +#define scheme_weak_reference_indirect (scheme_extension_table->scheme_weak_reference_indirect) +#define scheme_unweak_reference (scheme_extension_table->scheme_unweak_reference) +#define scheme_add_finalizer (scheme_extension_table->scheme_add_finalizer) +#define scheme_add_finalizer_once (scheme_extension_table->scheme_add_finalizer_once) +#define scheme_add_scheme_finalizer (scheme_extension_table->scheme_add_scheme_finalizer) +#define scheme_add_scheme_finalizer_once (scheme_extension_table->scheme_add_scheme_finalizer_once) +#define scheme_register_finalizer (scheme_extension_table->scheme_register_finalizer) +#define scheme_remove_all_finalization (scheme_extension_table->scheme_remove_all_finalization) +#define scheme_dont_gc_ptr (scheme_extension_table->scheme_dont_gc_ptr) +#define scheme_gc_ptr_ok (scheme_extension_table->scheme_gc_ptr_ok) +#define scheme_collect_garbage (scheme_extension_table->scheme_collect_garbage) +#define scheme_hash_table (scheme_extension_table->scheme_hash_table) +#define scheme_add_to_table (scheme_extension_table->scheme_add_to_table) +#define scheme_change_in_table (scheme_extension_table->scheme_change_in_table) +#define scheme_lookup_in_table (scheme_extension_table->scheme_lookup_in_table) +#define scheme_bucket_from_table (scheme_extension_table->scheme_bucket_from_table) +#define scheme_make_prim (scheme_extension_table->scheme_make_prim) +#define scheme_make_noneternal_prim (scheme_extension_table->scheme_make_noneternal_prim) +#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim) +#define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity) +#define scheme_make_folding_prim (scheme_extension_table->scheme_make_folding_prim) +#define scheme_make_noneternal_prim_w_arity (scheme_extension_table->scheme_make_noneternal_prim_w_arity) +#define scheme_make_closed_prim_w_arity (scheme_extension_table->scheme_make_closed_prim_w_arity) +#define scheme_make_folding_closed_prim (scheme_extension_table->scheme_make_folding_closed_prim) +#define scheme_make_closure (scheme_extension_table->scheme_make_closure) +#define scheme_make_pair (scheme_extension_table->scheme_make_pair) +#define scheme_make_string (scheme_extension_table->scheme_make_string) +#define scheme_make_sized_string (scheme_extension_table->scheme_make_sized_string) +#define scheme_make_sized_offset_string (scheme_extension_table->scheme_make_sized_offset_string) +#define scheme_make_immutable_sized_string (scheme_extension_table->scheme_make_immutable_sized_string) +#define scheme_make_string_without_copying (scheme_extension_table->scheme_make_string_without_copying) +#define scheme_alloc_string (scheme_extension_table->scheme_alloc_string) +#define scheme_append_string (scheme_extension_table->scheme_append_string) +#define scheme_make_vector (scheme_extension_table->scheme_make_vector) +#define scheme_make_integer_value (scheme_extension_table->scheme_make_integer_value) +#define scheme_make_integer_value_from_unsigned (scheme_extension_table->scheme_make_integer_value_from_unsigned) +#define scheme_make_double (scheme_extension_table->scheme_make_double) +#ifdef MZ_USE_SINGLE_FLOATS +#define scheme_make_float (scheme_extension_table->scheme_make_float) +#endif +#define scheme_make_char (scheme_extension_table->scheme_make_char) +#define scheme_make_promise (scheme_extension_table->scheme_make_promise) +#define scheme_make_promise_from_thunk (scheme_extension_table->scheme_make_promise_from_thunk) +#ifndef NO_SCHEME_THREADS +#define scheme_make_sema (scheme_extension_table->scheme_make_sema) +#define scheme_post_sema (scheme_extension_table->scheme_post_sema) +#define scheme_wait_sema (scheme_extension_table->scheme_wait_sema) +#endif +#define scheme_char_constants (scheme_extension_table->scheme_char_constants) +#define scheme_get_int_val (scheme_extension_table->scheme_get_int_val) +#define scheme_get_unsigned_int_val (scheme_extension_table->scheme_get_unsigned_int_val) +#define scheme_real_to_double (scheme_extension_table->scheme_real_to_double) +#define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name) +#define scheme_make_bignum (scheme_extension_table->scheme_make_bignum) +#define scheme_make_bignum_from_unsigned (scheme_extension_table->scheme_make_bignum_from_unsigned) +#define scheme_bignum_to_double (scheme_extension_table->scheme_bignum_to_double) +#define scheme_bignum_from_double (scheme_extension_table->scheme_bignum_from_double) +#ifdef MZ_USE_SINGLE_FLOATS +#define scheme_bignum_to_float (scheme_extension_table->scheme_bignum_to_float) +#define scheme_bignum_from_float (scheme_extension_table->scheme_bignum_from_float) +#else +# define scheme_bignum_to_float scheme_bignum_to_double +# define scheme_bignum_from_float scheme_bignum_from_double +#endif +#define scheme_bignum_to_string (scheme_extension_table->scheme_bignum_to_string) +#define scheme_read_bignum (scheme_extension_table->scheme_read_bignum) +#define scheme_bignum_normalize (scheme_extension_table->scheme_bignum_normalize) +#define scheme_double_to_int (scheme_extension_table->scheme_double_to_int) +#define scheme_make_rational (scheme_extension_table->scheme_make_rational) +#define scheme_rational_to_double (scheme_extension_table->scheme_rational_to_double) +#define scheme_rational_from_double (scheme_extension_table->scheme_rational_from_double) +#ifdef MZ_USE_SINGLE_FLOATS +#define scheme_rational_to_float (scheme_extension_table->scheme_rational_to_float) +#define scheme_rational_from_float (scheme_extension_table->scheme_rational_from_float) +#else +# define scheme_rational_to_float scheme_rational_to_double +# define scheme_rational_from_float scheme_rational_from_double +#endif +#define scheme_rational_normalize (scheme_extension_table->scheme_rational_normalize) +#define scheme_rational_numerator (scheme_extension_table->scheme_rational_numerator) +#define scheme_rational_denominator (scheme_extension_table->scheme_rational_denominator) +#define scheme_make_complex (scheme_extension_table->scheme_make_complex) +#define scheme_complex_normalize (scheme_extension_table->scheme_complex_normalize) +#define scheme_complex_real_part (scheme_extension_table->scheme_complex_real_part) +#define scheme_complex_imaginary_part (scheme_extension_table->scheme_complex_imaginary_part) +#define scheme_is_exact (scheme_extension_table->scheme_is_exact) +#define scheme_is_inexact (scheme_extension_table->scheme_is_inexact) +#define scheme_expand (scheme_extension_table->scheme_expand) +#define scheme_compile (scheme_extension_table->scheme_compile) +#define scheme_make_promise_value (scheme_extension_table->scheme_make_promise_value) +#define scheme_read (scheme_extension_table->scheme_read) +#define scheme_write (scheme_extension_table->scheme_write) +#define scheme_display (scheme_extension_table->scheme_display) +#define scheme_write_w_max (scheme_extension_table->scheme_write_w_max) +#define scheme_display_w_max (scheme_extension_table->scheme_display_w_max) +#define scheme_write_string (scheme_extension_table->scheme_write_string) +#define scheme_write_offset_string (scheme_extension_table->scheme_write_offset_string) +#define scheme_write_to_string (scheme_extension_table->scheme_write_to_string) +#define scheme_display_to_string (scheme_extension_table->scheme_display_to_string) +#define scheme_write_to_string_w_max (scheme_extension_table->scheme_write_to_string_w_max) +#define scheme_display_to_string_w_max (scheme_extension_table->scheme_display_to_string_w_max) +#define scheme_debug_print (scheme_extension_table->scheme_debug_print) +#define scheme_flush_output (scheme_extension_table->scheme_flush_output) +#define scheme_format (scheme_extension_table->scheme_format) +#define scheme_printf (scheme_extension_table->scheme_printf) +#define scheme_getc (scheme_extension_table->scheme_getc) +#define scheme_peekc (scheme_extension_table->scheme_peekc) +#define scheme_ungetc (scheme_extension_table->scheme_ungetc) +#define scheme_char_ready (scheme_extension_table->scheme_char_ready) +#define scheme_peekc_is_ungetc (scheme_extension_table->scheme_peekc_is_ungetc) +#define scheme_need_wakeup (scheme_extension_table->scheme_need_wakeup) +#define scheme_get_chars (scheme_extension_table->scheme_get_chars) +#define scheme_tell (scheme_extension_table->scheme_tell) +#define scheme_output_tell (scheme_extension_table->scheme_output_tell) +#define scheme_tell_line (scheme_extension_table->scheme_tell_line) +#define scheme_count_lines (scheme_extension_table->scheme_count_lines) +#define scheme_close_input_port (scheme_extension_table->scheme_close_input_port) +#define scheme_close_output_port (scheme_extension_table->scheme_close_output_port) +#define scheme_are_all_chars_ready (scheme_extension_table->scheme_are_all_chars_ready) +#define scheme_make_port_type (scheme_extension_table->scheme_make_port_type) +#define scheme_make_input_port (scheme_extension_table->scheme_make_input_port) +#define scheme_make_output_port (scheme_extension_table->scheme_make_output_port) +#define scheme_make_file_input_port (scheme_extension_table->scheme_make_file_input_port) +#define scheme_make_named_file_input_port (scheme_extension_table->scheme_make_named_file_input_port) +#define scheme_make_file_output_port (scheme_extension_table->scheme_make_file_output_port) +#define scheme_make_string_input_port (scheme_extension_table->scheme_make_string_input_port) +#define scheme_make_sized_string_input_port (scheme_extension_table->scheme_make_sized_string_input_port) +#define scheme_make_string_output_port (scheme_extension_table->scheme_make_string_output_port) +#define scheme_get_string_output (scheme_extension_table->scheme_get_string_output) +#define scheme_get_sized_string_output (scheme_extension_table->scheme_get_sized_string_output) +#define scheme_pipe (scheme_extension_table->scheme_pipe) +#define scheme_file_exists (scheme_extension_table->scheme_file_exists) +#define scheme_directory_exists (scheme_extension_table->scheme_directory_exists) +#define scheme_expand_filename (scheme_extension_table->scheme_expand_filename) +#define scheme_os_getcwd (scheme_extension_table->scheme_os_getcwd) +#define scheme_os_setcwd (scheme_extension_table->scheme_os_setcwd) +#define scheme_getdrive (scheme_extension_table->scheme_getdrive) +#define scheme_split_pathname (scheme_extension_table->scheme_split_pathname) +#define scheme_build_pathname (scheme_extension_table->scheme_build_pathname) +#define scheme_alloc_fdset_array (scheme_extension_table->scheme_alloc_fdset_array) +#define scheme_init_fdset_array (scheme_extension_table->scheme_init_fdset_array) +#define scheme_get_fdset (scheme_extension_table->scheme_get_fdset) +#define scheme_fdzero (scheme_extension_table->scheme_fdzero) +#define scheme_fdset (scheme_extension_table->scheme_fdset) +#define scheme_fdclr (scheme_extension_table->scheme_fdclr) +#define scheme_fdisset (scheme_extension_table->scheme_fdisset) +#define scheme_add_fd_handle (scheme_extension_table->scheme_add_fd_handle) +#define scheme_add_fd_eventmask (scheme_extension_table->scheme_add_fd_eventmask) +#define scheme_return_eof_for_error (scheme_extension_table->scheme_return_eof_for_error) +#define scheme_make_namespace (scheme_extension_table->scheme_make_namespace) +#define scheme_add_namespace_option (scheme_extension_table->scheme_add_namespace_option) +#define scheme_add_global (scheme_extension_table->scheme_add_global) +#define scheme_add_global_constant (scheme_extension_table->scheme_add_global_constant) +#define scheme_add_global_keyword (scheme_extension_table->scheme_add_global_keyword) +#define scheme_remove_global (scheme_extension_table->scheme_remove_global) +#define scheme_remove_global_constant (scheme_extension_table->scheme_remove_global_constant) +#define scheme_add_global_symbol (scheme_extension_table->scheme_add_global_symbol) +#define scheme_remove_global_symbol (scheme_extension_table->scheme_remove_global_symbol) +#define scheme_add_global_constant_symbol (scheme_extension_table->scheme_add_global_constant_symbol) +#define scheme_set_keyword (scheme_extension_table->scheme_set_keyword) +#define scheme_make_envunbox (scheme_extension_table->scheme_make_envunbox) +#define scheme_lookup_global (scheme_extension_table->scheme_lookup_global) +#define scheme_global_bucket (scheme_extension_table->scheme_global_bucket) +#define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket) +#define scheme_intern_symbol (scheme_extension_table->scheme_intern_symbol) +#define scheme_intern_exact_symbol (scheme_extension_table->scheme_intern_exact_symbol) +#define scheme_make_symbol (scheme_extension_table->scheme_make_symbol) +#define scheme_make_exact_symbol (scheme_extension_table->scheme_make_exact_symbol) +#define scheme_symbol_name (scheme_extension_table->scheme_symbol_name) +#define scheme_symbol_name_and_size (scheme_extension_table->scheme_symbol_name_and_size) +#define scheme_symbol_val (scheme_extension_table->scheme_symbol_val) +#define scheme_make_struct_values (scheme_extension_table->scheme_make_struct_values) +#define scheme_make_struct_names (scheme_extension_table->scheme_make_struct_names) +#define scheme_make_struct_type (scheme_extension_table->scheme_make_struct_type) +#define scheme_make_struct_instance (scheme_extension_table->scheme_make_struct_instance) +#define scheme_is_struct_instance (scheme_extension_table->scheme_is_struct_instance) +#define scheme_struct_ref (scheme_extension_table->scheme_struct_ref) +#define scheme_struct_set (scheme_extension_table->scheme_struct_set) +#ifndef NO_OBJECT_SYSTEM +#define scheme_is_subclass (scheme_extension_table->scheme_is_subclass) +#define scheme_is_implementation (scheme_extension_table->scheme_is_implementation) +#define scheme_is_interface_extension (scheme_extension_table->scheme_is_interface_extension) +#define scheme_is_a (scheme_extension_table->scheme_is_a) +#define scheme_get_class_name (scheme_extension_table->scheme_get_class_name) +#define scheme_get_interface_name (scheme_extension_table->scheme_get_interface_name) +#define scheme_make_object (scheme_extension_table->scheme_make_object) +#define scheme_make_uninited_object (scheme_extension_table->scheme_make_uninited_object) +#define scheme_find_ivar (scheme_extension_table->scheme_find_ivar) +#define scheme_make_class (scheme_extension_table->scheme_make_class) +#define scheme_add_method (scheme_extension_table->scheme_add_method) +#define scheme_add_method_w_arity (scheme_extension_table->scheme_add_method_w_arity) +#define scheme_made_class (scheme_extension_table->scheme_made_class) +#define scheme_class_to_interface (scheme_extension_table->scheme_class_to_interface) +#define scheme_make_class_assembly (scheme_extension_table->scheme_make_class_assembly) +#define scheme_create_class (scheme_extension_table->scheme_create_class) +#define scheme_make_interface_assembly (scheme_extension_table->scheme_make_interface_assembly) +#define scheme_create_interface (scheme_extension_table->scheme_create_interface) +#define scheme_apply_generic_data (scheme_extension_table->scheme_apply_generic_data) +#define scheme_get_generic_data (scheme_extension_table->scheme_get_generic_data) +#endif +#define scheme_invoke_unit (scheme_extension_table->scheme_invoke_unit) +#define scheme_assemble_compound_unit (scheme_extension_table->scheme_assemble_compound_unit) +#define scheme_make_compound_unit (scheme_extension_table->scheme_make_compound_unit) +#define scheme_get_unit_name (scheme_extension_table->scheme_get_unit_name) +#define scheme_eq (scheme_extension_table->scheme_eq) +#define scheme_eqv (scheme_extension_table->scheme_eqv) +#define scheme_equal (scheme_extension_table->scheme_equal) +#define scheme_build_list (scheme_extension_table->scheme_build_list) +#define scheme_list_length (scheme_extension_table->scheme_list_length) +#define scheme_proper_list_length (scheme_extension_table->scheme_proper_list_length) +#define scheme_alloc_list (scheme_extension_table->scheme_alloc_list) +#define scheme_map_1 (scheme_extension_table->scheme_map_1) +#define scheme_car (scheme_extension_table->scheme_car) +#define scheme_cdr (scheme_extension_table->scheme_cdr) +#define scheme_cadr (scheme_extension_table->scheme_cadr) +#define scheme_caddr (scheme_extension_table->scheme_caddr) +#define scheme_vector_to_list (scheme_extension_table->scheme_vector_to_list) +#define scheme_list_to_vector (scheme_extension_table->scheme_list_to_vector) +#define scheme_append (scheme_extension_table->scheme_append) +#define scheme_box (scheme_extension_table->scheme_box) +#define scheme_unbox (scheme_extension_table->scheme_unbox) +#define scheme_set_box (scheme_extension_table->scheme_set_box) +#define scheme_make_weak_box (scheme_extension_table->scheme_make_weak_box) +#define scheme_load (scheme_extension_table->scheme_load) +#define scheme_load_extension (scheme_extension_table->scheme_load_extension) +#define scheme_register_extension_global (scheme_extension_table->scheme_register_extension_global) +#define scheme_get_milliseconds (scheme_extension_table->scheme_get_milliseconds) +#define scheme_get_process_milliseconds (scheme_extension_table->scheme_get_process_milliseconds) +#define scheme_rep (scheme_extension_table->scheme_rep) +#define scheme_banner (scheme_extension_table->scheme_banner) +#define scheme_version (scheme_extension_table->scheme_version) +#define scheme_check_proc_arity (scheme_extension_table->scheme_check_proc_arity) +#define scheme_make_provided_string (scheme_extension_table->scheme_make_provided_string) +#define scheme_make_args_string (scheme_extension_table->scheme_make_args_string) +#define scheme_no_dumps (scheme_extension_table->scheme_no_dumps) +#define scheme_system_library_subpath (scheme_extension_table->scheme_system_library_subpath) diff --git a/collects/mzscheme/include/schexn.h b/collects/mzscheme/include/schexn.h new file mode 100644 index 00000000..dc35573d --- /dev/null +++ b/collects/mzscheme/include/schexn.h @@ -0,0 +1,170 @@ +/* This file was generated by makeexn */ +#ifndef _MZEXN_DEFINES +#define _MZEXN_DEFINES + +enum { + MZEXN, + MZEXN_USER, + MZEXN_VARIABLE, + MZEXN_VARIABLE_KEYWORD, + MZEXN_APPLICATION, + MZEXN_APPLICATION_ARITY, + MZEXN_APPLICATION_TYPE, + MZEXN_APPLICATION_MISMATCH, + MZEXN_APPLICATION_DIVIDE_BY_ZERO, + MZEXN_APPLICATION_CONTINUATION, + MZEXN_ELSE, + MZEXN_STRUCT, + MZEXN_OBJECT, + MZEXN_UNIT, + MZEXN_SYNTAX, + MZEXN_READ, + MZEXN_READ_EOF, + MZEXN_I_O, + MZEXN_I_O_PORT, + MZEXN_I_O_PORT_READ, + MZEXN_I_O_PORT_WRITE, + MZEXN_I_O_PORT_CLOSED, + MZEXN_I_O_PORT_USER, + MZEXN_I_O_FILESYSTEM, + MZEXN_I_O_TCP, + MZEXN_THREAD, + MZEXN_MISC, + MZEXN_MISC_UNSUPPORTED, + MZEXN_MISC_USER_BREAK, + MZEXN_MISC_OUT_OF_MEMORY, + MZEXN_OTHER +}; + +#endif + +#ifdef _MZEXN_TABLE + +#define MZEXN_MAXARGS 4 + +#ifdef GLOBAL_EXN_ARRAY +static exn_rec exn_table[] = { + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 4, NULL, NULL, 0 }, + { 4, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 4, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 }, + { 3, NULL, NULL, 0 }, + { 2, NULL, NULL, 0 } +}; +#else +static exn_rec *exn_table; +#endif + +#endif + +#ifdef _MZEXN_PRESETUP + +#ifndef GLOBAL_EXN_ARRAY + exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER); + exn_table[MZEXN].args = 2; + exn_table[MZEXN_USER].args = 2; + exn_table[MZEXN_VARIABLE].args = 3; + exn_table[MZEXN_VARIABLE_KEYWORD].args = 3; + exn_table[MZEXN_APPLICATION].args = 3; + exn_table[MZEXN_APPLICATION_ARITY].args = 4; + exn_table[MZEXN_APPLICATION_TYPE].args = 4; + exn_table[MZEXN_APPLICATION_MISMATCH].args = 3; + exn_table[MZEXN_APPLICATION_DIVIDE_BY_ZERO].args = 3; + exn_table[MZEXN_APPLICATION_CONTINUATION].args = 3; + exn_table[MZEXN_ELSE].args = 2; + exn_table[MZEXN_STRUCT].args = 2; + exn_table[MZEXN_OBJECT].args = 2; + exn_table[MZEXN_UNIT].args = 2; + exn_table[MZEXN_SYNTAX].args = 3; + exn_table[MZEXN_READ].args = 3; + exn_table[MZEXN_READ_EOF].args = 3; + exn_table[MZEXN_I_O].args = 2; + exn_table[MZEXN_I_O_PORT].args = 3; + exn_table[MZEXN_I_O_PORT_READ].args = 3; + exn_table[MZEXN_I_O_PORT_WRITE].args = 3; + exn_table[MZEXN_I_O_PORT_CLOSED].args = 3; + exn_table[MZEXN_I_O_PORT_USER].args = 3; + exn_table[MZEXN_I_O_FILESYSTEM].args = 4; + exn_table[MZEXN_I_O_TCP].args = 2; + exn_table[MZEXN_THREAD].args = 2; + exn_table[MZEXN_MISC].args = 2; + exn_table[MZEXN_MISC_UNSUPPORTED].args = 2; + exn_table[MZEXN_MISC_USER_BREAK].args = 3; + exn_table[MZEXN_MISC_OUT_OF_MEMORY].args = 2; +#endif + +#endif + +#ifdef _MZEXN_DECL_FIELDS + +static const char *MZEXN_FIELDS[2] = { "message", "continuation-marks" }; +static const char *MZEXN_VARIABLE_FIELDS[1] = { "id" }; +static const char *MZEXN_APPLICATION_FIELDS[1] = { "value" }; +static const char *MZEXN_APPLICATION_ARITY_FIELDS[1] = { "expected" }; +static const char *MZEXN_APPLICATION_TYPE_FIELDS[1] = { "expected" }; +static const char *MZEXN_SYNTAX_FIELDS[1] = { "expr" }; +static const char *MZEXN_READ_FIELDS[1] = { "port" }; +static const char *MZEXN_I_O_PORT_FIELDS[1] = { "port" }; +static const char *MZEXN_I_O_FILESYSTEM_FIELDS[2] = { "pathname", "detail" }; +static const char *MZEXN_MISC_USER_BREAK_FIELDS[1] = { "continuation" }; + +#endif + +#ifdef _MZEXN_SETUP + + SETUP_STRUCT(MZEXN, NULL, "exn", 2, MZEXN_FIELDS) + SETUP_STRUCT(MZEXN_USER, EXN_PARENT(MZEXN), "exn:user", 0, NULL) + SETUP_STRUCT(MZEXN_VARIABLE, EXN_PARENT(MZEXN), "exn:variable", 1, MZEXN_VARIABLE_FIELDS) + SETUP_STRUCT(MZEXN_VARIABLE_KEYWORD, EXN_PARENT(MZEXN_VARIABLE), "exn:variable:keyword", 0, NULL) + SETUP_STRUCT(MZEXN_APPLICATION, EXN_PARENT(MZEXN), "exn:application", 1, MZEXN_APPLICATION_FIELDS) + SETUP_STRUCT(MZEXN_APPLICATION_ARITY, EXN_PARENT(MZEXN_APPLICATION), "exn:application:arity", 1, MZEXN_APPLICATION_ARITY_FIELDS) + SETUP_STRUCT(MZEXN_APPLICATION_TYPE, EXN_PARENT(MZEXN_APPLICATION), "exn:application:type", 1, MZEXN_APPLICATION_TYPE_FIELDS) + SETUP_STRUCT(MZEXN_APPLICATION_MISMATCH, EXN_PARENT(MZEXN_APPLICATION), "exn:application:mismatch", 0, NULL) + SETUP_STRUCT(MZEXN_APPLICATION_DIVIDE_BY_ZERO, EXN_PARENT(MZEXN_APPLICATION), "exn:application:divide-by-zero", 0, NULL) + SETUP_STRUCT(MZEXN_APPLICATION_CONTINUATION, EXN_PARENT(MZEXN_APPLICATION), "exn:application:continuation", 0, NULL) + SETUP_STRUCT(MZEXN_ELSE, EXN_PARENT(MZEXN), "exn:else", 0, NULL) + SETUP_STRUCT(MZEXN_STRUCT, EXN_PARENT(MZEXN), "exn:struct", 0, NULL) + SETUP_STRUCT(MZEXN_OBJECT, EXN_PARENT(MZEXN), "exn:object", 0, NULL) + SETUP_STRUCT(MZEXN_UNIT, EXN_PARENT(MZEXN), "exn:unit", 0, NULL) + SETUP_STRUCT(MZEXN_SYNTAX, EXN_PARENT(MZEXN), "exn:syntax", 1, MZEXN_SYNTAX_FIELDS) + SETUP_STRUCT(MZEXN_READ, EXN_PARENT(MZEXN), "exn:read", 1, MZEXN_READ_FIELDS) + SETUP_STRUCT(MZEXN_READ_EOF, EXN_PARENT(MZEXN_READ), "exn:read:eof", 0, NULL) + SETUP_STRUCT(MZEXN_I_O, EXN_PARENT(MZEXN), "exn:i/o", 0, NULL) + SETUP_STRUCT(MZEXN_I_O_PORT, EXN_PARENT(MZEXN_I_O), "exn:i/o:port", 1, MZEXN_I_O_PORT_FIELDS) + SETUP_STRUCT(MZEXN_I_O_PORT_READ, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:read", 0, NULL) + SETUP_STRUCT(MZEXN_I_O_PORT_WRITE, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:write", 0, NULL) + SETUP_STRUCT(MZEXN_I_O_PORT_CLOSED, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:closed", 0, NULL) + SETUP_STRUCT(MZEXN_I_O_PORT_USER, EXN_PARENT(MZEXN_I_O_PORT), "exn:i/o:port:user", 0, NULL) + SETUP_STRUCT(MZEXN_I_O_FILESYSTEM, EXN_PARENT(MZEXN_I_O), "exn:i/o:filesystem", 2, MZEXN_I_O_FILESYSTEM_FIELDS) + SETUP_STRUCT(MZEXN_I_O_TCP, EXN_PARENT(MZEXN_I_O), "exn:i/o:tcp", 0, NULL) + SETUP_STRUCT(MZEXN_THREAD, EXN_PARENT(MZEXN), "exn:thread", 0, NULL) + SETUP_STRUCT(MZEXN_MISC, EXN_PARENT(MZEXN), "exn:misc", 0, NULL) + SETUP_STRUCT(MZEXN_MISC_UNSUPPORTED, EXN_PARENT(MZEXN_MISC), "exn:misc:unsupported", 0, NULL) + SETUP_STRUCT(MZEXN_MISC_USER_BREAK, EXN_PARENT(MZEXN_MISC), "exn:misc:user-break", 1, MZEXN_MISC_USER_BREAK_FIELDS) + SETUP_STRUCT(MZEXN_MISC_OUT_OF_MEMORY, EXN_PARENT(MZEXN_MISC), "exn:misc:out-of-memory", 0, NULL) + +#endif diff --git a/collects/mzscheme/include/schvers.h b/collects/mzscheme/include/schvers.h new file mode 100644 index 00000000..79f7b6c1 --- /dev/null +++ b/collects/mzscheme/include/schvers.h @@ -0,0 +1,8 @@ + +#ifdef MZSCHEME_SOMETHING_OMITTED +# define SPECIAL_TAG "-special" +#else +# define SPECIAL_TAG "" +#endif + +#define VERSION "102/13" SPECIAL_TAG diff --git a/collects/mzscheme/include/sconfig.h b/collects/mzscheme/include/sconfig.h new file mode 100644 index 00000000..609e044d --- /dev/null +++ b/collects/mzscheme/include/sconfig.h @@ -0,0 +1,1383 @@ + +/* + Configuration for compiling MzScheme + + If you want to set all the flags externally (on the command line + with -D or some other compiler-dependent way), then define + FLAGS_ALREADY_SET, and this file will be ignored. + + One flag cannot be set in this file: INCLUDE_WITHOUT_PATHS. + Define this flag if your compiler doesn't like #include + statements with relative paths using ".." and "/". (You will + have to #define this for Macintosh CodeWarrior in the project + header.) + + The best flag settings are already provided for some auto-detected + architecture/system/compilers. Otherwise, the default settings + are generic Unix. Send other architecture/system/compiler-specific + info to "plt-bugs@cs.rice.edu". +*/ + +#ifndef FLAGS_ALREADY_SET + +/*************** (BEGIN PLATFORM-INDEPENDENT OPTIONS) *************/ + + /***********************/ + /* Language Extensions */ +/***********************/ + + /* NO_OBJECT_SYSTEM removes MzScheme's object system. */ + + /* NO_REGEXP_UTILS removes MzScheme's regular expression utilities. */ + + /* NO_TCP_SUPPORT removes MzScheme's TCP utilities */ + + /* NO_SCHEME_THREADS removes MzScheme's threads from the Scheme user. + In this case, custodian-shutdown-all doesn't kill threads. */ + + /* NO_FILE_SYSTEM_UTILS removes most file system utilities. */ + +#if defined(NO_FILE_SYSTEM_UTILS) \ + || defined(NO_OBJECT_SYSTEM) \ + || defined(NO_TCP_SUPPORT) \ + || defined(NO_REGEXP_UTILS) \ + || defined(NO_SCHEME_THREADS) +# define MZSCHEME_SOMETHING_OMITTED +#endif + + /*******************************/ + /* Evaluator Tuning Parameters */ +/*******************************/ + +#define SCHEME_STACK_SIZE 5000 + + /* SCHEME_STACK_SIZE sets the size of stack segments for Scheme + variables. */ + +/**************** (END PLATFORM-INDEPENDENT OPTIONS) **************/ + + + +/******** (BEGIN KNOWN ARCHITECTURE/SYSTEM CONFIGURATIONS) ********/ + + /*************** OSKit with Linux/gcc *****************/ + +#if defined(OSKIT) + +# define SYSTEM_TYPE_NAME "oskit" + +# define STACK_GROWS_DOWN +# define DO_STACK_CHECK +# ifndef OSKIT_TEST +# define OSKIT_FIXED_STACK_BOUNDS +# else +# define ASSUME_FIXED_STACK_SIZE +# define FIXED_STACK_SIZE 65500 +# endif +# define STACK_SAFETY_MARGIN 10000 + +# define UNIX_FILE_SYSTEM +# define NO_UNIX_USERS + +# define TIME_SYNTAX +# define DIR_FUNCTION +# define DIRENT_NO_NAMLEN +# define GETENV_FUNCTION + +# ifndef OSKIT_TEST +# define HAS_FREEBSD_IOB +# else +# define HAS_LINUX_IOB +# endif +# define USE_OSKIT_CONSOLE +# define FILES_HAVE_FDS +# define FIXED_FD_LIMIT 256 +# define USE_UNIX_SOCKETS_TCP +# define USE_FCNTL_O_NONBLOCK + +# ifndef OSKIT_TEST +# define INCLUDE_OSKIT_SOCKET +# define MZ_PF_INET OSKIT_PF_INET +# define PROTOENT_IS_INT IPPROTO_TCP +# endif + +# define NO_USLEEP +# define NO_SLEEP +# define USER_TIME_IS_CLOCK + +# define SIGSET_IS_SIGNAL + +# define UNISTD_INCLUDE + +# define USE_TM_GMTOFF_FIELD + +# define FLAGS_ALREADY_SET + +#else /* >>>>>>> close after all platforms <<<<<<<<<< */ + + /************** SunOS/Solaris with gcc ****************/ + +#if defined(sun) + +# include "uconfig.h" + +# define STACK_GROWS_DOWN + +# define USE_EXPLICT_FP_FORM_CHECK +# define POW_HANDLES_INF_CORRECTLY + +# include +# ifdef ECHRNG +/* Solaris */ +# if defined(i386) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-solaris" +# else +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-solaris" +# endif +# define DIRENT_NO_NAMLEN +# define NO_USLEEP +# define USE_ULIMIT +# define USE_FCNTL_O_NONBLOCK +# define SOME_FDS_ARE_NOT_SELECTABLE +# define NEED_RESET_STDOUT_BLOCKING +# define USE_TIMEZONE_AND_ALTZONE_VAR + +# ifdef SOLARIS_THREADS +# define MZ_REAL_THREADS +# define MZ_USE_SOLARIS_THREADS + +#ifdef __cplusplus +extern "C" { +#endif +void *scheme_solaris_init_threads(void); +void scheme_solaris_create_thread(void (*f)(void *), void *data, unsigned long *stackend, void **thp); +void scheme_solaris_exit_thread(); +void scheme_solaris_break_thread(void *th); +struct Scheme_Process *scheme_solaris_get_current_process(); +void scheme_solaris_set_current_process(struct Scheme_Process *); +void *scheme_solaris_make_mutex(); +void scheme_solaris_free_mutex(void *); +void scheme_solaris_lock_mutex(void *); +void scheme_solaris_unlock_mutex(void *); +void *scheme_solaris_make_semaphore(int init); +void scheme_solaris_free_semaphore(void *); +int scheme_solaris_semaphore_up(void *); +int scheme_solaris_semaphore_down_breakable(void *); +int scheme_solaris_semaphore_try_down(void *); +#ifdef __cplusplus +} +#endif + +#define SCHEME_INIT_THREADS() scheme_solaris_init_threads() +#define SCHEME_CREATE_THREAD(f, data, slimit, thp) scheme_solaris_create_thread(f, data, slimit, thp) +#define SCHEME_EXIT_THREAD() scheme_solaris_exit_thread() +#define SCHEME_BREAK_THREAD(th) scheme_solaris_break_thread(th) +#define SCHEME_GET_CURRENT_PROCESS() scheme_solaris_get_current_process() +#define SCHEME_SET_CURRENT_PROCESS(p) scheme_solaris_set_current_process(p) +#define SCHEME_MAKE_MUTEX() scheme_solaris_make_mutex() +#define SCHEME_FREE_MUTEX(m) scheme_solaris_free_mutex(m) +#define SCHEME_LOCK_MUTEX(m) scheme_solaris_lock_mutex(m) +#define SCHEME_UNLOCK_MUTEX(m) scheme_solaris_unlock_mutex(m) +#define SCHEME_MAKE_SEMA(init) scheme_solaris_make_semaphore(init) +#define SCHEME_FREE_SEMA(s) scheme_solaris_free_semaphore(s) +#define SCHEME_SEMA_UP(s) scheme_solaris_semaphore_up(s) +#define SCHEME_SEMA_DOWN_BREAKABLE(s) scheme_solaris_semaphore_down_breakable(s) +#define SCHEME_SEMA_TRY_DOWN(s) scheme_solaris_semaphore_try_down(s) +# endif +# else +/* SunOS4 */ +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc-sunos4" +# define SIGSET_IS_SIGNAL +# define USE_TM_GMTOFF_FIELD +# endif + +# define FLAGS_ALREADY_SET + +#endif + + /************** RS6000/AIX with gcc or xlc ****************/ + +# if defined(_IBMR2) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "rs6k-aix" + +# include "uconfig.h" +# undef USE_FCHDIR + +# define STACK_GROWS_DOWN +# define UNIX_LIMIT_STACK 33554944 + +# define SELECT_INCLUDE + +# define POW_HANDLES_INF_CORRECTLY + +# define USE_FCNTL_O_NONBLOCK + +# define USE_TIMEZONE_VAR_W_DLS + +# define FLAGS_ALREADY_SET + +#endif + + /************** Linux with gcc ****************/ + +#if defined(linux) + +# if defined(i386) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-linux" +# define REGISTER_POOR_MACHINE +# endif +# if defined(powerpc) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-linux" +# endif +# if defined(__mc68000__) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "m68k-linux" +# endif +# ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "unknown-linux" +# endif + +# include "uconfig.h" +# undef HAS_STANDARD_IOB +# ifndef __ELF__ +# undef UNIX_DYNAMIC_LOAD +# endif + +# define DIRENT_NO_NAMLEN + +# define HAS_LINUX_IOB + +# define STACK_GROWS_DOWN + +# define USE_IEEE_FP_PREDS +# define USE_EXPLICT_FP_FORM_CHECK + +# define SIGSET_IS_SIGNAL +# define SIGSET_NEEDS_REINSTALL + +# define USE_DYNAMIC_FDSET_SIZE + +# define USE_TIMEZONE_VAR + +# ifdef LINUX_THREADS +# define MZ_USE_PTHREADS +# define MZ_USE_LINUX_PTHREADS + /* More configuration below for pthreads */ +# endif + +# define FLAGS_ALREADY_SET + +#endif + + /************** x86/OpenBSD with gcc ****************/ + /* Thanks to Bengt Kleberg */ + +# if defined(__OpenBSD__) && defined(i386) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-openbsd" + +# include "uconfig.h" +# undef HAS_STANDARD_IOB + +# define HAS_BSD_IOB + +# define STACK_GROWS_DOWN + +# define UNDERSCORE_DYNLOAD_SYMBOL_PREFIX + +# define USE_IEEE_FP_PREDS +# define POW_HANDLES_INF_CORRECTLY + +# define USE_DYNAMIC_FDSET_SIZE + +# define SIGSET_IS_SIGNAL + +# define REGISTER_POOR_MACHINE + +# define USE_TM_GMTOFF_FIELD + +# define FLAGS_ALREADY_SET + +#endif + + /************** x86/FreeBSD with gcc ****************/ + +# if defined(__FreeBSD__) && defined(i386) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-freebsd" + +# include "uconfig.h" +# undef HAS_STANDARD_IOB + +# define HAS_BSD_IOB + +# define STACK_GROWS_DOWN + +# ifdef FREEBSD_VERSION_2x +# define UNDERSCORE_DYNLOAD_SYMBOL_PREFIX +# endif + +# define USE_IEEE_FP_PREDS +# define FREEBSD_CONTROL_387 +# define POW_HANDLES_INF_CORRECTLY + +# define USE_DYNAMIC_FDSET_SIZE + +# define SIGSET_IS_SIGNAL + +# define USE_TM_GMTOFF_FIELD + +# define REGISTER_POOR_MACHINE + +# define FLAGS_ALREADY_SET + +#endif + + /************** BeOS with egcs (and CodeWarrior?) ****************/ + +#if defined(__BEOS__) + +# ifdef __INTEL__ +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i586-beos" +# else +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-beos" +#endif + +# include "uconfig.h" +# undef UNIX_DYNAMIC_LOAD +# undef UNIX_FIND_STACK_BOUNDS +# undef USE_GETRUSAGE +# undef SYSTEM_TYPE_NAME + +# define SYSTEM_TYPE_NAME "beos" + +# define BEOS_IMAGE_DYNAMIC_LOAD +# define LINK_EXTENSIONS_BY_TABLE + +# undef HAS_STANDARD_IOB +# undef FILES_HAVE_FDS +# undef USE_FD_PORTS +# define USE_BEOS_PORT_THREADS + +# undef UNIX_PROCESSES +# define BEOS_PROCESSES + +# define USE_FCNTL_O_NONBLOCK +# define MZ_PF_INET AF_INET +# define PROTOENT_IS_INT IPPROTO_TCP +# define CANT_SET_SOCKET_BUFSIZE +# define SEND_IS_NEVER_TOO_BIG + +# define USE_BEOS_SNOOZE + +# define SIGSET_IS_SIGNAL + +# define DIRENT_NO_NAMLEN + +# define BEOS_FIND_STACK_BOUNDS +# define STACK_GROWS_DOWN + +# define USE_TM_GMTOFF_FIELD + +# ifdef __INTEL__ +# define REGISTER_POOR_MACHINE +# endif + +# define FLAGS_ALREADY_SET + +#endif + + /************** SGI/IRIX with SGI cc ****************/ + +#if (defined(mips) || defined(__mips)) \ + && !(defined(ultrix) || defined(__ultrix)) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "mips-irix" + +# include "uconfig.h" + +# define STACK_GROWS_DOWN + +# define DIRENT_NO_NAMLEN + +# define BSTRING_INCLUDE + +# define DEFEAT_FP_COMP_OPTIMIZATION +# define POW_HANDLES_INF_CORRECTLY + +# define NO_INLINE_KEYWORD + +# define NO_USLEEP +# define USE_FCNTL_O_NONBLOCK + +# define USE_TIMEZONE_AND_ALTZONE_VAR + +# ifdef MZ_X_THREADS +# ifndef MZ_FAKE_THREADS +# define MZ_FAKE_THREADS +# endif +# endif + +# ifndef MZ_FAKE_THREADS +# ifdef IRIX_SPROCS +# define MZ_REAL_THREADS +# define MZ_USE_IRIX_SPROCS + +#ifdef __cplusplus +extern "C" { +#endif +void *scheme_sproc_init_threads(void); +void scheme_sproc_create_thread(void (*f)(void *), void *data, unsigned long *stackend, void **thp); +void scheme_sproc_exit_thread(); +void scheme_sproc_break_thread(void *); +struct Scheme_Process *scheme_sproc_get_current_process(); +void scheme_sproc_set_current_process(struct Scheme_Process *); +void *scheme_sproc_make_mutex(); +void scheme_sproc_free_mutex(void *); +void scheme_sproc_lock_mutex(void *); +void scheme_sproc_unlock_mutex(void *); +void *scheme_sproc_make_semaphore(int init); +void scheme_sproc_free_semaphore(void *); +int scheme_sproc_semaphore_up(void *); +int scheme_sproc_semaphore_down_breakable(void *); +int scheme_sproc_semaphore_try_down(void *); +#ifdef __cplusplus +} +#endif + +#define SCHEME_INIT_THREADS() scheme_sproc_init_threads() +#define SCHEME_CREATE_THREAD(f, data, slimit, thp) scheme_sproc_create_thread(f, data, slimit, thp) +#define SCHEME_EXIT_THREAD() scheme_sproc_exit_thread() +#define SCHEME_BREAK_THREAD(th) scheme_sproc_break_thread(th) +#define SCHEME_GET_CURRENT_PROCESS() scheme_sproc_get_current_process() +#define SCHEME_SET_CURRENT_PROCESS(p) scheme_sproc_set_current_process(p) +#define SCHEME_MAKE_MUTEX() scheme_sproc_make_mutex() +#define SCHEME_FREE_MUTEX(m) scheme_sproc_free_mutex(m) +#define SCHEME_LOCK_MUTEX(m) scheme_sproc_lock_mutex(m) +#define SCHEME_UNLOCK_MUTEX(m) scheme_sproc_unlock_mutex(m) +#define SCHEME_MAKE_SEMA(init) scheme_sproc_make_semaphore(init) +#define SCHEME_FREE_SEMA(s) scheme_sproc_free_semaphore(s) +#define SCHEME_SEMA_UP(s) scheme_sproc_semaphore_up(s) +#define SCHEME_SEMA_DOWN_BREAKABLE(s) scheme_sproc_semaphore_down_breakable(s) +#define SCHEME_SEMA_TRY_DOWN(s) scheme_sproc_semaphore_try_down(s) +# endif /* IRIX_SPROCS */ +# endif /* !MZ_FAKE_THREADS */ + +# define FLAGS_ALREADY_SET + +#endif + + /************** Ultrix with gcc ****************/ + +#if defined(ultrix) || defined(__ultrix) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "mips-ultrix" + +# include "uconfig.h" +# undef UNIX_DYNAMIC_LOAD +# undef USE_FCHDIR + +# define DIRENT_NO_NAMLEN + +# define STACK_GROWS_DOWN + +# define NO_USLEEP +# define USE_FCNTL_O_NONBLOCK + +# define FLAGS_ALREADY_SET + +#endif + + /************** ALPHA/OSF1 with gcc ****************/ + +#if defined(__alpha) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-osf1" + +# include "uconfig.h" + +# define STACK_GROWS_DOWN + +# define SIXTY_FOUR_BIT_INTEGERS + +# define ALPHA_CONTROL_FP + +# define FLAGS_ALREADY_SET + +#endif + + /************** HP/UX with cc ****************/ + +#if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "parisc-hpux" + +# include "uconfig.h" + +# undef UNIX_DYNAMIC_LOAD +# define SHL_DYNAMIC_LOAD + +# define STACK_GROWS_UP + +# define SOME_FDS_ARE_NOT_SELECTABLE + +# define USE_SYSCALL_GETRUSAGE + +# define USE_DIVIDE_MAKE_INFINITY +# define USE_IEEE_FP_PREDS +# define USE_EXPLICT_FP_FORM_CHECK +# define ZERO_MINUS_ZERO_IS_POS_ZERO + +# define NO_INLINE_KEYWORD + +# define USE_ULIMIT + +# define USE_TIMEZONE_VAR_W_DLS + +# define FLAGS_ALREADY_SET + +#endif + + /************** x86/SCO Unix with gcc ****************/ + /* Contributed by Atanas Ivanov */ + +#if defined(_M_XENIX) && defined(_M_SYSV) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sco-i386" + +# include "uconfig.h" +# undef HAS_STANDARD_IOB +#ifndef __ELF__ +# undef UNIX_DYNAMIC_LOAD +#endif + +# define DIRENT_NO_NAMLEN + +# define HAS_SCO_IOB + +# define STACK_GROWS_DOWN + +# define USE_SCO_IEEE_FP_PREDS +# define USE_EXPLICT_FP_FORM_CHECK +# define USE_FCNTL_O_NONBLOCK + +# define REGISTER_POOR_MACHINE + +# define FLAGS_ALREADY_SET + +#endif + + /******** Windows with MS Visual C++ or CYGWIN **********/ + /* See the "windows" directory for more MSVC details. */ + /* MzScheme is probably no longer Borland-friendly, */ + /* since it currently relies on one MSVC-style inline */ + /* assembly file. Nevertheless, the old flags and */ + /* instructions have been preserved. */ + +#if (defined(__BORLANDC__) || defined(_MSC_VER) || defined(__CYGWIN__)) \ + && (defined(__WIN32__) || defined(WIN32) || defined(_WIN32)) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "win32\\i386" + +# define SYSTEM_TYPE_NAME "windows" +# define DOS_FILE_SYSTEM +# if defined(_MSC_VER) +# define NO_READDIR +# define USE_FINDFIRST +# define NO_READLINK +# define MKDIR_NO_MODE_FLAG +# endif +# if defined(__BORLANDC__) +# define DIRENT_NO_NAMLEN +# define NO_READLINK +# define MKDIR_NO_MODE_FLAG +# endif +# if defined(__CYGWIN__) +# define USE_GET_CURRENT_DIRECTORY +# define USE_WINDOWS_FIND_FIRST +# define DIRENT_NO_NAMLEN +# endif + +# define TIME_SYNTAX +# ifdef __CYGWIN__ +# define USE_PLAIN_TIME +# define USE_TOD_FOR_TIMEZONE +# else +# define USE_FTIME +# define USE_TIMEZONE_VAR_W_DLS +# endif +# define GETENV_FUNCTION +# define DIR_FUNCTION + +# define STACK_GROWS_DOWN +# define DO_STACK_CHECK +# define WINDOWS_FIND_STACK_BOUNDS + +# define USE_MZ_SETJMP +# define GC_MIGHT_USE_REGISTERED_STATICS + +# define WINDOWS_DYNAMIC_LOAD +# define LINK_EXTENSIONS_BY_TABLE + +#if defined(_MSC_VER) +# define NAN_EQUALS_ANYTHING +# define POW_HANDLES_INF_CORRECTLY +#endif +#ifdef __CYGWIN__ +# define USE_DIVIDE_MAKE_INFINITY +#endif + +# define IO_INCLUDE +# define DONT_IGNORE_PIPE_SIGNAL + +# define PROCESS_FUNCTION +#ifdef __CYGWIN__ +# define UNIX_PROCESSES +# define FILES_HAVE_FDS +# define HAS_CYGWIN_IOB +# define SIGCHILD_DOESNT_INTERRUPT_SELECT +#else +# define NO_SLEEP +# define WINDOWS_PROCESSES +# define DETECT_WIN32_CONSOLE_STDIN +#endif + +# define SIGSET_IS_SIGNAL +# define SIGSET_NEEDS_REINSTALL + +#ifdef __CYGWIN__ +# define USE_UNIX_SOCKETS_TCP +# define CANT_SET_SOCKET_BUFSIZE +# define NO_NEED_FOR_BEGINTHREAD +# define USE_CREATE_PIPE +#else +# define USE_WINSOCK_TCP +#endif + +# ifdef WIN32_THREADS +# define MZ_REAL_THREADS +# define MZ_USE_WIN32_THREADS +#ifdef __cplusplus +extern "C" { +#endif +void *scheme_win32_init_threads(void); +void scheme_win32_create_thread(void (*f)(void *), void *data, unsigned long *stackend, void **thp); +void scheme_win32_exit_thread(); +void scheme_win32_break_thread(void *th); +struct Scheme_Process *scheme_win32_get_current_process(); +void scheme_win32_set_current_process(struct Scheme_Process *); +void *scheme_win32_make_mutex(); +void scheme_win32_free_mutex(void *s); +void scheme_win32_lock_mutex(void *); +void scheme_win32_unlock_mutex(void *); +void *scheme_win32_make_semaphore(int init); +void scheme_win32_free_semaphore(void *s); +int scheme_win32_semaphore_up(void *); +int scheme_win32_semaphore_down_breakable(void *); +int scheme_win32_semaphore_try_down(void *); +#ifdef __cplusplus +} +#endif + +#define SCHEME_INIT_THREADS() scheme_win32_init_threads() +#define SCHEME_CREATE_THREAD(f, data, slimit, thp) scheme_win32_create_thread(f, data, slimit, thp) +#define SCHEME_BREAK_THREAD(th) scheme_win32_break_thread(th) +#define SCHEME_EXIT_THREAD() scheme_win32_exit_thread() +#define SCHEME_GET_CURRENT_PROCESS() scheme_win32_get_current_process() +#define SCHEME_SET_CURRENT_PROCESS(p) scheme_win32_set_current_process(p) +#define SCHEME_MAKE_MUTEX() scheme_win32_make_mutex() +#define SCHEME_FREE_MUTEX(m) scheme_win32_free_mutex(m) +#define SCHEME_LOCK_MUTEX(m) scheme_win32_lock_mutex(m) +#define SCHEME_UNLOCK_MUTEX(m) scheme_win32_unlock_mutex(m) +#define SCHEME_MAKE_SEMA(init) scheme_win32_make_semaphore(init) +#define SCHEME_FREE_SEMA(s) scheme_win32_free_semaphore(s) +#define SCHEME_SEMA_UP(s) scheme_win32_semaphore_up(s) +#define SCHEME_SEMA_DOWN_BREAKABLE(s) scheme_win32_semaphore_down_breakable(s) +#define SCHEME_SEMA_TRY_DOWN(s) scheme_win32_semaphore_try_down(s) +# endif + +/* MS Visual C++ likes underscore prefixes */ +#if defined(_MSC_VER) +# define MSC_IZE(x) _ ## x +# define DIRECT_INCLUDE +#endif + +#if defined(__BORLANDC__) +# define DIR_INCLUDE +#endif + +# define REGISTER_POOR_MACHINE + +# define WINLATIN_CHAR_SET + +# define FLAGS_ALREADY_SET + +#endif + + /************ Macintosh with CodeWarrior *************/ + +#if defined(__MWERKS__) && !defined(__BEOS__) && !defined(__palmos__) + +# if defined(__POWERPC__) +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-mac" +# else +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "68k-mac" +# endif + +# define SYSTEM_TYPE_NAME "macos" +# define MAC_FILE_SYSTEM + +# define NO_READDIR +# define NO_READLINK +# define USE_MAC_FILE_TOOLBOX + +# define MACINTOSH_EVENTS +# define MACINTOSH_GIVE_TIME +# define MACINTOSH_SIOUX + +# if !defined(__POWERPC__) +# define MACINTOSH_SET_STACK +# define COMPUTE_NEG_INEXACT_TO_EXACT_AS_POS +# define NAN_LT_COMPARISON_WRONG +# define SQRT_NAN_IS_WRONG +# define ATAN2_DOESNT_WORK_WITH_INFINITIES +# else +# define CODEFRAGMENT_DYNAMIC_LOAD +# endif + +# ifndef MZSCHEME_IS_CODEFRAGMENT +# define LINK_EXTENSIONS_BY_TABLE +# endif + +# define STACK_GROWS_DOWN + +# define DO_STACK_CHECK +# define MACOS_FIND_STACK_BOUNDS +# define STACK_SAFETY_MARGIN 10000 + +# define TIME_SYNTAX +# define USE_MACTIME +# define CLOCK_IS_USER_TIME +# define DIR_FUNCTION +# define TIME_TYPE_IS_UNSIGNED + +# define NO_SYS_INCLUDE_SUBDIR +# define NO_USLEEP +# define UNISTD_INCLUDE +# define DONT_IGNORE_PIPE_SIGNAL + +# define POW_HANDLES_INF_CORRECTLY +# define TRIG_ZERO_NEEDS_SIGN_CHECK + +# define USE_MAC_TCP + +# define SIGSET_IS_SIGNAL + +# define MACROMAN_CHAR_SET + +# define FLAGS_ALREADY_SET + +#endif + + /************** DOS with Borland C++ ****************/ + /* (Never successfully supported) */ + +#if defined(__BORLANDC__) && defined(__MSDOS__) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "dos\\i386" + +# define USE_SENORA_GC +# define DOS_FAR_POINTERS +# define SMALL_HASH_TABLES + +# define SYSTEM_TYPE_NAME "dos" +# define DOS_FILE_SYSTEM +# define USE_GETDISK +# define DIRENT_NO_NAMLEN +# define NO_READLINK +# define MKDIR_NO_MODE_FLAG + +# define TIME_SYNTAX +# define USE_FTIME +# define GETENV_FUNCTION +# define DIR_FUNCTION + +# define STACK_GROWS_DOWN + +# define DO_STACK_CHECK +# define USE_STACKAVAIL +# define STACK_SAFETY_MARGIN 15000 + +# define IGNORE_BY_CONTROL_387 + +# define DIR_INCLUDE +# define IO_INCLUDE +# define NO_SLEEP +# define DONT_IGNORE_PIPE_SIGNAL + +# define REGISTER_POOR_MACHINE + +# define FLAGS_ALREADY_SET + +#endif + + /************ PalmOS *************/ + +#if defined(__palmos__) + +# define SCHEME_PLATFORM_LIBRARY_SUBPATH "68k-palm" + +# define SYSTEM_TYPE_NAME "palm" + +# define NO_FILE_SYSTEM_UTILS +# define NO_TCP_SUPPORT +# define MZSCHEME_SOMETHING_OMITTED + +# define PALMOS_STUFF +# define NO_STAT_PROC +# define NO_USER_BREAK_HANDLER +# define NO_USLEEP + +# define STACK_GROWS_DOWN + +# define DO_STACK_CHECK +# define PALM_FIND_STACK_BOUNDS +# define STACK_SAFETY_MARGIN 1000 + +# define TIME_SYNTAX +# define USE_PALMTIME +# define USER_TIME_IS_CLOCK +# define TIME_TYPE_IS_UNSIGNED + +# define DONT_IGNORE_PIPE_SIGNAL +# define DONT_IGNORE_FPE_SIGNAL + +# define POW_HANDLES_INF_CORRECTLY +# define USE_PALM_INF_TESTS + +# define FLAGS_ALREADY_SET + +#endif + + /***************************************************/ + +#endif /* end not OSKit */ + +/************** (END KNOWN ARCHITECTURE/SYSTEMS) ****************/ + + +/************** (BEGIN PTHREAD SETUP) ***************/ + +#ifdef MZ_USE_PTHREADS + +# define MZ_REAL_THREADS + +#ifdef __cplusplus +extern "C" { +#endif +void *scheme_pthread_init_threads(void); +void scheme_pthread_create_thread(void (*f)(void *), void *data, unsigned long *stackend, void **thp); +void scheme_pthread_exit_thread(); +void scheme_pthread_break_thread(void *th); +struct Scheme_Process *scheme_pthread_get_current_process(); +void scheme_pthread_set_current_process(struct Scheme_Process *); +void *scheme_pthread_make_mutex(); +void scheme_pthread_free_mutex(void *); +void scheme_pthread_lock_mutex(void *); +void scheme_pthread_unlock_mutex(void *); +void *scheme_pthread_make_semaphore(int init); +void scheme_pthread_free_semaphore(void *); +int scheme_pthread_semaphore_up(void *); +int scheme_pthread_semaphore_down_breakable(void *); +int scheme_pthread_semaphore_try_down(void *); +#ifdef __cplusplus +} +#endif + +#define SCHEME_INIT_THREADS() scheme_pthread_init_threads() +#define SCHEME_CREATE_THREAD(f, data, slimit, thp) scheme_pthread_create_thread(f, data, slimit, thp) +#define SCHEME_EXIT_THREAD() scheme_pthread_exit_thread() +#define SCHEME_BREAK_THREAD(th) scheme_pthread_break_thread(th) +#define SCHEME_GET_CURRENT_PROCESS() scheme_pthread_get_current_process() +#define SCHEME_SET_CURRENT_PROCESS(p) scheme_pthread_set_current_process(p) +#define SCHEME_MAKE_MUTEX() scheme_pthread_make_mutex() +#define SCHEME_FREE_MUTEX(m) scheme_pthread_free_mutex(m) +#define SCHEME_LOCK_MUTEX(m) scheme_pthread_lock_mutex(m) +#define SCHEME_UNLOCK_MUTEX(m) scheme_pthread_unlock_mutex(m) +#define SCHEME_MAKE_SEMA(init) scheme_pthread_make_semaphore(init) +#define SCHEME_FREE_SEMA(s) scheme_pthread_free_semaphore(s) +#define SCHEME_SEMA_UP(s) scheme_pthread_semaphore_up(s) +#define SCHEME_SEMA_DOWN_BREAKABLE(s) scheme_pthread_semaphore_down_breakable(s) +#define SCHEME_SEMA_TRY_DOWN(s) scheme_pthread_semaphore_try_down(s) + +#endif + +/************** (END PTHREAD SETUP) ***************/ + +/***** (BEGIN CONFIGURATION FLAG DESCRPTIONS AND DEFAULTS) ******/ + +#ifndef FLAGS_ALREADY_SET + + /*********************/ + /* Operating System */ +/*********************/ + +#define SYSTEM_TYPE_NAME "unix" + + /* SYSTEM_TYPE_NAME must be a string; this will be converted into + a symbol for the result of (system-type) */ + + /* SCHEME_PLATFORM_LIBRARY_SUBPATH must be a string; if it is + undefined, it is automatically generated into a file named + "schsys.h" into the same directory as .o files and #included + by string.c. This string is returned by (system-library-subpath) */ + + /*********************/ + /* Language Features */ +/*********************/ + +#define TIME_SYNTAX +#define PROCESS_FUNCTION +#define DIR_FUNCTION +#define GETENV_FUNCTION + + /* TIME_SYNTAX adds the (time ...) syntax; this may need to be + turned off for compilation on some systems. + CLOCKS_PER_SEC relates the values returned by clock() to + real seconds. (The difference between two clock() calls is + devided by this number.) Usually, this is defined in ; + it defaults to 1000000 */ + + /* USE_FTIME uses ftime instead of gettimeofday; only for TIME_SYNTAX */ + + /* USE_PLAIN_TIME uses time; only for TIME_SYNTAX */ + + /* USE_MACTIME uses the Mac toolbox to implement time functions. */ + + /* CLOCK_IS_USER_TIME uses the system time for user milliseconds. */ + + /* USER_TIME_IS_CLOCK uses the user time for system milliseconds. */ + + /* TIME_TYPE_IS_UNSIGNED converts time_t values as unsigned. */ + + /* PROCESS_FUNCTION adds (process ...) and (system ...) functions */ + + /* DIR_FUNCTION adds (current-directory ...) function */ + + /* GETENV_FUNCTION adds (getenv ...) function */ + + /* USE_TIMEZONE_VAR gets timezone offset from a timezone global. + USE_TOD_FOR_TIMEZONE gets timezone offset via gettimeofday. + USE_TIMEZONE_VAR_W_DLS is similar, but adds 1 hour when daylight + savings is in effect. + USE_TIMEZONE_AND_ALTZONE_VAR is similar, but uses altzone when + daylight savings is in effect. + USE_TM_GMTOFF_FIELD gets timezone offset from the tm_gmtoff field + of the tm struct. */ + + + /*******************/ + /* Filesystem */ +/*******************/ + +#define UNIX_FILE_SYSTEM +#define EXPAND_FILENAME_TILDE + + /* UNIX_FILE_SYSTEM indicates that filenames are as in Unix, with + forward slash separators, ".." as the parent directory, "/" + as the root directory, and case-sensitivity */ + + /* DOS_FILE_SYSTEM indicates that filenames are as in DOS, with + slash or backward slash separators, ".." as the parent directory, + "X:\", "X:/", "\", or "/" as a root directory (for some letter X), + and case insensitivity */ + + /* MAC_FILE_SYSTEM indicates that filenames are as on the Macintosh, + with colon separators, "" as the parent directory, a volume name + (followed by a colon) as a root directory, and case insensitivity. */ + + /* EXPAND_FILENAME_TILDE expands ~ in a filename with a user's home + directory. */ + + /* NO_STAT_PROC means that there is no stat() function. */ + + /* NO_MKDIR means that there is no mkdir() function. */ + + /* NO_READLINK means that there is no readlink() function. */ + + /* USE_GETDISK uses getdisk() and setdisk() to implement the + filesystem-root-list primitive under DOS. */ + + /* NO_READDIR means that there is no opendir() and readdir() for + implementing directory-list. */ + + /* DIRENT_NO_NAMLEN specifies that dirent entries do not have a + d_namlen field; this is used only when NO_READDIR is not + specified. */ + + /* MKDIR_NO_MODE_FLAG specifies that mkdir() takes only one argument, + instead of a directory name and mode flags. */ + + /* USE_GET_CURRENT_DIRECTORY uses Windows's GetCurrentDirectory() + instead of getcwd(). */ + + /* USE_WINDOWS_FIND_FIRST uses Window's FindFirstFile(), etc. + instead for _findfirst(), etc. */ + + /***********************/ + /* Ports */ +/***********************/ + +/* These are flags about the implementation of char-ready? for FILE*s + None of these flags are required, but char-ready? may return + spurious #ts if they are set up incorrectly. */ + +#define HAS_STANDARD_IOB +#define FILES_HAVE_FDS +#define USE_UNIX_SOCKETS_TCP +#define CLOSE_ALL_FDS_AFTER_FORK + + /* HAS_STANDARD_IOB, HAS_GNU_IOB, HAS_CYGWIN_IOB, HAS_LINUX_IOB, + HAS_BSD_IOB, and HAS_SCO_IOB are mutually exclusive; they describe + how to read the FILE* structure to determine if there are + available cached characters. */ + + /* FILES_HAVE_FDS means that a FILE* is always associated with a + file desciptor, which can be select-ed to see if there are + pending bytes. Don't use this unless one of the HAS__IOB + flags is used. */ + + /* CLOSE_ALL_FDS_AFTER_FORK means that all fds except 0, 1, and 2 + should be closed after performing a fork() for `process' + and `system' calls. */ + + /* USE_UNIX_SOCKETS_TCP means that the tcp- procedures can be implemented + with the standard Unix socket functions. */ + + /* USE_WINSOCK_TCP means that the tcp- procedures can be implemented + with the Winsock toolbox. */ + + /* USE_MAC_TCP means that the tcp- procedures can be implemented + with the Mac TCP toolbox. */ + + /* DETECT_WIN32_CONSOLE_STDIN notices character reads from console + stdin so that char-ready? and blocking reads can be implemented + correctly (so that Scheme threads are not blocked when no input + is ready). If NO_STDIO_THREADS is defined, this flag is ignored. */ + + /* NO_STDIO_THREADS turns off special Windows handling for stdin + and process input ports. The special handling implements char-ready? + and non-blocking reads (so that reading from one of these ports does + not block other MzScheme threads). */ + + /* USE_FCNTL_O_NONBLOCK uses O_NONBLOCK instead of FNDELAY for + fcntl on Unix TCP sockets. (Posix systems need this flag). */ + + /* SOME_FDS_ARE_NOT_SELECTABLE indicates that select() doesn't work + for reading on all kinds of file descriptors. Such FDs must never + be able to go from no-char-ready to char-ready while MzScheme is + sleeping. */ + + /* NEED_RESET_STDOUT_BLOCKING enures that file descriptors 1 and 2 + are reset to blocking mode before exiting. */ + + /* USE_ULIMIT uses ulimit instead of getdtablesize (Unix). */ + + /* USE_DYNAMIC_FDSET_SIZE allocates fd_set records based on the + current fd limit instead of relying on the compile-time size + of fd_set. */ + + /* UNIX_LIMIT_FDSET_SIZE insures that the fd limit at start-up is + no greater than FD_SETSIZE */ + + /* CANT_SET_SOCKET_BUFSIZE turns off setting the buffer size for + Unix TCP sockets. */ + + /***********************/ + /* Processes & Signals */ +/***********************/ + +/* These are flags about the implementation of system, process, etc. */ + +# define UNIX_PROCESSES +# define SIGSET_IS_SIGNAL +# define SIGSET_NEEDS_REINSTALL + + /* UNIX_PROCESSES implements the process functions for Unix; uses + sigset() to install the signal handler. */ + + /* WINDOWS_PROCESSES implements the process functions for Windows. */ + + /* SIGSET_IS_SIGNAL uses signal() in place of sigset() for Unix. This + flag is often paired with SIGSET_NEEDS_REINSTALL for traditional + Unix systems. */ + + /* SIGSET_NEEDS_REINSTALL reinstalls a signal handler when it + is called to handle a signal. The expected semantics of sigset() + (when this flags is not defined) is that a signal handler is NOT + reset to SIG_DFL after a handler is called to handle a signal. */ + + /* DONT_IGNORE_FPE_SIGNAL stops MzScheme from ignoring floating-point + exception signals. */ + + /* DONT_IGNORE_PIPE_SIGNAL stops MzScheme from ignoring SIGPIPE + signals. */ + + /* USE_CREATE_PIPE uses CreatePipe() instead of _pipe() for Windows. */ + + /* SIGCHILD_DOESNT_INTERRUPT_SELECT indicates that the SIGCHILD + signal, sent when a child OS process dies, does not interrupt + select(). This flag is needed for Cygwin B20. */ + + /**********************/ + /* Inexact Arithmetic */ +/**********************/ + + /* USE_SINGLE_FLOATS turns on support for single-precision + floating point numbers. Otherwise, floating point numbers + are always represented in double-precision. */ + + /* USE_SINGLE_FLOATS_AS_DEFAULT, when used with + USE_SINGLE_FLOATS, causes exact->inexact coercions to + use single-precision numbers as the result rather + than double-precision numbers. */ + + /* USE_INFINITY_FUNC uses infinity() to get the infinity + floating-point constant instead of using HUGE_VAL. */ + + /* USE_DIVIDE_MAKE_INFINITY creates +inf.0 by dvividing by zero + instead of using HUGE_VAL. */ + + /* USE_IEEE_FP_PREDS uses isinf() and isnan() to implement tests for + infinity. */ + + /* USE_SCO_IEEE_FP_PREDS uses fpclass() and isnan() to implement tests for + infinity. */ + + /* DEFEAT_FP_COMP_OPTIMIZATION avoids a compiler optimization that + converts (a == a) to TRUE, even if `a' is floating-point. Used + only when USE_[SCO_]IEEE_FP_PREDS is not defined. */ + + /* IGNORE_BY_CONTROL_387 turns off floating-point error for + Intel '387 with _control87. DONT_IGNORE_PIPE_SIGNAL can be on or + off. */ + + /* FREEBSD_CONTROL_387 controls the floating-point processor under i386 + FreeBSD */ + + /* LINUX_CONTROL_387 controls the floating-point processor under i386 + Linux using __setfpucw(). libc 6.1 doesn't export __setfpucw() and + it doesn't matter; for Linux 2.0 and up, the default FP behavior + is the one we want. This flag might be needed for older versions + of Linux. */ + + /* APLHA_CONTROL_FP controls the floating-point processor for Alpha + OSF1 */ + + /* NAN_EQUALS_ANYTHING indicates that the compiler is broken and + equality comparisons with +nan.0 always return #t. Currently + used for MSVC++ */ + + /* ZERO_MINUS_ZERO_IS_POS_ZERO indicates that something (compiler? + machine? fp flags?) is broken so that 0.0 - 0.0 = 0.0 instead of + -0.0. This flag doesn't fix MzScheme completely, since (- 0.0) is + still 0.0, but at least it lets MzScheme read and print 0.0 and + -0.0 accurately. Currently used for HP/UX. */ + + /* NAN_LT_COMPARISON_WRONG indicates that +nan.0 is not handled correctly + by < or <=. Probably the compiler implements < as !>. */ + + /* USE_EXPLICT_FP_FORM_CHECK circumvents bugs in strtod() under Linux, + SunOS/Solaris, and HP/UX by explicit pre-checking the form of the + number and looking for values that are obviously +inf.0 or -inf.0 */ + + /* POW_HANDLES_INF_CORRECTLY inidicates that thw pow() library procedure + handles +/-inf.0 correctly. Otherwise, code in inserted to specifically + check for infinite arguments. */ + + /* ATAN2_DOESNT_WORK_WITH_INFINITIES indicates that atan2(+/-inf, +/-inf) + is not the same as atan2(1, 1). */ + + /* SQRT_NAN_IS_WRONG indicates that (sqrt +nan.0) must be forced to +nan.0 + (i.e., the C library function is bad). */ + + /* COMPUTE_NEG_INEXACT_TO_EXACT_AS_POS computes inexact->exact of some + negative inexact number x by computing the result for -x and negating + it. Use this if (inexact->exact -0.1) is wrong. */ + + /* TRIG_ZERO_NEEDS_SIGN_CHECK defines versions of tan, sin, atan, and + asin that preserve the sign of a zero argument. */ + + /***********************/ + /* Stack Maniuplations */ +/***********************/ + +# define DO_STACK_CHECK +# define UNIX_FIND_STACK_BOUNDS +# define STACK_SAFETY_MARGIN 50000 + + /* STACK_GROWS_UP means that deeper stack values have higher + numbered addresses. + STACK_GROWS_DOWN means that deeper stack values have lower + numbered addresses. This is usually the case (Sparc and + Intel platforms, for example, use this). + Use only one or none of these. (It's faster if you know which + one applies, but it can also be figured it out dynamically.) */ + + /* DO_STACK_CHECK checks for stack overflow during execution. + Requires either UNIX_FIND_STACK_BOUNDS, USE_STACKAVAIL, + MACOS_FIND_STACK_BOUNDS, or ASSUME_FIXED_STACK_SIZE. */ + + /* UNIX_FIND_STACK_BOUNDS figures out the maximum stack position + on Unix systems, using getrlimit() and the GC_find_stack_base() + defined in the conservative garbage collector. + USE_STACKAVIL uses stackavail() function for checking stack + overflow; works with Borland C++, maybe other compilers. + WINDOWS_FIND_STACK_BOUNDS figures out the maximum stack position + under Windows (uses GC_find_stack_base()) + MACOS_FIND_STACK_BOUNDS figures out the stack limit on the Mac. + ASSUME_FIXED_STACK_SIZE assumes that the main stack size is + always FIXED_STACK_SIZE. + Use only one of these if DO_STACK_CHECK is used, or none otherwise. */ + + /* FIXED_STACK_SIZE sets the stack size to when the + ASSUME_FIXED_STACK_SIZE stack-checking mode is on. */ + + /* STACK_SAFETY_MARGIN sets the number of bytes that should be + available on the stack for "safety" to . Used only if + DO_STACK_CHECK is used. STACK_SAFETY_MARGIN defaults to 50000. */ + + /* UNIX_LIMIT_STACK limits stack usage to bytes. This may + be necessary to avoid GC-setup traversal over too much memory + (with GC flag HEURISTIC2?). */ + + /* OSKIT_FIXED_STACK_BOUNDS uses base_stack_start to get the hottest + stack location */ + + /***********************/ + /* Dynamic Loading */ +/***********************/ + +#define UNIX_DYNAMIC_LOAD + + /* UNIX_DYNAMIC_LOAD implements dynamic extensions under Unix + using dlopen(); you may have to add the -ldl flag in the LIBS + Makefile variable. The library doesn't exist under Linux without + ELF, so it won't work. If you get linker errors about dlopen(), etc., + this flag and the -ldl linker flag are the things to adjust. + SHL_DYNAMIC_LOAD implement HP/UX dynamic loading. + WINDOWS_DYNAMIC_LOAD implements dynamic extensions under Windows + (Thanks to Patrick Barta). + CODEFRAGMENT_DYNAMIC_LOAD implements dynamic extensions with + MacOS's Code Fragment Manager (thanks to William Ng). + Use only one or none of these. */ + + /* UNDERSCORE_DYNLOAD_SYMBOL_PREFIX with UNIX_DYNAMIC_LOAD menas that + an extra underscore ("_") must be placed in front of the name passed + to dlopen(). */ + + /* LINK_EXTENSIONS_BY_TABLE specifies that the MzScheme functions + used by an extension must be manually linked via a table of + function pointers. Windows dynamic linking uses this method. */ + + /* MZSCHEME_IS_CODEFRAGMENT exploits improved CFM linking when + MzScheme is itself a shared library instead of embedded in + an application */ + + /***********************/ + /* Heap Images */ +/***********************/ + + /* UNIX_IMAGE_DUMPS turns on image save and restore for Unix systems. + This will only work if the final application is statically linked. + (As an exception, the dynamic-linking library itself can be + dynamically linked. This works because loading an extension in + MzScheme automatically turns off image saving.) */ + + /*****************************/ + /* Macintosh Standalone */ +/*****************************/ + + /* MACINTOSH_EVENTS checks for a user break on the Mac. This should always + be defined for MacOS. */ + + /* MACINTOSH_GIVE_TIME lets background processes run when checking for + a user break. */ + + /* MACINTOSH_SIOUX interfaces with Metrowerks's SIOUX library */ + + /* MACINTOSH_SET_STACK sets the stack to be 1/4 of the heap. This should + be used for 68k machines, where the stack is not user-configurable. */ + + /***********************/ + /* Miscellaneous */ +/***********************/ + +#define UNISTD_INCLUDE +#define NO_INLINE_KEYWORD + + /* REGISTER_POOR_MACHINE guides a hand optimization that seems to + be work best one way for Sparc machines, and better the other + way for x86 machines. */ + + /* SIXTY_FOUR_BIT_INTEGERS indicates that 'long's are 64-bits wide. */ + + /* MACROMAN_CHAR_SET indicates that latin1-integer->char should convert + Latin-1 values to MacRoman characters. */ + + /* WINLATIN_CHAR_SET indicates that latin1-integer->char should return + #f for values in #x80 to #x9F, and char->latin-1-integer should + return #f for characters in that range. */ + + /* NO_INLINE_KEYWORD indicates that the C compiler doesn't recognize + C's `inline' keyword. */ + + /* NO_USER_BREAK_HANDLER turns off handling of INT signal in main.c */ + + /* DIR_INCLUDE if there's a file (mainly for Windows). */ + + /* DIRECT_INCLUDE if there's a file (mainly for Windows). */ + + /* IO_INCLUDE if there's a file (mainly for Windows). */ + + /* UNISTD_INCLUDE if there's a file (mainly for Unix). */ + + /* SELECT_INCLUDE if there's a file (mainly for Unix) + to be used with FILES_HAVE_FDS. */ + + /* BSTRING_INCLUDE if there's a file (mainly for Unix) + to be used with FILES_HAVE_FDS. */ + + /* NO_SYS_INCLUDE_SUBDIR if include files should all be ; no + includes of the form . Mainly used for + for MacOS. */ + + /* USE_FCHDIR uses fchdir() to improve thread context switches when + a small number of threads are active. */ + + /* USE_GETRUSAGE uses getrusage() to for timing info; otherwise clock() + is used. */ + + /* USE_SYSCALL_GETRUSAGE uses syscall() to implement getrusage() for + timing info. Used with USE_GETRUSAGE. */ + + /* NO_SLEEP means that there is no sleep() function. Used only in + standalone MzScheme. */ + + /* NO_USLEEP means that there is no usleep() function. Used only in + standalone MzScheme. Used only if NO_SLEEP is undefined. */ + + /* NO_NEED_FOR_BEGINTHREAD indicates that the C library used for + Windows is always thread-ready and there's no need use the + _beginthreadex() function instead of CreateThread(). This is only + used when stdin and process ports are tested in a separate thread + (see NO_STDIO_TREADS). */ + + /* WIN32S_HACK uses a special hack to implement threads under Win32s + with some compilers. Obsolete. */ + +#endif /* FLAGS_ALREADY_SET */ + +/****** (END CONFIGURATION FLAG DESCRPTIONS AND DEFAULTS) *******/ + +#endif /* FLAGS_ALREADY_SET */ diff --git a/collects/mzscheme/include/stypes.h b/collects/mzscheme/include/stypes.h new file mode 100644 index 00000000..2748b6ef --- /dev/null +++ b/collects/mzscheme/include/stypes.h @@ -0,0 +1,184 @@ + +enum { + + /* compiled object types: (internal) */ + scheme_variable_type, + scheme_local_type, + scheme_local_unbox_type, + scheme_syntax_type, + scheme_application_type, + scheme_sequence_type, + scheme_branch_type, + scheme_unclosed_procedure_type, + scheme_let_value_type, + scheme_let_void_type, + scheme_letrec_type, /* 10 */ + scheme_let_one_type, + scheme_with_cont_mark_type, + + _scheme_values_types_, /* All following types are values */ + + /* intermediate compiled: */ + scheme_compiled_unclosed_procedure_type, + scheme_compiled_let_value_type, + scheme_compiled_let_void_type, + scheme_compiled_syntax_type, + + scheme_quote_compilation_type, + + _scheme_compiled_values_types_, + + /* procedure types */ + scheme_prim_type, /* 20 */ + scheme_closed_prim_type, + scheme_linked_closure_type, + scheme_case_closure_type, + scheme_cont_type, + scheme_escaping_cont_type, + + /* basic types */ + scheme_char_type, /* 26 */ + scheme_integer_type, + scheme_bignum_type, + scheme_rational_type, + scheme_float_type, /* 30 */ + scheme_double_type, + scheme_complex_izi_type, + scheme_complex_type, + scheme_string_type, + scheme_symbol_type, + scheme_null_type, + scheme_pair_type, + scheme_vector_type, + scheme_closure_type, + scheme_input_port_type, /* 40 */ + scheme_output_port_type, + scheme_eof_type, + scheme_true_type, + scheme_false_type, + scheme_void_type, + scheme_syntax_compiler_type, + scheme_macro_type, + scheme_promise_type, + scheme_box_type, + scheme_process_type, /* 50 */ + scheme_object_type, + scheme_class_type, + scheme_structure_type, + scheme_generic_type, + scheme_cont_mark_set_type, + scheme_sema_type, + scheme_hash_table_type, + scheme_generic_data_type, + scheme_weak_box_type, + scheme_struct_type_type, /* 60 */ + scheme_id_macro_type, + scheme_unit_type, + scheme_exp_time_type, + scheme_listener_type, + scheme_namespace_type, + scheme_config_type, + scheme_reserved_1_type, + scheme_will_executor_type, + scheme_interface_type, + scheme_manager_type, /* 70 */ + scheme_random_state_type, + scheme_regexp_type, + + /* These reserved types will let us add types + without forcing recompilation of compiled MzScheme code */ + scheme_reserved_3_type, + + /* more internal types: */ + scheme_compilation_top_type, + + scheme_envunbox_type, + scheme_eval_waiting_type, + scheme_tail_call_waiting_type, + scheme_class_data_type, + scheme_undefined_type, + scheme_struct_info_type, /* 80 */ + scheme_multiple_values_type, + scheme_placeholder_type, + scheme_case_lambda_sequence_type, + scheme_begin0_sequence_type, + + scheme_compiled_unit_type, + scheme_unit_body_data_type, + scheme_reserved_5_type, + scheme_unit_compound_data_type, + scheme_invoke_unit_data_type, + + scheme_interface_data_type, /* 90 */ + + scheme_svector_type, + +#ifdef MZTAG_REQUIRED + _scheme_last_normal_type_, + + scheme_rt_comp_env, + scheme_rt_constant_binding, + scheme_rt_link_info, + scheme_rt_compile_info, + scheme_rt_cont_mark, + scheme_rt_saved_stack, + scheme_rt_eval_in_env, + scheme_rt_reply_item, + scheme_rt_closure_info, + scheme_rt_overflow, + scheme_rt_dyn_wind_cell, + scheme_rt_cont_mark_chain, + scheme_rt_dyn_wind_info, + scheme_rt_dyn_wind, + scheme_rt_dup_check, + scheme_rt_class_var, + scheme_rt_class_method, + scheme_rt_class_assembly, + scheme_rt_init_obj_rec, + scheme_rt_super_init_data, + scheme_rt_thread_memory, + scheme_rt_input_file, + scheme_rt_input_fd, + scheme_rt_oskit_console_input, + scheme_rt_tested_input_file, + scheme_rt_tested_output_file, + scheme_rt_indexed_string, + scheme_rt_output_file, + scheme_rt_load_handler_data, + scheme_rt_load_data, + scheme_rt_pipe, + scheme_rt_beos_process, + scheme_rt_system_child, + scheme_rt_tcp, + scheme_rt_write_data, + scheme_rt_tcp_select_info, + scheme_rt_namespace_option, + scheme_rt_param_data, + scheme_rt_will, + scheme_rt_will_registration, + scheme_rt_breakable_wait, + scheme_rt_sema_waiter, + scheme_rt_struct_proc_info, + scheme_rt_linker_name, + scheme_rt_unit_id, + scheme_rt_body_expr, + scheme_rt_body_var, + scheme_rt_param_map, + scheme_rt_export_source, + scheme_rt_unit_data_closure, + scheme_rt_compound_linked_data, + scheme_rt_do_invoke_data, + scheme_rt_finalization, + scheme_rt_finalizations, + scheme_rt_cpp_object, + scheme_rt_cpp_array_object, + scheme_rt_stack_object, + scheme_rt_preallocated_object, + scheme_process_hop_type, + scheme_rt_breakable, +#endif + + _scheme_last_type_ +}; + +extern char *scheme_get_type_name(Scheme_Type type); diff --git a/collects/mzscheme/include/uconfig.h b/collects/mzscheme/include/uconfig.h new file mode 100644 index 00000000..2ca2ac31 --- /dev/null +++ b/collects/mzscheme/include/uconfig.h @@ -0,0 +1,32 @@ + +/* Standard settings for Unix platforms. */ +/* Used by sconfig.h for known architectures. */ + +#define SYSTEM_TYPE_NAME "unix" +#define UNIX_FILE_SYSTEM + +#define TIME_SYNTAX +#define PROCESS_FUNCTION +#define DIR_FUNCTION +#define GETENV_FUNCTION + +#define USE_FD_PORTS +#define HAS_STANDARD_IOB +#define FILES_HAVE_FDS +#define USE_UNIX_SOCKETS_TCP + +#define UNIX_PROCESSES +#define CLOSE_ALL_FDS_AFTER_FORK + +#define EXPAND_FILENAME_TILDE + +#define DO_STACK_CHECK +#define UNIX_FIND_STACK_BOUNDS +#define STACK_SAFETY_MARGIN 50000 + +#define UNIX_DYNAMIC_LOAD + +#define UNISTD_INCLUDE +#define USE_FCHDIR + +#define USE_GETRUSAGE diff --git a/collects/mzscheme/lib/mzdyn.c b/collects/mzscheme/lib/mzdyn.c new file mode 100644 index 00000000..80c4390f --- /dev/null +++ b/collects/mzscheme/lib/mzdyn.c @@ -0,0 +1,55 @@ +/* + MzScheme + Copyright (c) 1995 Matthew Flatt + All rights reserved. + + Please see the full copyright in the documentation. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file should be linked with any MzScheme extension dynamic + object. */ + + +#include "escheme.h" +#ifdef INCLUDE_WITHOUT_PATHS +# include "schvers.h" +#else +# include "../src/schvers.h" +#endif + +#ifdef MZ_PRECISE_GC +# define PLAIN_OR_2K "@2k" +#else +# define PLAIN_OR_2K "" +#endif + +#ifdef LINK_EXTENSIONS_BY_TABLE +Scheme_Extension_Table *scheme_extension_table; +#endif + +#ifdef CODEFRAGMENT_DYNAMIC_LOAD +#pragma export on +char *scheme_initialize_internal( +#ifdef LINK_EXTENSIONS_BY_TABLE + Scheme_Extension_Table *table +#endif + ); +#pragma export off +#endif + +char *scheme_initialize_internal( +#ifdef LINK_EXTENSIONS_BY_TABLE + Scheme_Extension_Table *table +#endif + ) +{ +#ifdef LINK_EXTENSIONS_BY_TABLE + scheme_extension_table = table; +#endif + + return VERSION PLAIN_OR_2K; +} diff --git a/collects/net/base64.ss b/collects/net/base64.ss new file mode 100644 index 00000000..f3e2bca3 --- /dev/null +++ b/collects/net/base64.ss @@ -0,0 +1,8 @@ + +(require-relative-library "base64s.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:base64^ + (require-relative-library "base64r.ss")) diff --git a/collects/net/base64r.ss b/collects/net/base64r.ss new file mode 100644 index 00000000..e5452b84 --- /dev/null +++ b/collects/net/base64r.ss @@ -0,0 +1,68 @@ + +(unit/sig mzlib:base64^ + (import) + + (define (base64-encode src) + ; Always includes a terminator + (let* ([len (string-length src)] + [new-len (let ([l (add1 (ceiling (* len 8/6)))]) + ; Break l into 72-character lines. + ; Insert CR/LF between each line. + (+ l (* (quotient l 72) 2)))] + [dest (make-string new-len #\0)] + [char-map (list->vector + (let ([each-char (lambda (s e) + (let loop ([l null][i (char->integer e)]) + (if (= i (char->integer s)) + (cons s l) + (loop (cons (integer->char i) + l) + (sub1 i)))))]) + (append + (each-char #\A #\Z) + (each-char #\a #\z) + (each-char #\0 #\9) + (list #\+ #\/))))]) + (let loop ([bits 0][v 0][col 0][srcp 0][destp 0]) + (cond + [(= col 72) + ; Insert CRLF + (string-set! dest destp #\return) + (string-set! dest (add1 destp) #\linefeed) + (loop bits + v + 0 + srcp + (+ destp 2))] + [(and (= srcp len) + (<= bits 6)) + ; That's all, folks. + ; Write the last few bits. + (begin + (string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits)))) + (add1 destp)) + (if (= col 71) + ; Have to write CRLF before terminator + (begin + (string-set! dest (+ destp 1) #\return) + (string-set! dest (+ destp 2) #\linefeed) + (string-set! dest (+ destp 3) #\=)) + (string-set! dest (add1 destp) #\=)) + dest] + [(< bits 6) + ; Need more bits. + (loop (+ bits 8) + (bitwise-ior (arithmetic-shift v 8) + (char->integer (string-ref src srcp))) + col + (add1 srcp) + destp)] + [else + ; Write a char. + (string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits)))) + (loop (- bits 6) + (bitwise-and v (sub1 (arithmetic-shift 1 (- bits 6)))) + (add1 col) + srcp + (add1 destp))]))))) + diff --git a/collects/net/base64s.ss b/collects/net/base64s.ss new file mode 100644 index 00000000..452525f5 --- /dev/null +++ b/collects/net/base64s.ss @@ -0,0 +1,3 @@ + +(define-signature mzlib:base64^ + (base64-encode)) diff --git a/collects/net/cgi.ss b/collects/net/cgi.ss new file mode 100644 index 00000000..db770679 --- /dev/null +++ b/collects/net/cgi.ss @@ -0,0 +1,8 @@ + +(require-library "cgiu.ss" "net") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:cgi^ + mzlib:cgi@) diff --git a/collects/net/cgir.ss b/collects/net/cgir.ss new file mode 100644 index 00000000..040c2610 --- /dev/null +++ b/collects/net/cgir.ss @@ -0,0 +1,313 @@ +(unit/sig mzlib:cgi^ + (import) + + ;; type bindings = list ((symbol . string)) + + ;; -------------------------------------------------------------------- + + ;; Exceptions: + + (define-struct cgi-error ()) + + ;; chars : list (char) + ;; -- gives the suffix which is invalid, not including the `%' + + (define-struct (incomplete-%-suffix struct:cgi-error) (chars)) + + ;; char : char + ;; -- an invalid character in a hex string + + (define-struct (invalid-%-suffix struct:cgi-error) (char)) + + ;; -------------------------------------------------------------------- + + ;; query-chars->string : + ;; list (char) -> string + + ;; -- The input is the characters post-processed as per Web specs, which + ;; is as follows: + ;; spaces are turned into "+"es and lots of things are turned into %XX, + ;; where XX are hex digits, eg, %E7 for ~. The output is a regular + ;; Scheme string with all the characters converted back. + + (define query-chars->string + (lambda (chars) + (list->string + (let loop ((chars chars)) + (if (null? chars) null + (let ((first (car chars)) + (rest (cdr chars))) + (let-values (((this rest) + (cond + ((char=? first #\+) + (values #\space rest)) + ((char=? first #\%) + (if (and (pair? rest) + (pair? (cdr rest))) + (values + (integer->char + (or (string->number + (string + (car rest) (cadr rest)) + 16) + (raise (make-invalid-%-suffix + (if (string->number + (string (car rest)) + 16) + (cadr rest) + (car rest)))))) + (cddr rest)) + (raise + (make-incomplete-%-suffix rest)))) + (else + (values first rest))))) + (cons this (loop rest))))))))) + + ;; string->html : + ;; string -> string + ;; -- the input is raw text, the output is HTML appropriately quoted + + (define string->html + (lambda (s) + (apply string-append + (map (lambda (c) + (case c + ((#\<) "<") + ((#\>) ">") + ((#\&) "&") + (else (string c)))) + (string->list s))))) + + (define default-text-color "#000000") + (define default-bg-color "#ffffff") + (define default-link-color "#cc2200") + (define default-vlink-color "#882200") + (define default-alink-color "#444444") + + ;; generate-html-output : + ;; html-string x list (html-string) x ... -> () + + (define generate-html-output + (opt-lambda (title body-lines + (text-color default-text-color) + (bg-color default-bg-color) + (link-color default-link-color) + (vlink-color default-vlink-color) + (alink-color default-alink-color)) + (let ((sa string-append)) + (for-each + (lambda (l) + (display l) (newline)) + `("Content-type: text/html" + "" + "" + "" + + "" + ,(sa "" title "") + "" + "" + ,(sa "") + "" + ,@body-lines + "" + "" + ""))))) + + ;; read-until-char : + ;; iport x char -> list (char) x bool + ;; -- operates on the default input port; the second value indicates + ;; whether reading stopped because an EOF was hit (as opposed to the + ;; delimiter being seen); the delimiter is not part of the result + + (define read-until-char + (lambda (ip delimiter) + (let loop ((chars '())) + (let ((c (read-char ip))) + (cond + ((eof-object? c) + (values (reverse chars) #t)) + ((char=? c delimiter) + (values (reverse chars) #f)) + (else + (loop (cons c chars)))))))) + + ;; read-name+value : + ;; iport -> (symbol + bool) x (string + bool) x bool + + ;; -- If the first value is false, so is the second, and the third is + ;; true, indicating EOF was reached without any input seen. Otherwise, + ;; the first and second values contain strings and the third is either + ;; true or false depending on whether the EOF has been reached. The + ;; strings are processed to remove the CGI spec "escape"s. + + ;; This code is _slightly_ lax: it allows an input to end in `&'. It's + ;; not clear this is legal by the CGI spec, which suggests that the last + ;; value binding must end in an EOF. It doesn't look like this matters. + ;; It would also introduce needless modality and reduce flexibility. + + (define read-name+value + (lambda (ip) + (let-values + (((name eof?) + (read-until-char ip #\=))) + (cond + ((and eof? (null? name)) + (values #f #f #t)) + (eof? + (generate-error-output + (list "Server generated malformed input for POST method:" + (string-append + "No binding for `" (list->string name) "' field.")))) + (else + (let-values (((value eof?) + (read-until-char ip #\&))) + (values (string->symbol (query-chars->string name)) + (query-chars->string value) + eof?))))))) + + ;; get-bindings/post : + ;; () -> bindings + + (define get-bindings/post + (lambda () + (let-values (((name value eof?) + (read-name+value + (current-input-port)))) + (cond + ((and eof? (not name)) + null) + ((and eof? name) + (list (cons name value))) + (else + (cons (cons name value) + (get-bindings/post))))))) + + ;; get-bindings/get : + ;; () -> bindings + + (define get-bindings/get + (lambda () + (let ((p (open-input-string + (getenv "QUERY_STRING")))) + (let loop () + (let-values (((name value eof?) + (read-name+value p))) + (cond + ((and eof? (not name)) + null) + ((and eof? name) + (list (cons name value))) + (else + (cons (cons name value) + (loop))))))))) + + ;; get-bindings : + ;; () -> bindings + + (define get-bindings + (lambda () + (if (string=? (get-cgi-method) "POST") + (get-bindings/post) + (get-bindings/get)))) + + ;; generate-error-output : + ;; list (html-string) -> + + (define generate-error-output + (lambda (error-message-lines) + (generate-html-output "Internal Error" + error-message-lines) + (exit))) + + ;; bindings-as-html : + ;; bindings -> list (html-string) + ;; -- formats name-value bindings as HTML appropriate for displaying + + (define bindings-as-html + (lambda (bindings) + `("" + ,@(map + (lambda (bind) + (string-append + (symbol->string (car bind)) + " --> " + (cdr bind) + "
")) + bindings) + ""))) + + ;; extract-bindings : + ;; (string + symbol) x bindings -> list (string) + + ;; -- Extracts the bindings associated with a given name. The semantics + ;; of forms states that a CHECKBOX may use the same NAME field multiple + ;; times. Hence, a list of strings is returned. Note that the result + ;; may be the empty list. + + (define extract-bindings + (lambda (field-name bindings) + (let ((field-name (if (symbol? field-name) field-name + (string->symbol field-name)))) + (let loop ((found null) (bindings bindings)) + (if (null? bindings) + found + (if (equal? field-name (caar bindings)) + (loop (cons (cdar bindings) found) (cdr bindings)) + (loop found (cdr bindings)))))))) + + ;; extract-binding/single : + ;; (string + symbol) x bindings -> string + ;; -- used in cases where only one binding is supposed to occur + + (define extract-binding/single + (lambda (field-name bindings) + (let ((field-name (if (symbol? field-name) field-name + (string->symbol field-name)))) + (let ((result (extract-bindings field-name bindings))) + (cond + ((null? result) + (generate-error-output + `(,(string-append "No binding for field `" + (if (symbol? field-name) + (symbol->string field-name) + field-name) + "' in

") + ,@(bindings-as-html bindings)))) + ((null? (cdr result)) + (car result)) + (else + (generate-error-output + `(,(string-append "Multiple bindings for field `" + (if (symbol? field-name) + (symbol->string field-name) + field-name) + "' where only one was expected in

") + ,@(bindings-as-html bindings))))))))) + + ;; get-cgi-method : + ;; () -> string + ;; -- string is either GET or POST (though future extension is possible) + + (define get-cgi-method + (lambda () + (getenv "REQUEST_METHOD"))) + + ;; generate-link-text : + ;; string x html-string -> html-string + + (define generate-link-text + (lambda (url anchor-text) + (string-append "" anchor-text ""))) + + ;; ==================================================================== + + + ) diff --git a/collects/net/cgis.ss b/collects/net/cgis.ss new file mode 100644 index 00000000..c51585cf --- /dev/null +++ b/collects/net/cgis.ss @@ -0,0 +1,24 @@ +(require-library "macro.ss") + +(define-signature mzlib:cgi^ + ( + ;; -- exceptions raised -- + (struct cgi-error ()) + (struct incomplete-%-suffix (chars)) + (struct invalid-%-suffix (char)) + + ;; -- cgi methods -- + get-bindings + get-bindings/post + get-bindings/get + generate-html-output + generate-error-output + bindings-as-html + extract-bindings + extract-binding/single + get-cgi-method + + ;; -- general HTML utilities -- + string->html + generate-link-text + )) diff --git a/collects/net/cgiu.ss b/collects/net/cgiu.ss new file mode 100644 index 00000000..1b13e28f --- /dev/null +++ b/collects/net/cgiu.ss @@ -0,0 +1,4 @@ +(require-library "refer.ss") +(require-library "cgis.ss" "net") + +(define mzlib:cgi@ (require-library-unit/sig "cgir.ss" "net")) diff --git a/collects/net/dns.ss b/collects/net/dns.ss new file mode 100644 index 00000000..b569eb68 --- /dev/null +++ b/collects/net/dns.ss @@ -0,0 +1,8 @@ + +(require-relative-library "dnss.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:dns^ + (require-relative-library "dnsr.ss")) diff --git a/collects/net/dnsr.ss b/collects/net/dnsr.ss new file mode 100644 index 00000000..804d4254 --- /dev/null +++ b/collects/net/dnsr.ss @@ -0,0 +1,293 @@ + +(unit/sig mzlib:dns^ + (import) + + (define types + '((a 1) + (ns 2) + (md 3) + (mf 4) + (cname 5) + (soa 6) + (mb 7) + (mg 8) + (mr 9) + (null 10) + (wks 11) + (ptr 12) + (hinfo 13) + (minfo 14) + (mx 15) + (txt 16))) + + (define classes + '((in 1) + (cs 2) + (ch 3) + (hs 4))) + + (define (cossa i l) + (cond + [(null? l) #f] + [(equal? (cadar l) i) + (car l)] + [else (cossa i (cdr l))])) + + + (define (number->octet-pair n) + (list (integer->char (arithmetic-shift n -8)) + (integer->char (modulo n 256)))) + + (define (octet-pair->number a b) + (+ (arithmetic-shift (char->integer a) 8) + (char->integer b))) + + (define (octet-quad->number a b c d) + (+ (arithmetic-shift (char->integer a) 24) + (arithmetic-shift (char->integer b) 16) + (arithmetic-shift (char->integer c) 8) + (char->integer d))) + + (define (name->octets s) + (let ([do-one (lambda (s) + (cons + (integer->char (string-length s)) + (string->list s)))]) + (let loop ([s s]) + (let ([m (regexp-match "^([^.]*)[.](.*)" s)]) + (if m + (append + (do-one (cadr m)) + (loop (caddr m))) + (append + (do-one s) + (list #\nul))))))) + + (define (make-std-query-header id question-count) + (append + (number->octet-pair id) + (list #\001 #\nul) ; Opcode & flags (recusive flag set) + (number->octet-pair question-count) + (number->octet-pair 0) + (number->octet-pair 0) + (number->octet-pair 0))) + + (define (make-query id name type class) + (append + (make-std-query-header id 1) + (name->octets name) + (number->octet-pair (cadr (assoc type types))) + (number->octet-pair (cadr (assoc class classes))))) + + (define (add-size-tag m) + (append (number->octet-pair (length m)) m)) + + (define (rr-data rr) + (cadddr (cdr rr))) + + (define (rr-type rr) + (cadr rr)) + + (define (rr-name rr) + (car rr)) + + (define (parse-name start reply) + (let ([v (char->integer (car start))]) + (cond + [(zero? v) + ; End of name + (values #f (cdr start))] + [(zero? (bitwise-and #xc0 v)) + ; Normal label + (let loop ([len v][start (cdr start)][accum null]) + (cond + [(zero? len) + (let-values ([(s start) (parse-name start reply)]) + (let ([s0 (list->string (reverse! accum))]) + (values (if s + (string-append s0 "." s) + s0) + start)))] + [else (loop (sub1 len) (cdr start) (cons (car start) accum))]))] + [else + ; Compression offset + (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) + (char->integer (cadr start)))]) + (let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)]) + (values s (cddr start))))]))) + + (define (parse-rr start reply) + (let-values ([(name start) (parse-name start reply)]) + (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))] + [start (cddr start)]) + (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))] + [start (cddr start)]) + (let ([ttl (octet-quad->number (car start) (cadr start) + (caddr start) (cadddr start))] + [start (cddddr start)]) + (let ([len (octet-pair->number (car start) (cadr start))] + [start (cddr start)]) + ; Extract next len bytes for data: + (let loop ([len len][start start][accum null]) + (if (zero? len) + (values (list name type class ttl (reverse! accum)) + start) + (loop (sub1 len) (cdr start) (cons (car start) accum)))))))))) + + (define (parse-ques start reply) + (let-values ([(name start) (parse-name start reply)]) + (let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))] + [start (cddr start)]) + (let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))] + [start (cddr start)]) + (values (list name type class) start))))) + + (define (parse-n parse start reply n) + (let loop ([n n][start start][accum null]) + (if (zero? n) + (values (reverse! accum) start) + (let-values ([(rr start) (parse start reply)]) + (loop (sub1 n) start (cons rr accum)))))) + + (define (dns-query nameserver addr type class) + (unless (assoc type types) + (raise-type-error 'dns-query "DNS query type" type)) + (unless (assoc class classes) + (raise-type-error 'dns-query "DNS query class" class)) + + (let* ([query (make-query (random 256) addr type class)] + [reply + (let-values ([(r w) (tcp-connect nameserver 53)]) + (dynamic-wind + void + + (lambda () + (display (list->string (add-size-tag query)) w) + (flush-output w) + + (let ([a (read-char r)] + [b (read-char r)]) + (let ([len (octet-pair->number a b)]) + (let ([s (read-string len r)]) + (unless (= len (string-length s)) + (error 'dns-query "unexpected EOF from server")) + (string->list s))))) + + (lambda () + (close-input-port r) + (close-output-port w))))]) + + ; First two bytes must match sent message id: + (unless (and (char=? (car reply) (car query)) + (char=? (cadr reply) (cadr query))) + (error 'dns-query "bad reply id from server")) + + (let ([v0 (caddr reply)] + [v1 (cadddr reply)]) + ; Check for error code: + (let ([rcode (bitwise-and #xf (char->integer v1))]) + (unless (zero? rcode) + (error 'dns-query "error from server: ~a" + (case rcode + [(1) "format error"] + [(2) "server failure"] + [(3) "name error"] + [(4) "not implemented"] + [(5) "refused"])))) + + (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] + [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] + [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] + [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) + + (let ([start (list-tail reply 12)]) + (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] + [(ans start) (parse-n parse-rr start reply an-count)] + [(nss start) (parse-n parse-rr start reply ns-count)] + [(ars start) (parse-n parse-rr start reply ar-count)]) + (unless (null? start) + (error 'dns-query "error parsing server reply")) + (values (positive? (bitwise-and #x4 (char->integer v0))) + qds ans nss ars reply))))))) + + (define cache (make-hash-table)) + (define (dns-query/cache nameserver addr type class) + (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) + (let ([v (hash-table-get cache key (lambda () #f))]) + (if v + (apply values v) + (let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)]) + (hash-table-put! cache key (list auth? qds ans nss ars reply)) + (values auth? qds ans nss ars reply)))))) + + (define (ip->string s) + (format "~a.~a.~a.~a" + (char->integer (list-ref s 0)) + (char->integer (list-ref s 1)) + (char->integer (list-ref s 2)) + (char->integer (list-ref s 3)))) + + (define (try-forwarding k nameserver) + (let loop ([nameserver nameserver][tried (list nameserver)]) + ; Normally the recusion is done for us, but it's technically optional + (let-values ([(v ars auth?) (k nameserver)]) + (or v + (and (not auth?) + (let* ([ns (ormap + (lambda (ar) + (and (eq? (rr-type ar) 'a) + (ip->string (rr-data ar)))) + ars)]) + (and ns + (not (member ns tried)) + (loop ns (cons ns tried))))))))) + + (define (dns-get-address nameserver addr) + (or (try-forwarding + (lambda (nameserver) + (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)]) + (values (and (positive? (length ans)) + (let ([s (rr-data (car ans))]) + (ip->string s))) + ars auth?))) + nameserver) + (error 'dns-get-address "bad address"))) + + (define (dns-get-mail-exchanger nameserver addr) + (or (try-forwarding + (lambda (nameserver) + (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)]) + (values (let loop ([ans ans][best-pref +inf.0][exchanger #f]) + (cond + [(null? ans) (or exchanger + ;; Does 'soa mean that the input address is fine? + (and (ormap + (lambda (ns) (eq? (rr-type ns) 'soa)) + nss) + addr))] + [else + (let ([d (rr-data (car ans))]) + (let ([pref (octet-pair->number (car d) (cadr d))]) + (if (< pref best-pref) + (let-values ([(name start) (parse-name (cddr d) reply)]) + (loop (cdr ans) pref name)) + (loop (cdr ans) best-pref exchanger))))])) + ars auth?))) + nameserver) + (error 'dns-get-mail-exchanger "bad address"))) + + (define (dns-find-nameserver) + (case (system-type) + [(unix) (with-handlers ([void (lambda (x) #f)]) + (with-input-from-file "/etc/resolv.conf" + (lambda () + (let loop () + (let ([l (read-line)]) + (or (and (string? l) + (let ([m (regexp-match + (format "nameserver[ ~a]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #\tab) + l)]) + (and m (cadr m)))) + (and (not (eof-object? l)) + (loop))))))))] + [else #f]))) diff --git a/collects/net/dnss.ss b/collects/net/dnss.ss new file mode 100644 index 00000000..8083f659 --- /dev/null +++ b/collects/net/dnss.ss @@ -0,0 +1,5 @@ + +(define-signature mzlib:dns^ + (dns-get-address + dns-get-mail-exchanger + dns-find-nameserver)) diff --git a/collects/net/doc.txt b/collects/net/doc.txt new file mode 100644 index 00000000..e3fabe04 --- /dev/null +++ b/collects/net/doc.txt @@ -0,0 +1,999 @@ +Time-stamp: <99/10/22 12:42:59 shriram> + +The `net' collection contains libraries that provide access to the +following _Internet_ (quasi-)protocols: + + URL parsing + CGI backends + sendmail + SMTP + NNTP + POP-3 + IMAP + Mail header reading and writing + DNS + +Shriram Krishnamurthi +shriram@cs.rice.edu +Matthew Flatt +mflatt@cs.utah.edu + +========================================================================== +_URL_ posting, _web clients_, _WWW_ +========================================================================== + +Collection: net +Files: _url.ss_, _urlr.ss_, _urls.ss_, _urlu.ss_ + +ABSTRACT ------------------------------------------------------------- + +The url package manages features of URLs. + +TYPES ---------------------------------------------------------------- + +> url + struct url (scheme host port path params query fragment) + scheme : string or #f + host : string or #f + port : number or #f + path : string + params : string or #f + query : string or #f + fragment : string or #f + + The basic structure for all URLs. + + http://www.cs.rice.edu:80/cgi-bin/finger;xyz?name=shriram&host=nw#top + 1 2 3 4 5 6 7 + + 1 = scheme, 2 = host, 3 = port, 4 = path, + 5 = params, 6 = query, 7 = fragment + +> pure-port + + A pure port is one from which the MIME headers have been removed, so + that what remains is purely the first content fragment. + +> mime-header + struct mime-header (name value) + name : string + value : string + + MIME header. + +PROCEDURES ----------------------------------------------------------- + +> (unixpath->path string) -> path-string + + Given a path from a URL structure, turns it into a path that + conforms to the local OS path specifications. Useful for file + accesses on the local disk system. + +> (get-pure-port url [list-of-strings]) -> input-port + + Takes a URL and returns a pure port corresponding to it. Writes the + optional strings to the server. + +> (get-impure-port url [list-of-strings]) -> input-port + + Takes a URL and returns an impure port corresponding to it. Writes + the optional strings to the server. + +> (display-pure-port input-port) -> void + + Writes the output of a pure port. For debugging purposes. + +> (purify-port input-port) -> list-of-mime-headers + + Purifies a port, returning the MIME headers. + +> (string->url string) -> url + + Turns a string into a URL. + +> (netscape/string->url string) -> url + + Turns a string into a URL, applying (what appear to be) Netscape's + conventions on automatically specifying the scheme: a string + starting with a slash gets the scheme "file", while all others get + the scheme "http". + +> (url->string url) -> string + + Generates a string corresponding to the contents of the url struct. + +> (call/input-url url url->port-proc port->void-proc [list-of-strings]) -> void + + First argument is the URL to open. Second is a procedure that takes + a URL and turns it into a (pure or impure) port. The third takes + the (pure or impure) port and handles its contents. The optional + fourth argument is a set of strings to send to the server. + +> (combine-url/relative url string) -> url + + Given a base URL and a relative path, combines the two and returns a + new URL. + +EXAMPLE -------------------------------------------------------------- + + (require-library "url.ss" "net") + (define url:cs (string->url "http://www.cs.rice.edu/")) + (define url:me (string->url "http://www.cs.rice.edu/~shriram/")) + (define comb combine-url/relative) + (define (test url) + (call/input-url url get-pure-port display-pure-port)) + (test url:cs) + +========================================================================== +_CGI_ backends, _WWW_ +========================================================================== + +Collection: net +Libraries: _cgi.ss_, _cgic.ss_, _cgir.ss_, _cgis.ss_, _cgiu.ss_ + +ABSTRACT ------------------------------------------------------------- + +The cgi package helps programmers write scripts that follow the Common +Gateway Interface (CGI) protocol of the World-Wide Web. + +TYPES ---------------------------------------------------------------- + +binding: + + A binding is an association of a form item with its value. Some form + items (such as checkboxes) may correspond to multiple bindings. A + binding is a tag-string pair, where a tag is a symbol or a string. + +bindings: + + A list of `binding's. + +html-string: + + A text string that has been escaped according to HTML conventions. + +EXCEPTIONS ----------------------------------------------------------- + +> cgi-error + struct cgi-error () + + cgi-error is a super-structure for all exceptions thrown by this + library. + +> incomplete-%-suffix + struct (incomplete-%-suffix cgi-error) (chars) + chars : list of chars + + Used when a % in a query is followed by an incomplete suffix. The + characters of the suffix -- excluding the "%" -- are provided by the + exception. + +> invalid-%-suffix + struct (invalid-%-suffix cgi-error) (char) + char : char + + Used when the character immediately following a % in a query is + invalid. + +PROCEDURES ----------------------------------------------------------- + +> (get-bindings) -> bindings +> (get-bindings/post) -> bindings +> (get-bindings/get) -> bindings + + Returns the bindings that corresponding to the options specified by + the user. The /post and /get forms work only when POST and GET + forms are used, respectively, while get-bindings determines the kind + of form that was used and invokes the appropriate function. + +> (extract-bindings symbol-or-string bindings) -> list of strings + + Given a key and a set of bindings, extract-bindings determines which + ones correspond to a given key. There may be zero, one, or many + associations for a given key. + +> (extract-binding/single symbol-or-string bindings) -> string + + Given a key and a set of bindings, extract-binding/single ensures + that the key has exactly one association, and returns it. + +> (generate-html-output html-string list-of-html-strings [color color color color color]) -> void + + The first argument is the title. The second is a list of strings + that consist of the body. The last five arguments are each strings + representing a HTML color; in order, they represent the color of the + text, the background, un-visited links, visited links, and a link + being selected. + +> (string->html string) -> html-string + + Converts a string into an html-string by applying the appropriate + HTML quoting conventions. + +> (generate-link-text string html-string) -> html-string + + Takes a string representing a URL, a html-string for the anchor + text, and generates HTML corresponding to an achor. + +> (generate-error-output list-of-html-strings) -> + + The procedure takes a series of strings representing the body, + prints them with the subject line "Internal error", and forces the + script to exit. + +> (get-cgi-method) -> string + + Returns either "GET" or "POST". Always returns a string when + invoked inside a CGI script. Unpredictable otherwise. + +> (bindings-as-html bindings) -> list of html-strings + + Converts a set of bindings into a list of html-string's. Useful for + debugging. + +========================================================================== +_sending mail_, _sendmail_ +========================================================================== + +Collection: net +Files: _mail.ss_, _mailr.ss_, _mails.ss_, _mailu.ss_ + +ABSTRACT ------------------------------------------------------------- + +The mail package helps programmers write programs that need to send +electronic mail messages. The package assumes the existence of a +conformant sendmail program on the local system; see also the SMTP +package, below. + +TYPES ---------------------------------------------------------------- + + All strings used in mail messages are assumed to conform to their + corresponding SMTP specifications, except as noted otherwise. + +EXCEPTIONS ----------------------------------------------------------- + +> no-mail-recipients + struct (no-mail-recipients exn) () + + Raised when no mail recipients were specified. + +PROCEDURES ----------------------------------------------------------- + +> (send-mail-message/port from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string) -> output-port + + The first argument is the header for the sender, the second is the + subject line, the third a list of To: recipients, the fourth a list + of CC: recipients, and the fifth a list of BCC: recipients. The + optional sixth argument is used for other mail headers, which must + be specified completely formatted. + + The return value is an output port into which the client must write + the message. Clients are urged to use close-output-port on the + return value as soon as the necessary text has been written, so that + the sendmail process can complete. + + The sender can hold any value, though of course spoofing should be + used with care. + +> (send-mail-message from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string body-list-of-strings [extra-headers-list-of-strings]) -> void + + The arguments are the same as that for send-mail-message/port except + that there is one extra input, the list of strings corresponding to + the mail message (followed by the optional additional headers, if + present). There is no interesting return value. + + Lines that contain a single period do not need to be quoted. + +========================================================================== +_sending mail_, _SMTP_ +========================================================================== + +Collection: net +Files: _smtp.ss_, _smtpr.ss_, _smtps.ss_ + +ABSTRACT ------------------------------------------------------------- + +The SMTP package helps programmers write programs that need to send +electronic mail messages using SMTP. The client must provide the +address of an SMTP server; in contrast, the mail package (see above) +uses a pre-configured sendmail on the local system. + +TYPES ---------------------------------------------------------------- + + The head package defines the format of a `header' string, which is + used by `send-smtp-message'. The head package also provides + utilities to verify the formatting of a mail address. The procedures + of the SMTP package assume that the given string arguments are + well-formed. + +EXCEPTIONS ----------------------------------------------------------- + + Communication errors are signalled via exn:user structure instances. + +PROCEDURES ----------------------------------------------------------- + +> (smtp-send-message server-string from-string to-list-of-strings header message-list-of-strings [port]) -> void + + The first argument is the IP address of the SMTP server. The + `from-string' argument specifies the mail address of the sender, and + `to-listof-strings' is a list of recipient addresses (including + "To", "CC", and "BCC" recipients). The `header' argument is the + complete message header, which should already include "From", "To", + and "CC" fields consistent with the given sender and recipients. + the `message-list-of-strings' argument is the body of the message, + where each string in the list corresponds to a single line of + message text; no string in `message-list-of-strings' should contain + a carriage return or newline characters. The optional `port' + argument specifies the IP port to use in contacting the SMTP server; + the default is 25. + + See the head package for utilities that construct a message headers + and validate mail address strings. + +> (smtp-sending-end-of-message [proc]) + + Parameter that detemines a send-done procedure to be called after + `smtp-send-message' has completely sent the message. Before the + send-done procedure is called, breaking the thread that is executing + `smtp-send-message' cancels the send. After the send-done procedure + is called, breaking may or may not cancel the send (and probably + won't). + +========================================================================== +_NNTP_, _newsgroups_ +========================================================================== + +Collection: net +Files: _nntp.ss_, _nntpr.ss_, _nntps.ss_, _nntpu.ss_ + +ABSTRACT ------------------------------------------------------------- + +The nntp package helps programmers access Usenet groups via the NNTP +protocols. + +TYPES ---------------------------------------------------------------- + +> communicator + struct communicator (sender receiver server port) + sender : oport + receiver : iport + server : string + port : number + + Once a connection to a Usenet server has been established, its state + is stored in a communicator, and other procedures take communicators + as an argument. + +> desired + + A regular expression that matches against a Usenet header. + +EXCEPTIONS ----------------------------------------------------------- + +> nntp + struct (nntp exn) () + + The super-struct of all subsequent exceptions. + +> unexpected-response + struct (unexpected-response nntp) (code text) + code : number + text : string + + Thrown whenever an unexpected response code is received. The text + holds the response text sent by the server. + +> bad-status-line + struct (bad-status-line nntp) (line) + line : string + + Mal-formed status lines. + +> premature-close + struct (premature-close nntp) (communicator) + communicator : communicator + + Thrown when a remote server closes its connection unexpectedly. + +> bad-newsgroup-line + struct (bad-newsgroup-line nntp) (line) + line : string + + When the newsgroup line is improperly formatted. + +> non-existent-group + struct (non-existent-group nntp) (group) + group : string + + When the server does not recognize the name of the requested group. + +> article-not-in-group + struct (article-not-in-group nntp) (article) + article : number + + When an article is outside the server's range for that group. + +> no-group-selected + struct (no-group-selected nntp) () + + When an article operation is used before a group has been selected. + +> article-not-found + struct (article-not-found nntp) (article) + article : number + + When the server is unable to locate the article. + +PROCEDURES ----------------------------------------------------------- + +> (connect-to-server server-string [port-number]) -> communicator + + Connects to the name server. The second argument, if provided, must + be a port number; otherwise the default NNTP port is used. + +> (disconnect-from-server communicator) -> void + + Disconnects a communicator. + +> (open-news-group communicator newsgroup-string) -> three values: number number number + + The second argument is the name of a newsgroup. The returned values + are the total number of articles in that group, the first available + article, and the last available article. + +> (head-of-message communicator message-number) -> list of strings + + Given a message number, returns its headers. + +> (body-of-message communicator message-number) -> list of strings + + Given a message number, returns the body of the message. + +> (make-desired-header tag-string) -> desired + + Takes the header's tag and returns a desired regexp for that header. + +> (extract-desired-headers list-of-header-strings list-of-desireds) -> list of strings + + Given a list of headers and of desired's, returns the header lines + that match any of the desired's. + +========================================================================== +_POP-3_, _reading mail_ +========================================================================== + +Collection: net +Files: _pop3.ss_, _pop3r.ss_, _pop3s.ss_, _pop3u.ss_ + +Note: The pop3.ss invoke-opens the pop3r.ss unit with a "pop3:" prefix. + +ABSTRACT ------------------------------------------------------------- + +Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose. +http://www.cis.ohio-state.edu/htbin/rfc/rfc1939.html + +TYPES ---------------------------------------------------------------- + +> communicator + struct communicator (sender receiver server port state) + sender : oport + receiver : iport + server : string + port : number + state : symbol = (disconnected, authorization, transaction) + + Once a connection to a POP-3 server has been established, its state + is stored in a communicator, and other procedures take communicators + as an argument. + +> desired + + A regular expression that matches against a mail header. + +EXCEPTIONS ----------------------------------------------------------- + +> pop3 + struct (pop3 exn) () + + The super-struct used for all other package exceptions. + +> cannot-connect + struct (cannot-connect pop3) () + + When a connection to a server cannot be established. + +> username-rejected + struct (username-rejected pop3) () + + If the username is rejected. + +> password-rejected + struct (password-rejected pop3) () + + If the password is rejected. + +> not-ready-for-transaction + struct (not-ready-for-transaction pop3) (communicator) + communicator : communicator + + When the communicator is not in transaction mode. + +> not-given-headers + struct (not-given-headers pop3) (communicator message) + communicator : communicator + message : number + + When the server does not respond with headers for a message as + requested. + +> illegal-message-number + struct (illegal-message-number pop3) (communicator message) + communicator : communicator + message : number + + When the user specifies an illegal message number. + +> cannot-delete-message + struct (cannot-delete-message exn) (communicator message) + communicator : communicator + message : number + + When the server is unable to delete a message. + +> disconnect-not-quiet + struct (disconnect-not-quiet pop3) (communicator) + communicator : communicator + + When the server does not gracefully disconnect. + +> malformed-server-response + struct (malformed-server-response pop3) (communicator) + communicator : communicator + + When the server produces a mal-formed response. + +PROCEDURES ----------------------------------------------------------- + +> (connect-to-server server-string [port-number]) -> communicator + + Connects to a server. Uses the default port number if none is + provided. + +> (disconnect-from-server communicator) -> void + + Disconnects from as server. Sets the communicator state to + disconnected. + +> (authenticate/plain-text user-string passwd-string communicator) -> void + + Takes a username and password string and, if successful, changes the + communicator's state to transaction. + +> (get-mailbox-status communicator) -> two values: count-number octet-number + + Returns the number of messages and the number of octets. + +> (get-message/complete communicator message-number) -> two lists of strings + + Given a message number, returns a list of headers and list of + strings for the body. + +> (get-message/headers communicator message-number) -> list of strings + + Given a message number, returns the list of headers. + +> (get-message/body communicator message-number) -> list of strings + + Given a message number, returns the list of strings for the body. + +> (delete-message communicator message-number) -> void + + Deletes the specified message. + +> (get-unique-id/single communicator message-number) -> string + + Gets the server's unique id for a particular message. + +> (get-unique-id/all communicator) -> list of (cons message-number id-string) + + Gets a list of unique id's from the server for all the messages in + the mailbox. + +> (make-desired-header tag-string) -> desired + + Takes the header's tag and returns a desired regexp for that header. + +> (extract-desired-headers list-of-strings list-of-desireds) -> list of strings + + Given a list of headers and of desired's, returns the header lines + that match any of the desired's. + +EXAMPLE -------------------------------------------------------------- + + > (require-library "pop3.ss" "net") + > (define c (pop3:connect-to-server "cs.rice.edu")) + > (pop3:authenticate/plain-text "scheme" "********" c) + > (pop3:get-mailbox-status c) + 196 + 816400 + > (pop3:get-message/headers c 100) + ("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)" + "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>" + "From: Shriram Krishnamurthi " + ... + "Status: RO") + > (pop3:get-message/complete c 100) + ("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)" + "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>" + "From: Shriram Krishnamurthi " + ... + "Status: RO") + ("some body" "text" "goes" "." "here" "." "") + > (pop3:get-unique-id/single c 205) + no message numbered 205 available for unique id + > (list-tail (pop3:get-unique-id/all c) 194) + ((195 . "e24d13c7ef050000") (196 . "3ad2767070050000")) + > (pop3:get-unique-id/single c 196) + "3ad2767070050000" + > (pop3:disconnect-from-server c) + +========================================================================== +_IMAP_, _reading mail_ +========================================================================== + +Collection: net +Files: _imap.ss_, _imapr.ss_, _imaps.ss_ + +ABSTRACT ------------------------------------------------------------- + +Implements portions of client-side RFC 2060, Internet Message Access +Protocol - Version 4rev1, Crispin, http://www.isi.edu/in-notes/rfc2060.txt + +TYPES ---------------------------------------------------------------- + +> imap + + An opaque record reprsenting an IMAP connection. + +> imap-flag + + A symbol, but generally not a convenient one to use within a Scheme + program. The `imap-flag->symbol' and `symbol->imap-flag' procedures + convert IMAP flags to convenient symbols and vice-versa. + +EXCEPTIONS ----------------------------------------------------------- + + Communication errors are signalled via exn:user structure instances. + +PROCEDURES ----------------------------------------------------------- + +> (imap-connect server-string username-string password-string mailbox-string) + -> three values: imap, message count, recent message count + + Establishes an IMAP connection to the given server using the given + username and password, and selects the specified mailbox. The second + and third return values indicate the total number of message in the + mailbox and the number of recent messages (i.e., messages received + since the mailbox was last selected), respectively. + + See also `imap-port-number', below. + + A user's primary mailbox is always called "INBOX". + +> (imap-disconnect imap) -> void + + Closes an IMAP connection. The close may fail due to a communication + error. + +> (imap-force-disconnect imap) -> void + + Closes an IMAP connection forcefully (i.e., without send a close + message to the server). A forced disconnect never fails. + +> (imap-reselect imap mailbox-string) + -> two values: message count and recent message count + + De-selects the mailbox currently selected by the connection and + selects the specified mailbox, returning the total and recent + message counts for the new mailbox. + + This procedure is useful for polling a mailbox to see whether there + are any new messages (by providing the currently selected mailbox as + the new mailbox), but use imap-status with the 'uidnext flag to + determine whether a mailbox has changed at all (e.g., via a copy + instead of a move). + +> (imap-status imap mailbox-string status-symbol-list) + -> list of status values + + Requests information about a mailbox from the server. The + status-symbol-list specifies the request, and the return value + includes one value for each symbol in status-symbol-list. The + allowed status symbols are: + 'messages - number of messages + 'recent - number of recent messages + 'unseen - number of unseen messages + 'uidnext - uid for next received message + 'uidvalidity - id that changes when all uids are changed + +> (imap-get-messages imap msg-num-list field-list) + -> list of field-value lists + + Downloads information for a set of messages. The `msg-num-list' + argument specifies a set of messages by their message positions (not + their uids). The `field-list' argument specifies the type of + information to download for each message. The avilable fields are: + + * 'uid - value is an integer + * 'header - value is a header (string; see the head package) + * 'body - value is a string (with CRLF-separated lines) + * 'flags - value is a list of imap flags + + The return value is a list of entry items in parallel to + `msg-num-list'. Each entry is itself a list containing value items + in parallel to `field-list'. + + Example: + (imap-get-message imap '(1 3 5) '(uid header)) + ; => ((107 "From: larry@stooges.com ...") + (110 "From: moe@stooges.com ...") + (112 "From: curly@stooges.com ...")) + +> (imap-flag->symbol imap-flag) -> symbol +> (symbol->imap-flag symbol) -> imap-flag + + An imap flag is a symbol, but it is generally not a convenient one + to use within a Scheme program, because it usually starts with a + backslash and flag comparisions are case-insensitive. The + `imap-flag->symbol' and `symbol->imap-flag' procedures convert IMAP + flags to convenient symbols and vice-versa: + + symbol imap flag + ------ ---------- + 'seen '|\Seen| \ + 'answered '|\Answered| | + 'flagged '|\Flagged| > message flags + 'deleted '|\Deleted| | + 'draft '|\Draft| | + 'recent '|\Recent| / + + 'noinferiors '|\Noinferiors| \ + 'noselect '|\Noselect| > mailbox flags + 'marked '|\Marked| | + 'unmarked '|\Unmarked| / + + `imap-flag->symbol' and `symbol->imap-flag' act like the identity + function when any other symbol/flag is provided. + +> (imap-store imap mode msg-num-list imap-flags) -> void + + Sets flags for a set of messages. The mode argument specifies how + flags are set: + + * '+ - add the given flags to each message + * '- - remove the given flags from each emssage + * '! - set each message's flags to the given set + + The `msg-num-list' argument specifies a set of messages by their + message positions (not their uids). The `flags' argument specifies + the imap flags to add/remove/install. + + Example: + (imap-store imap '+ '(1 2 3) (list (symbol->imap-flag 'deleted))) + ; marks the first three messages to be deleted + (imap-expunge imap) + ; permanently removes the first three messages (and possibly others) + ; from the currently-selected mailbox + +> (imap-expunge imap) -> void + + Purges every message currently marked with the '|\Deleted| flag from + the mailbox. + +> (imap-copy imap msg-num-list dest-mailbox-string) -> void + + Copies the specified messages from the currently selected mailbox to + the specified mailbox. + +> (imap-mailbox-exists? imap mailbox-string) -> bool + + Returns #t if the specified mailbox exists, #f otherwise. + +> (imap-create-mailbox imap mailbox-string) -> void + + Creates the specified mailbox. (It must not exist already.) + +> (imap-list-child-mailboxes imap mailbox-string [delimiter-string]) + -> list of mailbox-info lists + + Returns information about sub-mailboxes of the given mailbox. If + mailbox-string is #f, information about all top-level mailboxes is + returned. The optional `delimiter-string' is determined + automatically (via `imap-get-hierarchy-delimiter') if it is not + provided. + + The return value is a list of mailbox-information lists. Each + mailbox-information list contains two items: + * a list of imap flags for the mailbox + * the mailbox's name + +> (imap-get-hierarchy-delimiter imap) -> string + + Returns the server-specific string that is used as a separator in + mailbox path names. + +> (imap-port-number [k]) + + A parameter that determines the server port number. The initial + value is 143. + +========================================================================== +_mail headers_ +========================================================================== + +Collection: net +Files: _head.ss_, _headr.ss_, _heads.ss_ + +ABSTRACT ------------------------------------------------------------- + +Implements utlities for RFC 822 headers and mail addresses. + +TYPES ---------------------------------------------------------------- + +> header + + A string that is an RFC-882-compliant header. A header string + contains a series of CRLF-delimitted fields, and ends with two CRLFs + (the first one terminates the last field, and the second terminates + the header). + +PROCEDURES ----------------------------------------------------------- + +> empty-header + + A string correcponding to the empty header, useful for building up + headers with `insert-field' and `append-headers'. + +> (validate-header candidate-header-string) -> void + + If the format of `candidate-header-string' matches RFC 822, void is + returned, otherwise an exception is raised. + +> (extract-field field-string header) -> string or #f + + Returns the header content for the specified field, or #f if the + field is not in the header. `field-string' should not end with ":", + and it is used case-insensitively. The returned string will not + contain the field name, color separator, of CRLF terminator for the + field; however, if the field spans multiple lines, the CRLFs + separating the lines will be intact. + + Example: + (extract-field "TO" (insert-field "to" "me@localhost" empty-header)) + ; => "me@localhost" + +> (remove-field field-string header) -> header + + Creates a new header by removing the specified field from `header' + (or the first instance of the field, if it occurs multiple + times). If the field is not in `header', then the return value is + `header'. + +> (insert-field field-string value-string header) -> header + + Creates a new header by prefixing the given header with the given + field-value pair. `value-string' should not contain a terminating + CRLF, but a multi-line value (perhaps created with + `data-lines->data') may contain seperator CRLFs. + +> (append-headers a-header another-header) -> header + +> (standard-message-header from-string to-list-of-strings cc-list-of-strings bcc-list-of-strings subject-string) -> header + + Creates a standard mail header given the sender, various lists of + recipients, and a subject. (The BCC recipients do not acually appear + in the header, but they're accepted anyway to complete the + abstarction.) + +> (data-lines->data list-of-strings) -> string + + Merges multiple lines for a single field value into one string, + adding CRLF-TAB separators. + +> (extract-addresses string kind) -> list of strings or + list of list of strings + + Parses `string' as a list of comma-delimited mail addresses, raising + an exception if the list is ill-formed. This procedure can be used + for single-address strings, in which case the returned list should + contain only one address. + + The `kind' argument specifies which portion of an address should be + returned: + + * 'name - the free-form name in the address, or the address + itself if no name is available: + "John Doe " => "Jon Doe" + "doe@localhost (Johnny Doe)" => "Johnny Doe" + "doe@localhost" => "doe@localhost" + + * 'address - just the mailing address, without any free-form + names: + "Jon Doe " => "doe@localhost" + "doe@localhost (Johnny Doe)" => "doe@localhost" + "doe@localhost" => "doe@localhost" + + * 'full - the full address, essentially as it appears in the + input, but normalized: + "Jon Doe < doe@localhost >" => "Jon Doe " + " doe@localhost (Johnny Doe)" => "doe@localhost (Johnny Doe)" + "doe@localhost" => "doe@localhost" + + * 'all - a list containing each of the three posibilities: + free-form name, address, and full address (in that + order) + + Example: + (extract-addresses " \"Doe, John\" , john" 'address) + ; => ("doe@localhost" "john") + +> (assemble-address-field list-of-address-strings) -> string + + Creates a header field value from a list of addresses. The addresses + are comma-separated, and possibly broken into multiple lines. + +========================================================================== +_DNS_, _domain name service_ +========================================================================== + +Collection: net +Files: _dns.ss_, _dnsr.ss_, _dnss.ss_ + +ABSTRACT ------------------------------------------------------------- + +Implements a DNS client, based on RFC 1035 + +PROCEDURES ----------------------------------------------------------- + +> (dns-get-address nameserver-string address-string) -> address-string + + Consults the specified nameserver (normally a numerical address like + "128.42.1.30") to obtain a numerical address for the given internet + address. + + The query record sent to the DNS server includes the "recursive" + bit, but `dns-get-address' also implements a recursive search itself + in case the server does not provide this optional feature. + +> (dns-get-mail-exchanger nameserver-string address-string) -> address-string + + Consults the specified nameserver to obtain the address for a mail + exchanger the given mail host address. For example, the mail + exchanger for "ollie.cs.rice.edu" is currently "cs.rice.edu". + +> (dns-find-nameserver) -> address-string or #f + + Attempts to find the address of a nameserver on the present system. + Under Unix, this procedure parses /etc/resolv.conf to extract the + first nameserver address. + +========================================================================== +_Base 64 Encoding_, _base64_ +========================================================================== + +Collection: net +Files: _base64.ss_, _base64r.ss_, _base64s.ss_ + +ABSTRACT ------------------------------------------------------------- + +Implements a Base 64 (mime-standard) encoder. (We'll implement a +decoder eventually.) + +PROCEDURES ----------------------------------------------------------- + +> (base64-encode string) -> string + + Consumes a string and returns its base64 encoding as a new string. + The returned string is broken into 72-character lines separated by + CRLF combinations, and it always ends with the "=" base64 + terminator. diff --git a/collects/net/head.ss b/collects/net/head.ss new file mode 100644 index 00000000..e9c8b16e --- /dev/null +++ b/collects/net/head.ss @@ -0,0 +1,8 @@ + +(require-relative-library "heads.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:head^ + (require-relative-library "headr.ss")) diff --git a/collects/net/headr.ss b/collects/net/headr.ss new file mode 100644 index 00000000..37ad57de --- /dev/null +++ b/collects/net/headr.ss @@ -0,0 +1,243 @@ + +(unit/sig mzlib:head^ + (import) + + (define empty-header (string #\return #\newline)) + + (define (string->ci-regexp s) + (list->string + (apply + append + (map + (lambda (c) + (cond + [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^)) + (list #\\ c)] + [(char-alphabetic? c) + (list #\[ (char-upcase c) (char-downcase c) #\])] + [else (list c)])) + (string->list s))))) + + (define re:field-start (regexp + (format "^[^~a~a~a~a~a:~a-~a]*:" + #\space #\tab #\linefeed #\return #\vtab + (integer->char 1) + (integer->char 26)))) + (define re:continue (regexp (format "^[~a~a~a]" #\space #\tab #\vtab))) + + (define (validate-header s) + (let ([len (string-length s)]) + (let loop ([offset 0]) + (cond + [(and (= (+ offset 2) len) + (string=? empty-header (substring s offset len))) + (void)] ; validated + [(= offset len) (error 'validate-header "missing ending CRLF")] + [(or (regexp-match re:field-start s offset) + (regexp-match re:continue s offset)) + (let ([m (regexp-match-positions (string #\return #\linefeed) s offset)]) + (if m + (loop (cdar m)) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (substring s offset (string-length s)))])))) + + (define (make-field-start-regexp field) + (format "(^|[~a][~a])(~a: *)" + #\return #\linefeed + (string->ci-regexp field))) + + (define (extract-field field header) + (let ([m (regexp-match-positions + (make-field-start-regexp field) + header)]) + (and m + (let ([s (substring header + (cdaddr m) + (string-length header))]) + (let ([m (regexp-match-positions + (format "[~a][~a][^: ~a~a]*:" + #\return #\linefeed + #\return #\linefeed) + s)]) + (if m + (substring s 0 (caar m)) + ; Rest of header is this field, but strip trailing CRLFCRLF: + (regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed) + s + ""))))))) + + (define (remove-field field header) + (let ([m (regexp-match-positions + (make-field-start-regexp field) + header)]) + (if m + (let ([pre (substring header + 0 + (caaddr m))] + [s (substring header + (cdaddr m) + (string-length header))]) + (let ([m (regexp-match-positions + (format "[~a][~a][^: ~a~a]*:" + #\return #\linefeed + #\return #\linefeed) + s)]) + (if m + (string-append pre (substring s (+ 2 (caar m)) + (string-length s))) + pre))) + header))) + + (define (insert-field field data header) + (let ([field (format "~a: ~a~a~a" + field + data + #\return #\linefeed)]) + (string-append field header))) + + (define (append-headers a b) + (let ([alen (string-length a)]) + (if (> alen 1) + (string-append (substring a 0 (- alen 2)) b) + (error 'append-headers "first argument is not a header: ~a" a)))) + + (define (standard-message-header from tos ccs bccs subject) + (let ([h (insert-field + "Subject" subject + empty-header)]) + ; NOTE: bccs don't go into the header; that's why + ; they're "blind" + (let ([h (if (null? ccs) + h + (insert-field + "CC" (assemble-address-field ccs) + h))]) + (let ([h (if (null? tos) + h + (insert-field + "To" (assemble-address-field tos) + h))]) + (insert-field + "From" from + h))))) + + (define (splice l sep) + (if (null? l) + "" + (format "~a~a" + (car l) + (apply + string-append + (map + (lambda (n) (format "~a~a" sep n)) + (cdr l)))))) + + (define (data-lines->data datas) + (splice datas (format "~a~a~a" #\return #\linefeed #\tab))) + + ;;; Extracting Addresses ;;; + + (define blank (format "[~a~a~a~a~a]" #\space #\tab #\newline #\return #\vtab)) + (define re:all-blank (regexp (format "^~a*$" blank))) + + (define (extract-addresses s form) + (unless (memq form '(name address full all)) + (raise-type-error 'extract-addresses + "form: 'name, 'address, 'full, or 'all" + form)) + (if (or (not s) (regexp-match re:all-blank s)) + null + (let loop ([prefix ""][s s]) + ; Which comes first - a quote or a comma? + (let ([mq (regexp-match-positions "\"[^\"]*\"" s)] + [mc (regexp-match-positions "," s)]) + (if (and mq mc (< (caar mq) (caar mc) (cdar mq))) + ; Quote contains a comma + (loop (string-append + prefix + (substring s 0 (cdar mq))) + (substring s (cdar mq) (string-length s))) + ; Normal comma parsing: + (let ([m (regexp-match "([^,]*),(.*)" s)]) + (if m + (let ([n (extract-one-name (string-append prefix (cadr m)) form)] + [rest (extract-addresses (caddr m) form)]) + (cons n rest)) + (let ([n (extract-one-name (string-append prefix s) form)]) + (list n))))))))) + + (define (select-result form name addr full) + (case form + [(name) name] + [(address) addr] + [(full) full] + [(all) (list name addr full)])) + + (define (one-result form s) + (select-result form s s s)) + + (define (extract-one-name s form) + (cond + [(regexp-match (format "^~a*(\"[^\"]*\")(.*)" blank) s) + => (lambda (m) + (let ([name (cadr m)] + [addr (extract-angle-addr (caddr m))]) + (select-result form name addr + (format "~a <~a>" name addr))))] + ; ?!?!? Where does the "addr (name)" standard come from ?!?!? + [(regexp-match (format "(.*)[(]([^)]*)[)]~a*$" blank) s) + => (lambda (m) + (let ([name (caddr m)] + [addr (extract-simple-addr (cadr m))]) + (select-result form name addr + (format "~a (~a)" addr name))))] + [(regexp-match (format "^~a*(.*)(<.*>)~a*$" blank blank) s) + => (lambda (m) + (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")] + [addr (extract-angle-addr (caddr m))]) + (select-result form name addr + (format "~a <~a>" name addr))))] + [(or (regexp-match "<" s) (regexp-match ">" s)) + (one-result form (extract-angle-addr s))] + [else + (one-result form (extract-simple-addr s))])) + + (define (extract-angle-addr s) + (if (or (regexp-match "<.*<" s) (regexp-match ">.*>" s)) + (error 'extract-address "too many angle brackets: ~a" s) + (let ([m (regexp-match (format "~a*<([^>]*)>~a*" blank blank) s)]) + (if m + (extract-simple-addr (cadr m)) + (error 'extract-address "cannot parse address: ~a" s))))) + + (define (extract-simple-addr s) + (cond + [(regexp-match "[,\"()<>]" s) + (error 'extract-address "cannot parse address: ~a" s)] + [else + ; final whitespace strip + (regexp-replace + (format "~a*$" blank) + (regexp-replace (format "~a*" blank) s "") + "")])) + + (define (assemble-address-field addresses) + (if (null? addresses) + "" + (let loop ([addresses (cdr addresses)] + [s (car addresses)] + [len (string-length (car addresses))]) + (if (null? addresses) + s + (let* ([addr (car addresses)] + [alen (string-length addr)]) + (if (<= 72 (+ len alen)) + (loop (cdr addresses) + (format "~a,~a~a~a~a" + s #\return #\linefeed + #\tab addr) + alen) + (loop (cdr addresses) + (format "~a, ~a" s addr) + (+ len alen 2))))))))) diff --git a/collects/net/heads.ss b/collects/net/heads.ss new file mode 100644 index 00000000..c6c9a2f1 --- /dev/null +++ b/collects/net/heads.ss @@ -0,0 +1,12 @@ + +(define-signature mzlib:head^ + (empty-header + validate-header + extract-field + remove-field + insert-field + append-headers + standard-message-header + data-lines->data + extract-addresses + assemble-address-field)) diff --git a/collects/net/imap.ss b/collects/net/imap.ss new file mode 100644 index 00000000..844c4842 --- /dev/null +++ b/collects/net/imap.ss @@ -0,0 +1,8 @@ + +(require-relative-library "imaps.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:imap^ + (require-relative-library "imapr.ss")) diff --git a/collects/net/imapr.ss b/collects/net/imapr.ss new file mode 100644 index 00000000..f6f0ba64 --- /dev/null +++ b/collects/net/imapr.ss @@ -0,0 +1,379 @@ + +(unit/sig mzlib:imap^ + (import) + + (define debug-via-stdio? #f) + + (define eol (if debug-via-stdio? + 'linefeed + 'return-linefeed)) + + (define crlf (string #\return #\linefeed)) + + (define (tag-eq? a b) + (or (eq? a b) + (and (symbol? a) + (symbol? b) + (string-ci=? (symbol->string a) + (symbol->string b))))) + + (define field-names + (list + (list 'uid (string->symbol "UID")) + (list 'header (string->symbol "RFC822.HEADER")) + (list 'body (string->symbol "RFC822.TEXT")) + (list 'size (string->symbol "RFC822.SIZE")) + (list 'flags (string->symbol "FLAGS")))) + + (define flag-names + (list + (list 'seen (string->symbol "\\Seen")) + (list 'answered (string->symbol "\\Answered")) + (list 'flagged (string->symbol "\\Flagged")) + (list 'deleted (string->symbol "\\Deleted")) + (list 'draft (string->symbol "\\Draft")) + (list 'recent (string->symbol "\\Recent")) + + (list 'noinferiors (string->symbol "\\Noinferiors")) + (list 'noselect (string->symbol "\\Noselect")) + (list 'marked (string->symbol "\\Marked")) + (list 'unmarked (string->symbol "\\Unmarked")))) + + (define (imap-flag->symbol f) + (or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) + flag-names) + f)) + + (define (symbol->imap-flag s) + (let ([a (assoc s flag-names)]) + (if a + (cadr a) + s))) + + (define (log-warning . args) + ; (apply printf args) + (void)) + (define log log-warning) + + (define make-msg-id + (let ([id 0]) + (lambda () + (begin0 + (format "a~a " id) + (set! id (add1 id)))))) + + (define (starts-with? l n) + (and (>= (string-length l) (string-length n)) + (string=? n (substring l 0 (string-length n))))) + + (define (skip s n) + (substring s + (if (number? n) n (string-length n)) + (string-length s))) + + (define (splice l sep) + (if (null? l) + "" + (format "~a~a" + (car l) + (apply + string-append + (map + (lambda (n) (format "~a~a" sep n)) + (cdr l)))))) + + (define (imap-read s r) + (let loop ([s s] + [r r] + [accum null] + [eol-k (lambda (accum) (reverse! accum))] + [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))]) + (cond + [(string=? "" s) (eol-k accum)] + [(char-whitespace? (string-ref s 0)) + (loop (skip s 1) r accum eol-k eop-k)] + [else + (case (string-ref s 0) + [(#\") (let ([m (regexp-match "\"([^\"]*)\"(.*)" s)]) + (if m + (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k) + (error 'imap-read "didn't find end of quoted string in: ~a" s)))] + [(#\)) (eop-k (skip s 1) accum)] + [(#\() (letrec ([next-line + (lambda (accum) + (loop (read-line r eol) r + accum + next-line + finish-parens))] + [finish-parens + (lambda (s laccum) + (loop s r + (cons (reverse! laccum) accum) + eol-k eop-k))]) + (loop (skip s 1) r null next-line finish-parens))] + [(#\{) (let ([m (regexp-match "{([0-9]+)}(.*)" s)]) + (cond + [(not m) (error 'imap-read "couldn't read {} number: ~a" s)] + [(not (string=? (caddr m) "")) (error 'imap-read "{} not at end-of-line: ~a" s)] + [else (loop "" r + (cons (read-string (string->number (cadr m)) r) + accum) + eol-k eop-k)]))] + [else (let ([m (regexp-match "([^ (){}]+)(.*)" s)]) + (if m + (loop (caddr m) r + (cons (let ([v (cadr m)]) + (if (regexp-match "^[0-9]*$" v) + (string->number v) + (string->symbol (cadr m)))) + accum) + eol-k eop-k) + (error 'imap-read "failure reading atom: ~a" s)))])]))) + + (define (imap-send r w cmd info-handler) + (let ([id (make-msg-id)]) + (log "sending ~a~a~n" id cmd) + (fprintf w "~a~a~a" id cmd crlf) + (let loop () + (let ([l (read-line r eol)]) + ; (log "raw-reply: ~s~n" l) + (cond + [(starts-with? l id) + (let ([reply (imap-read (skip l id) r)]) + (log "response: ~a~n" reply) + reply)] + [(starts-with? l "* ") + (let ([info (imap-read (skip l 2) r)]) + (log "info: ~s~n" info) + (info-handler info)) + (loop)] + [(starts-with? l "+ ") + (error 'imap-send "unexpected continuation request: ~a" l)] + [else + (log-warning "warning: unexpected response for ~a: ~a" id l) + (loop)]))))) + + (define (str->arg s) + (if (or (regexp-match " " s) + (string=? s "")) + (format "\"~a\"" s) + s)) + + (define (check-ok reply) + (unless (and (pair? reply) + (tag-eq? (car reply) 'OK)) + (error 'check-ok "server error: ~s" reply))) + + (define-struct imap-connection (r w)) + + (define imap-port-number (make-parameter 143)) + + (define (imap-connect server username password inbox) + ; => imap count-k recent-k + (let-values ([(r w) (if debug-via-stdio? + (begin + (printf "stdin == ~a~n" server) + (values (current-input-port) (current-output-port))) + (tcp-connect server (imap-port-number)))]) + (with-handlers ([void + (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + + (check-ok (imap-send r w "NOOP" void)) + (let ([reply (imap-send r w (format "LOGIN ~a ~a" + (str->arg username) + (str->arg password)) + void)]) + (if (and (pair? reply) (tag-eq? 'NO (car reply))) + (error "username or password rejected by server") + (check-ok reply))) + + (let ([imap (make-imap-connection r w)]) + (let-values ([(init-count init-recent) + (imap-reselect imap inbox)]) + (values imap + init-count + init-recent)))))) + + (define (imap-reselect imap inbox) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (let ([init-count 0] + [init-recent 0]) + (check-ok (imap-send r w (format "SELECT ~a" (str->arg inbox)) + (lambda (i) + (when (and (list? i) (= 2 (length i))) + (cond + [(tag-eq? (cadr i) 'EXISTS) + (set! init-count (car i))] + [(tag-eq? (cadr i) 'RECENT) + (set! init-recent (car i))]))))) + (values init-count init-recent)))) + + (define (imap-status imap inbox flags) + (unless (and (list? flags) + (andmap (lambda (s) + (memq s '(messages recent uidnext uidvalidity unseen))) + flags)) + (raise-type-error 'imap-status "list of status flag symbols" flags)) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (let ([results null]) + (check-ok (imap-send r w (format "STATUS ~a ~a" (str->arg inbox) flags) + (lambda (i) + (when (and (list? i) (= 3 (length i)) + (tag-eq? (car i) 'STATUS)) + (set! results (caddr i)))))) + (map + (lambda (f) + (let loop ([l results]) + (cond + [(or (null? l) (null? (cdr l))) #f] + [(tag-eq? f (car l)) (cadr l)] + [else (loop (cdr l))]))) + flags)))) + + (define (imap-disconnect imap) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (check-ok (imap-send r w "LOGOUT" void)) + (close-input-port r) + (close-output-port w))) + + (define (imap-force-disconnect imap) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (close-input-port r) + (close-output-port w))) + + (define (imap-get-messages imap msgs field-list) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (when (or (not (list? msgs)) + (not (andmap integer? msgs))) + (raise-type-error 'imap-get-messages "non-empty message list" msgs)) + (when (or (null? field-list) + (not (list? field-list)) + (not (andmap (lambda (f) (assoc f field-names)) field-list))) + (raise-type-error 'imap-get-messages "non-empty field list" field-list)) + + (if (null? msgs) + null + (let ([results null]) + (imap-send r w (format "FETCH ~a (~a)" + (splice msgs ",") + (splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " ")) + (lambda (i) + (when (and (list? i) (<= 2 (length i)) + (tag-eq? (cadr i) 'FETCH)) + (set! results (cons i results))))) + (map + (lambda (msg) + (let ([m (assoc msg results)]) + (unless m + (error 'imap-get-messages "no result for message ~a" msg)) + (let ([d (caddr m)]) + (map + (lambda (f) + (let ([fld (cadr (assoc f field-names))]) + (let loop ([d d]) + (cond + [(null? d) #f] + [(null? (cdr d)) #f] + [(tag-eq? (car d) fld) (cadr d)] + [else (loop (cddr d))])))) + field-list)))) + msgs))))) + + (define (imap-store imap mode msgs flags) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (check-ok + (imap-send r w + (format "STORE ~a ~a ~a" + (splice msgs ",") + (case mode + [(+) "+FLAGS.SILENT"] + [(-) "-FLAGS.SILENT"] + [(!) "FLAGS.SILENT"] + [else (raise-type-error + 'imap-store + "mode: '!, '+, or '-")]) + flags) + void)))) + + (define (imap-copy imap msgs dest-mailbox) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (check-ok + (imap-send r w + (format "COPY ~a ~a" + (splice msgs ",") + (str->arg dest-mailbox)) + void)))) + + (define (imap-expunge imap) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (check-ok (imap-send r w "EXPUNGE" void)))) + + + (define (imap-mailbox-exists? imap mailbox) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)] + [exists? #f]) + (check-ok (imap-send r w + (format "LIST \"\" ~s" (str->arg mailbox)) + (lambda (i) + (when (and (pair? i) + (tag-eq? (car i) 'LIST)) + (set! exists? #t))))) + exists?)) + + (define (imap-create-mailbox imap mailbox) + (let ([r (imap-connection-r imap)] + [w (imap-connection-w imap)]) + (check-ok + (imap-send r w + (format "CREATE ~a" (str->arg mailbox)) + void)))) + + (define (imap-get-hierarchy-delimiter imap) + (let* ([r (imap-connection-r imap)] + [w (imap-connection-w imap)] + [result #f]) + (check-ok + (imap-send r w "LIST \"\" \"\"" + (lambda (x) + (set! result (caddr x))))) + result)) + + (define imap-list-child-mailboxes + (case-lambda + [(imap mailbox) + (imap-list-child-mailboxes imap mailbox (imap-get-hierarchy-delimiter imap))] + [(imap mailbox delimiter) + (let* ([r (imap-connection-r imap)] + [w (imap-connection-w imap)] + [mailbox-name (and mailbox (format "~a~a" mailbox delimiter))] + [pattern (if mailbox + (format "~a%" mailbox-name) + "%")] + [sub-folders null]) + (check-ok + (imap-send r w (format "LIST \"\" ~a" (str->arg pattern)) + (lambda (x) + (let ([flags (cadr x)] + [name (let ([s (cadddr x)]) + (if (symbol? s) + (symbol->string s) + s))]) + (unless (and mailbox-name + (string=? name mailbox-name)) + (set! sub-folders + (cons + (list flags name) + sub-folders))))))) + (reverse sub-folders))]))) diff --git a/collects/net/imaps.ss b/collects/net/imaps.ss new file mode 100644 index 00000000..0a802eb4 --- /dev/null +++ b/collects/net/imaps.ss @@ -0,0 +1,20 @@ + +(define-signature mzlib:imap^ + (imap-port-number + + imap-connect + imap-disconnect + imap-force-disconnect + imap-reselect + imap-status + + imap-get-messages + imap-copy + imap-store imap-flag->symbol symbol->imap-flag + imap-expunge + + imap-mailbox-exists? + imap-create-mailbox + + imap-list-child-mailboxes + imap-get-hierarchy-delimiter)) diff --git a/collects/net/info.ss b/collects/net/info.ss new file mode 100644 index 00000000..a70d15c9 --- /dev/null +++ b/collects/net/info.ss @@ -0,0 +1,9 @@ +(lambda (sym fail) + (let ([elab (list "cgis.ss" "mails.ss" "nntps.ss" "pop3s.ss" "urls.ss" + "smtps.ss" "heads.ss" "imaps.ss" "dnss.ss" "base64s.ss")]) + (case sym + [(name) "Net"] + [(compile-prefix) `(begin ,@(map (lambda (x) `(require-library ,x "net")) elab))] + [(compile-omit-files) elab] + [(compile-elaboration-zos) elab] + [else (fail)]))) \ No newline at end of file diff --git a/collects/net/mail.ss b/collects/net/mail.ss new file mode 100644 index 00000000..3e231e73 --- /dev/null +++ b/collects/net/mail.ss @@ -0,0 +1,8 @@ +(require-library "mails.ss" "net") +(require-library "mailu.ss" "net") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:sendmail^ + mzlib:sendmail@) diff --git a/collects/net/mailr.ss b/collects/net/mailr.ss new file mode 100644 index 00000000..5be07bad --- /dev/null +++ b/collects/net/mailr.ss @@ -0,0 +1,105 @@ +(unit/sig mzlib:sendmail^ + (import) + + (define-struct (no-mail-recipients struct:exn) ()) + + (define sendmail-search-path + '("/usr/lib" "/usr/sbin")) + + (define sendmail-program-file + (if (eq? (system-type) 'unix) + (let loop ((paths sendmail-search-path)) + (if (null? paths) + (raise (make-exn:misc:unsupported + "unable to find sendmail on this Unix variant" + (current-continuation-marks))) + (let ((p (build-path (car paths) "sendmail"))) + (if (and (file-exists? p) + (memq 'execute (file-or-directory-permissions p))) + p + (loop (cdr paths)))))) + (raise (make-exn:misc:unsupported + "sendmail only available under Unix" + (current-continuation-marks))))) + + ;; send-mail-message/port : + ;; string x string x list (string) x list (string) x list (string) + ;; [x list (string)] -> oport + + ;; -- sender can be anything, though spoofing is not recommended. + ;; The recipients must all be pure email addresses. Note that + ;; everything is expected to follow RFC conventions. If any other + ;; headers are specified, they are expected to be completely + ;; formatted already. Clients are urged to use close-output-port on + ;; the port returned by this procedure as soon as the necessary text + ;; has been written, so that the sendmail process can complete. + + (define send-mail-message/port + (lambda (sender subject to-recipients cc-recipients bcc-recipients + . other-headers) + (when (and (null? to-recipients) (null? cc-recipients) + (null? bcc-recipients)) + (raise (make-no-mail-recipients + "no mail recipients were specified" + (current-continuation-marks)))) + (let ((return (apply process* sendmail-program-file "-i" + (append to-recipients cc-recipients bcc-recipients)))) + (let ((reader (car return)) + (writer (cadr return)) + (pid (caddr return)) + (error-reader (cadddr return))) + (close-input-port reader) + (close-input-port error-reader) + (fprintf writer "From: ~a~n" sender) + (letrec ((write-recipient-header + (lambda (header-string recipients) + (let ((header-space + (+ (string-length header-string) 2))) + (fprintf writer "~a: " header-string) + (let loop ((to recipients) (indent header-space)) + (if (null? to) + (newline writer) + (let ((first (car to))) + (let ((len (string-length first))) + (if (>= (+ len indent) 80) + (begin + (fprintf writer "~n ~a, " first) + (loop (cdr to) (+ len header-space 2))) + (begin + (fprintf writer "~a, " first) + (loop (cdr to) + (+ len indent 2)))))))))))) + (write-recipient-header "To" to-recipients) + (write-recipient-header "CC" cc-recipients)) + (fprintf writer "Subject: ~a~n" subject) + (fprintf writer "X-Mailer: MzScheme: see www.cs.rice.edu/CS/PLT/~n") + (for-each (lambda (s) + (display s writer) + (newline writer)) + other-headers) + (newline writer) + writer)))) + + ;; send-mail-message : + ;; string x string x list (string) x list (string) x list (string) x + ;; list (string) [x list (string)] -> () + + ;; -- sender can be anything, though spoofing is not recommended. The + ;; recipients must all be pure email addresses. The text is expected + ;; to be pre-formatted. Note that everything is expected to follow + ;; RFC conventions. If any other headers are specified, they are + ;; expected to be completely formatted already. + + (define send-mail-message + (lambda (sender subject to-recipients cc-recipients bcc-recipients text + . other-headers) + (let ((writer (apply send-mail-message/port sender subject + to-recipients cc-recipients bcc-recipients + other-headers))) + (for-each (lambda (s) + (display s writer) ; We use -i, so "." is not a problem + (newline writer)) + text) + (close-output-port writer)))) + + ) diff --git a/collects/net/mails.ss b/collects/net/mails.ss new file mode 100644 index 00000000..56c18572 --- /dev/null +++ b/collects/net/mails.ss @@ -0,0 +1,4 @@ +(define-signature mzlib:sendmail^ + (send-mail-message/port + send-mail-message + (struct no-mail-recipients ()))) diff --git a/collects/net/mailu.ss b/collects/net/mailu.ss new file mode 100644 index 00000000..0b010537 --- /dev/null +++ b/collects/net/mailu.ss @@ -0,0 +1,4 @@ +(require-library "mails.ss" "net") + +(define mzlib:sendmail@ + (require-library-unit/sig "mailr.ss" "net")) diff --git a/collects/net/nntp.sd b/collects/net/nntp.sd new file mode 100644 index 00000000..d00a462b --- /dev/null +++ b/collects/net/nntp.sd @@ -0,0 +1,128 @@ +(define nntp-doc + (mk-document {nntp} + {The PLT NNTP Toolkit} + + {[(paragraph {The NNTP toolkit implements routines which form the + basis for a client that can converse with an NNTP (Usenet + News) server. The toolkit defines both procedures to + interface with the server, and exceptions which indicate + erroneous behavior.})] + + [(paragraph + {The toolkit is parameterized over [(italic + {communicator})]s, which are structures representing a + connection to a particular server. Several communicators can + be open at any given time. A communicator has four fields: + + [(mk-itemize + (list + {[(italic {sender})], an output port which sends + commands to the the server; + } + {[(italic {receiver})], an input port for receiving + responses from the server; + } + {[(italic {server})], a string containing the name of + the server, which is useful for error messages and + identification; and, + } + {[(italic {port})], a number denoting the port number + on the server to which this connection was + established. + }))]})] + + [(paragraph {The following procedures are defined:})] + + [(mk-itemize + (list + {[(bold {connect-to-server})] accepts a string, the server's + name, and optionally the port number. If no port number + is provided, the default NNTP port (119) is used. A + communicator is returned.} + {[(bold {disconnect-from-server})] takes a communicator and + closes its connections.} + {[(bold {open-news-group})] accepts a communicator and a + string, representing the group's name, and makes it the + current group. Three values are returned: the number of + articles the server has for the group, the first + available article number, and the last article number.} + {[(bold {head-of-message})] takes a communicator and a + message number, and returns the message's headers as a + list of strings.} + {[(bold {body-of-message})] takes a communicator and a + message number, and returns the message's body as a list + of strings.} + {[(bold {make-desired-header})] takes a string representing a + header, and returns a regular expression which can be + matched against header lines. The string should be given + sans a trailing colon; regular expressions may be used + within the string.} + {[(bold {extract-desired-headers})] accepts a list of strings + representing the header and a list of regular expressions + representing desired headers, and returns a list of + strings denoting the desired headers.}))] + + [(paragraph {This library only interfaces using the NNTP + protocol; it does not attempt to improve it by providing an + alternative, perhaps more functional, formulation. Hence, it + generates the same errors as those returned by NNTP servers. + These errors are expressed as Scheme exceptions. They are + all sub-types of the exception [(bold {nntp})] (which has + no fields).})] + + [(itemize + {[(bold {unexpected-response})] has two fields: [(italic + {code})], a number and [(italic {text})], a string containing + the error message returned by the server. This is raised + when the return code is not recognized by the toolkit.} + + {[(bold {premature-close})] is raised when the server + generates an end-of-file in the midst of a multi-line + response (such as the message header or body). The exception + has a [(italic {communicator})] field.} + + {[(bold {non-existent-group})] is raised when the group being + opened is not recognized by the server. Note that not all + servers carry all groups.} + + {[(bold {article-not-in-group})] is raised when an attempt is + made to get the header or body of a group outside the range + for the group or which has expired or been cancelled. The + [(italic {article})] field holds the article number.} + + {[(bold {article-not-found})] is raised in other situations + when an article cannot be found. The article number is given + in the [(italic {article})] field.} + + {[(bold {no-group-selected})] is raised when an attempt is + made to get the header or body of an article before any group + has been selected.} + + {[(bold {bad-newsgroup-line})] is raised when the server is + not following the RFC specification acknowledging that a + newsgroup has been set. It holds the line in the [(italic + {line})] field.} + + {[(bold {bad-status-line})] has one field: [(italic {line})], + a string. This is only flagged when the server does not + follow the RFC specification.})] + + [(paragraph {There are at least two routes to take when + improving the library's design. One possibility is to + provide a construct, similar to Scheme's i/o functions, in + whose dynamic range groups are selected, and inside which all + article reading is done. Another approach is to require all + article accesses to also specify a group. The current group + state would be maintained by the implementation, which can + optimize away the need to make the current group setting for + each article read. It can also anticipate certain errors. + The state would be cached with each communicator.})] + + [(paragraph {This implementation currently provides no posting + conveniences, though since the output port to the server is + available, the user could implement this. However, that same + argument can be made for the rest of the toolkit as well.})] + + })) + +(render-html nntp-doc) diff --git a/collects/net/nntp.ss b/collects/net/nntp.ss new file mode 100644 index 00000000..0050f26a --- /dev/null +++ b/collects/net/nntp.ss @@ -0,0 +1,8 @@ +(require-library "nntpu.ss" "net") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:nntp^ + mzlib:nntp@ + nntp) diff --git a/collects/net/nntpr.ss b/collects/net/nntpr.ss new file mode 100644 index 00000000..5787d75f --- /dev/null +++ b/collects/net/nntpr.ss @@ -0,0 +1,281 @@ +; Time-stamp: <98/07/14 14:41:20 shriram> +; Time-stamp: <97/03/05 15:34:09 shriram> + +(unit/sig mzlib:nntp^ + (import) + + ; sender : oport + ; receiver : iport + ; server : string + ; port : number + + (define-struct communicator (sender receiver server port)) + + ; code : number + ; text : string + ; line : string + ; communicator : communicator + ; group : string + ; article : number + + (define-struct (nntp struct:exn) ()) + (define-struct (unexpected-response struct:nntp) (code text)) + (define-struct (bad-status-line struct:nntp) (line)) + (define-struct (premature-close struct:nntp) (communicator)) + (define-struct (bad-newsgroup-line struct:nntp) (line)) + (define-struct (non-existent-group struct:nntp) (group)) + (define-struct (article-not-in-group struct:nntp) (article)) + (define-struct (no-group-selected struct:nntp) ()) + (define-struct (article-not-found struct:nntp) (article)) + + ; signal-error : + ; (exn-args ... -> exn) x format-string x values ... -> + ; exn-args -> () + + ; - throws an exception + + (define signal-error + (lambda (constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args))))) + + ; default-nntpd-port-number : + ; number + + (define default-nntpd-port-number 119) + + ; connect-to-server : + ; string [x number] -> commnicator + + (define connect-to-server + (opt-lambda (server-name (port-number default-nntpd-port-number)) + (let-values (((receiver sender) + (tcp-connect server-name port-number))) + (let ((communicator + (make-communicator sender receiver server-name port-number))) + (let-values (((code response) + (get-single-line-response communicator))) + (case code + ((200) + communicator) + (else + ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)))))))) + + ; close-communicator : + ; communicator -> () + + (define close-communicator + (lambda (communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator)))) + + ; disconnect-from-server : + ; communicator -> () + + (define disconnect-from-server + (lambda (communicator) + (send-to-server communicator "QUIT") + (let-values (((code response) + (get-single-line-response communicator))) + (case code + ((205) + (close-communicator communicator)) + (else + ((signal-error make-unexpected-response + "unexpected dis-connect response: ~s ~s" + code response) + code response)))))) + + ; send-to-server : + ; communicator x format-string x list (values) -> () + + (define send-to-server + (lambda (communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "~n") + rest))) + + ; parse-status-line : + ; string -> number x string + + (define parse-status-line + (let ((pattern (regexp "([0-9]+) (.*)"))) + (lambda (line) + (let ((match (cdr (or (regexp-match pattern line) + ((signal-error make-bad-status-line + "malformed status line: ~s" line) + line))))) + (values (string->number (car match)) + (cadr match)))))) + + ; get-one-line-from-server : + ; iport -> string + + (define get-one-line-from-server + (lambda (server->client-port) + (read-line server->client-port 'return-linefeed))) + + ; get-single-line-response : + ; communicator -> number x string + + (define get-single-line-response + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((status-line (get-one-line-from-server receiver))) + (parse-status-line status-line))))) + + ; get-rest-of-multi-line-response : + ; communicator -> list (string) + + (define get-rest-of-multi-line-response + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let loop () + (let ((l (get-one-line-from-server receiver))) + (cond + ((eof-object? l) + ((signal-error make-premature-close + "port prematurely closed during multi-line response") + communicator)) + ((string=? l ".") + '()) + ((string=? l "..") + (cons "." (loop))) + (else + (cons l (loop))))))))) + + ; get-multi-line-response : + ; communicator -> number x string x list (string) + + ; -- The returned values are the status code, the rest of the status + ; response line, and the remaining lines. + + (define get-multi-line-response + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((status-line (get-one-line-from-server receiver))) + (let-values (((code rest-of-line) + (parse-status-line status-line))) + (values code rest-of-line (get-rest-of-multi-line-response))))))) + + ; open-news-group : + ; communicator x string -> number x number x number + + ; -- The returned values are the number of articles, the first + ; article number, and the last article number for that group. + + (define open-news-group + (let ((pattern (regexp "([0-9]+) ([0-9]+) ([0-9]+)"))) + (lambda (communicator group-name) + (send-to-server communicator "GROUP ~a" group-name) + (let-values (((code rest-of-line) + (get-single-line-response communicator))) + (case code + ((211) + (let ((match (map string->number + (cdr + (or (regexp-match pattern rest-of-line) + ((signal-error make-bad-newsgroup-line + "malformed newsgroup open response: ~s" + rest-of-line) + rest-of-line)))))) + (let ((number-of-articles (car match)) + (first-article-number (cadr match)) + (last-article-number (caddr match))) + (values number-of-articles + first-article-number + last-article-number)))) + ((411) + ((signal-error make-non-existent-group + "group ~s does not exist on server ~s" + group-name (communicator-server communicator)) + group-name)) + (else + ((signal-error make-unexpected-response + "unexpected group opening response: ~s" code) + code rest-of-line))))))) + + ; head/body-of-message : + ; string x number -> communicator x number -> list (string) + + (define head/body-of-message + (lambda (command ok-code) + (lambda (communicator message-number) + (send-to-server communicator (string-append command " ~a") + (number->string message-number)) + (let-values (((code response) + (get-single-line-response communicator))) + (if (= code ok-code) + (get-rest-of-multi-line-response communicator) + (case code + ((423) + ((signal-error make-article-not-in-group + "article number ~s not in group" message-number) + message-number)) + ((412) + ((signal-error make-no-group-selected + "no group selected"))) + ((430) + ((signal-error make-article-not-found + "no article number ~s found" message-number) + message-number)) + (else + ((signal-error make-unexpected-response + "unexpected message access response: ~s" code) + code response)))))))) + + ; head-of-message : + ; communicator x number -> list (string) + + (define head-of-message + (head/body-of-message "HEAD" 221)) + + ; body-of-message : + ; communicator x number -> list (string) + + (define body-of-message + (head/body-of-message "BODY" 222)) + + ; make-desired-header : + ; string -> desired + + (define make-desired-header + (lambda (raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + ((char-lower-case? c) + (list #\[ (char-upcase c) c #\])) + ((char-upper-case? c) + (list #\[ c (char-downcase c) #\])) + (else + (list c)))) + (string->list raw-header)))) + ":")))) + + ; extract-desired-headers : + ; list (string) x list (desired) -> list (string) + + (define extract-desired-headers + (lambda (headers desireds) + (let loop ((headers headers)) + (if (null? headers) null + (let ((first (car headers)) + (rest (cdr headers))) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest))))))) + + ) diff --git a/collects/net/nntps.ss b/collects/net/nntps.ss new file mode 100644 index 00000000..0d8dca9d --- /dev/null +++ b/collects/net/nntps.ss @@ -0,0 +1,19 @@ +(require-library "macro.ss") + +(define-signature mzlib:nntp^ + ((struct communicator (sender receiver server port)) + connect-to-server disconnect-from-server + open-news-group + head-of-message body-of-message + make-desired-header extract-desired-headers + + (struct nntp ()) + (struct unexpected-response (code text)) + (struct bad-status-line (line)) + (struct premature-close (communicator)) + (struct bad-newsgroup-line (line)) + (struct non-existent-group (group)) + (struct article-not-in-group (article)) + (struct no-group-selected ()) + (struct article-not-found (article)))) + diff --git a/collects/net/nntpu.ss b/collects/net/nntpu.ss new file mode 100644 index 00000000..1551b592 --- /dev/null +++ b/collects/net/nntpu.ss @@ -0,0 +1,5 @@ +(require-library "macro.ss") + +(require-library "nntps.ss" "net") + +(define mzlib:nntp@ (require-library-unit/sig "nntpr.ss" "net")) diff --git a/collects/net/pop3.ss b/collects/net/pop3.ss new file mode 100644 index 00000000..b91822c8 --- /dev/null +++ b/collects/net/pop3.ss @@ -0,0 +1,32 @@ +(require-library "pop3u.ss" "net") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:pop3^ + mzlib:pop3@ pop3) + +#| + +> (require-library "pop3.ss" "net") +> (define c (pop3:connect-to-server "cs.rice.edu")) +> (pop3:authenticate/plain-text "scheme" "********" c) +> (pop3:get-mailbox-status c) +100 +177824 +> (pop3:get-message/headers c 100) +("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)" + "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>" + "From: Shriram Krishnamurthi " + ... + "Status: RO") +> (pop3:get-message/complete c 100) +("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)" + "Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>" + "From: Shriram Krishnamurthi " + ... + "Status: RO") +("some body" "text" "goes" "." "here" "." "") +> (pop3:disconnect-from-server c) + +|# diff --git a/collects/net/pop3r.ss b/collects/net/pop3r.ss new file mode 100644 index 00000000..381598c2 --- /dev/null +++ b/collects/net/pop3r.ss @@ -0,0 +1,403 @@ +; Time-stamp: <98/10/09 19:19:06 shriram> + +(unit/sig mzlib:pop3^ + (import) + + ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose + + ;; sender : oport + ;; receiver : iport + ;; server : string + ;; port : number + ;; state : symbol = (disconnected, authorization, transaction) + + (define-struct communicator (sender receiver server port state)) + + (define-struct (pop3 struct:exn) ()) + (define-struct (cannot-connect struct:pop3) ()) + (define-struct (username-rejected struct:pop3) ()) + (define-struct (password-rejected struct:pop3) ()) + (define-struct (not-ready-for-transaction struct:pop3) (communicator)) + (define-struct (not-given-headers struct:pop3) (communicator message)) + (define-struct (illegal-message-number struct:pop3) (communicator message)) + (define-struct (cannot-delete-message struct:exn) (communicator message)) + (define-struct (disconnect-not-quiet struct:pop3) (communicator)) + (define-struct (malformed-server-response struct:pop3) (communicator)) + + ;; signal-error : + ;; (exn-args ... -> exn) x format-string x values ... -> + ;; exn-args -> () + + (define signal-error + (lambda (constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args))))) + + ;; signal-malformed-response-error : + ;; exn-args -> () + + ;; -- in practice, it takes only one argument: a communicator. + + (define signal-malformed-response-error + (signal-error make-malformed-server-response + "malformed response from server")) + + ;; confirm-transaction-mode : + ;; communicator x string -> () + + ;; -- signals an error otherwise. + + (define confirm-transaction-mode + (lambda (communicator error-message) + (unless (eq? (communicator-state communicator) 'transaction) + ((signal-error make-not-ready-for-transaction error-message) + communicator)))) + + ;; default-pop-port-number : + ;; number + + (define default-pop-port-number 110) + + (define-struct server-responses ()) + (define-struct (+ok struct:server-responses) ()) + (define-struct (-err struct:server-responses) ()) + + (define +ok (make-+ok)) + (define -err (make--err)) + + ;; connect-to-server : + ;; string [x number] -> communicator + + (define connect-to-server + (opt-lambda (server-name (port-number default-pop-port-number)) + (let-values (((receiver sender) + (tcp-connect server-name port-number))) + (let ((communicator + (make-communicator sender receiver server-name port-number + 'authorization))) + (let ((response (get-status-response/basic communicator))) + (cond + ((+ok? response) communicator) + ((-err? response) + ((signal-error make-cannot-connect + "cannot connect to ~a on port ~a" + server-name port-number))))))))) + + ;; authenticate/plain-text : + ;; string x string x communicator -> () + + ;; -- if authentication succeeds, sets the communicator's state to + ;; transaction. + + (define authenticate/plain-text + (lambda (username password communicator) + (let ((sender (communicator-sender communicator))) + (send-to-server communicator "USER ~a" username) + (let ((status (get-status-response/basic communicator))) + (cond + ((+ok? status) + (send-to-server communicator "PASS ~a" password) + (let ((status (get-status-response/basic communicator))) + (cond + ((+ok? status) + (set-communicator-state! communicator 'transaction)) + ((-err? status) + ((signal-error make-password-rejected + "password was rejected")))))) + ((-err? status) + ((signal-error make-username-rejected + "username was rejected")))))))) + + ;; get-mailbox-status : + ;; communicator -> number x number + + ;; -- returns number of messages and number of octets. + + (define get-mailbox-status + (let ((stat-regexp (regexp "([0-9]+) ([0-9]+)"))) + (lambda (communicator) + (confirm-transaction-mode communicator + "cannot get mailbox status unless in transaction mode") + (send-to-server communicator "STAT") + (apply values + (map string->number + (let-values (((status result) + (get-status-response/match communicator + stat-regexp #f))) + result)))))) + + ;; get-message/complete : + ;; communicator x number -> list (string) x list (string) + + (define get-message/complete + (lambda (communicator message) + (confirm-transaction-mode communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "RETR ~a" message) + (let ((status (get-status-response/basic communicator))) + (cond + ((+ok? status) + (split-header/body (get-multi-line-response communicator))) + ((-err? status) + ((signal-error make-illegal-message-number + "not given message ~a" message) + communicator message)))))) + + ;; get-message/headers : + ;; communicator x number -> list (string) + + (define get-message/headers + (lambda (communicator message) + (confirm-transaction-mode communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "TOP ~a 0" message) + (let ((status (get-status-response/basic communicator))) + (cond + ((+ok? status) + (let-values (((headers body) + (split-header/body + (get-multi-line-response communicator)))) + headers)) + ((-err? status) + ((signal-error make-not-given-headers + "not given headers to message ~a" message) + communicator message)))))) + + ;; get-message/body : + ;; communicator x number -> list (string) + + (define get-message/body + (lambda (communicator message) + (let-values (((headers body) + (get-message/complete communicator message))) + body))) + + ;; split-header/body : + ;; list (string) -> list (string) x list (string) + + ;; -- returns list of headers and list of body lines. + + (define split-header/body + (lambda (lines) + (let loop ((lines lines) (header null)) + (if (null? lines) + (values (reverse header) null) + (let ((first (car lines)) + (rest (cdr lines))) + (if (string=? first "") + (values (reverse header) rest) + (loop rest (cons first header)))))))) + + ;; delete-message : + ;; communicator x number -> () + + (define delete-message + (lambda (communicator message) + (confirm-transaction-mode communicator + "cannot delete message unless in transaction state") + (send-to-server communicator "DELE ~a" message) + (let ((status (get-status-response/basic communicator))) + (cond + ((-err? status) + ((signal-error make-cannot-delete-message + "no message numbered ~a available to be deleted" message) + communicator message)) + ((+ok? status) + 'deleted))))) + + ;; regexp for UIDL responses + + (define uidl-regexp (regexp "([0-9]+) (.*)")) + + ;; get-unique-id/single : + ;; communicator x number -> string + + (define (get-unique-id/single communicator message) + (confirm-transaction-mode communicator + "cannot get unique message id unless in transaction state") + (send-to-server communicator "UIDL ~a" message) + (let-values (((status result) + (get-status-response/match communicator + uidl-regexp + ".*"))) + ;; The server response is of the form + ;; +OK 2 QhdPYR:00WBw1Ph7x7 + (cond + ((-err? status) + ((signal-error make-illegal-message-number + "no message numbered ~a available for unique id" message) + communicator message)) + ((+ok? status) + (cadr result))))) + + ;; get-unique-id/all : + ;; communicator -> list(number x string) + + (define (get-unique-id/all communicator) + (confirm-transaction-mode communicator + "cannot get unique message ids unless in transaction state") + (send-to-server communicator "UIDL") + (let ((status (get-status-response/basic communicator))) + ;; The server response is of the form + ;; +OK + ;; 1 whqtswO00WBw418f9t5JxYwZ + ;; 2 QhdPYR:00WBw1Ph7x7 + ;; . + (map (lambda (l) + (let ((m (regexp-match uidl-regexp l))) + (cons (string->number (cadr m)) (caddr m)))) + (get-multi-line-response communicator)))) + + ;; close-communicator : + ;; communicator -> () + + (define close-communicator + (lambda (communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator)))) + + ;; disconnect-from-server : + ;; communicator -> () + + (define disconnect-from-server + (lambda (communicator) + (send-to-server communicator "QUIT") + (set-communicator-state! communicator 'disconnected) + (let ((response (get-status-response/basic communicator))) + (close-communicator communicator) + (cond + ((+ok? response) (void)) + ((-err? response) + ((signal-error make-disconnect-not-quiet + "got error status upon disconnect") + communicator)))))) + + ;; send-to-server : + ;; communicator x format-string x list (values) -> () + + (define send-to-server + (lambda (communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "~n") + rest))) + + ;; get-one-line-from-server : + ;; iport -> string + + (define get-one-line-from-server + (lambda (server->client-port) + (read-line server->client-port 'return-linefeed))) + + ;; get-server-status-response : + ;; communicator -> server-responses x string + + ;; -- provides the low-level functionality of checking for +OK + ;; and -ERR, returning an appropriate structure, and returning the + ;; rest of the status response as a string to be used for further + ;; parsing, if necessary. + + (define get-server-status-response + (let ((+ok-regexp (regexp "^\\+OK (.*)")) + (-err-regexp (regexp "^\\-ERR (.*)"))) + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let ((status-line (get-one-line-from-server receiver))) + (let ((r (regexp-match +ok-regexp status-line))) + (if r + (values +ok (cadr r)) + (let ((r (regexp-match -err-regexp status-line))) + (if r + (values -err (cadr r)) + (signal-malformed-response-error communicator)))))))))) + + ;; get-status-response/basic : + ;; communicator -> server-responses + + ;; -- when the only thing to determine is whether the response + ;; was +OK or -ERR. + + (define get-status-response/basic + (lambda (communicator) + (let-values (((response rest) + (get-server-status-response communicator))) + response))) + + ;; get-status-response/match : + ;; communicator x regexp x regexp -> (status x list (string)) + + ;; -- when further parsing of the status response is necessary. + ;; Strips off the car of response from regexp-match. + + (define get-status-response/match + (lambda (communicator +regexp -regexp) + (let-values (((response rest) + (get-server-status-response communicator))) + (if (and +regexp (+ok? response)) + (let ((r (regexp-match +regexp rest))) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (if (and -regexp (-err? response)) + (let ((r (regexp-match -regexp rest))) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (signal-malformed-response-error communicator)))))) + + ;; get-multi-line-response : + ;; communicator -> list (string) + + (define get-multi-line-response + (lambda (communicator) + (let ((receiver (communicator-receiver communicator))) + (let loop () + (let ((l (get-one-line-from-server receiver))) + (cond + ((eof-object? l) + (signal-malformed-response-error communicator)) + ((string=? l ".") + '()) + ((and (> (string-length l) 1) + (char=? (string-ref l 0) #\.)) + (cons (substring l 1 (string-length l)) (loop))) + (else + (cons l (loop))))))))) + + ;; make-desired-header : + ;; string -> desired + + (define make-desired-header + (lambda (raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + ((char-lower-case? c) + (list #\[ (char-upcase c) c #\])) + ((char-upper-case? c) + (list #\[ c (char-downcase c) #\])) + (else + (list c)))) + (string->list raw-header)))) + ":")))) + + ;; extract-desired-headers : + ;; list (string) x list (desired) -> list (string) + + (define extract-desired-headers + (lambda (headers desireds) + (let loop ((headers headers)) + (if (null? headers) null + (let ((first (car headers)) + (rest (cdr headers))) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest))))))) + + ) diff --git a/collects/net/pop3s.ss b/collects/net/pop3s.ss new file mode 100644 index 00000000..143d6768 --- /dev/null +++ b/collects/net/pop3s.ss @@ -0,0 +1,26 @@ +(require-library "macro.ss") + +(define-signature mzlib:pop3^ + ((struct communicator (sender receiver server port state)) + connect-to-server disconnect-from-server + authenticate/plain-text + get-mailbox-status + get-message/complete get-message/headers get-message/body + delete-message + get-unique-id/single get-unique-id/all + + make-desired-header extract-desired-headers + + (struct pop3 ()) + (struct cannot-connect ()) + (struct username-rejected ()) + (struct password-rejected ()) + (struct not-ready-for-transaction (communicator)) + (struct not-given-headers (communicator message)) + (struct illegal-message-number (communicator message)) + (struct cannot-delete-message (communicator message)) + (struct disconnect-not-quiet (communicator)) + (struct malformed-server-response (communicator)) + + ) + ) diff --git a/collects/net/pop3u.ss b/collects/net/pop3u.ss new file mode 100644 index 00000000..5169fd00 --- /dev/null +++ b/collects/net/pop3u.ss @@ -0,0 +1,5 @@ +(require-library "macro.ss") + +(require-library "pop3s.ss" "net") + +(define mzlib:pop3@ (require-library-unit/sig "pop3r.ss" "net")) diff --git a/collects/net/smtp.ss b/collects/net/smtp.ss new file mode 100644 index 00000000..28da5346 --- /dev/null +++ b/collects/net/smtp.ss @@ -0,0 +1,8 @@ + +(require-relative-library "smtps.ss") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:smtp^ + (require-relative-library "smtpr.ss")) diff --git a/collects/net/smtpr.ss b/collects/net/smtpr.ss new file mode 100644 index 00000000..62c2696f --- /dev/null +++ b/collects/net/smtpr.ss @@ -0,0 +1,101 @@ + +(unit/sig mzlib:smtp^ + (import) + + (define ID "localhost") + + (define debug-via-stdio? #f) + + (define crlf (string #\return #\linefeed)) + + (define (log . args) + ; (apply printf args) + (void)) + + (define (starts-with? l n) + (and (>= (string-length l) (string-length n)) + (string=? n (substring l 0 (string-length n))))) + + (define (check-reply r v) + (let ([l (read-line r (if debug-via-stdio? + 'linefeed + 'return-linefeed))]) + (log "server: ~a~n" l) + (if (eof-object? l) + (error 'check-reply "got EOF") + (let ([n (number->string v)]) + (unless (starts-with? l n) + (error 'check-reply "expected reply ~a; got: ~a" v l)) + (let ([n- (string-append n "-")]) + (when (starts-with? l n-) + ; Multi-line reply. Go again. + (check-reply r v))))))) + + (define (protect-line l) + ; If begins with a dot, add one more + (if (or (string=? "" l) (not (char=? #\. (string-ref l 0)))) + l + (string-append "." l))) + + (define smtp-sending-end-of-message + (make-parameter void + (lambda (f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'smtp-sending-end-of-message "thunk" f)) + f))) + + (define smtp-send-message + (case-lambda + [(server sender recipients header message-lines) + (smtp-send-message server sender recipients header message-lines 25)] + [(server sender recipients header message-lines pos) + (when (null? recipients) + (error 'send-smtp-message "no recievers")) + (let-values ([(r w) (if debug-via-stdio? + (values (current-input-port) (current-output-port)) + (tcp-connect server pos))]) + (with-handlers ([void (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + (check-reply r 220) + (log "hello~n") + (fprintf w "EHLO ~a~a" ID crlf) + (check-reply r 250) + + (log "from~n") + (fprintf w "MAIL FROM:<~a>~a" sender crlf) + (check-reply r 250) + + (log "to~n") + (for-each + (lambda (dest) + (fprintf w "RCPT TO:<~a>~a" dest crlf) + (check-reply r 250)) + recipients) + + (log "header~n") + (fprintf w "DATA~a" crlf) + (check-reply r 354) + (fprintf w "~a" header) + (for-each + (lambda (l) + (log "body: ~a~n" l) + (fprintf w "~a~a" (protect-line l) crlf)) + message-lines) + + ;; After we send the ".", then only break in an emergency + ((smtp-sending-end-of-message)) + + (log "dot~n") + (fprintf w ".~a" crlf) + (flush-output w) + (check-reply r 250) + + (log "quit~n") + (fprintf w "QUIT~a" crlf) + (check-reply r 221) + + (close-output-port w) + (close-input-port r)))]))) diff --git a/collects/net/smtps.ss b/collects/net/smtps.ss new file mode 100644 index 00000000..aaf743af --- /dev/null +++ b/collects/net/smtps.ss @@ -0,0 +1,4 @@ + +(define-signature mzlib:smtp^ + (smtp-send-message + smtp-sending-end-of-message)) diff --git a/collects/net/url.ss b/collects/net/url.ss new file mode 100644 index 00000000..701befd8 --- /dev/null +++ b/collects/net/url.ss @@ -0,0 +1,20 @@ +(require-library "macro.ss") +(require-library "match.ss") +(require-library "file.ss") + +(require-library "urlu.ss" "net") + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig mzlib:url^ + (compound-unit/sig + (import + (FILE : mzlib:file^)) + (link + (URL : mzlib:url^ + (mzlib:url@ FILE))) + (export + (open URL))) + #f + mzlib:file^) diff --git a/collects/net/urlr.ss b/collects/net/urlr.ss new file mode 100644 index 00000000..a37d45ea --- /dev/null +++ b/collects/net/urlr.ss @@ -0,0 +1,525 @@ +;; To do: +;; Handle HTTP/file errors. +;; Not throw away MIME headers. +;; Determine file type. + +;; ---------------------------------------------------------------------- + +;; Input ports have two statuses: +;; "impure" = they have text waiting +;; "pure" = the MIME headers have been read + +(unit/sig mzlib:url^ + (import [file : mzlib:file^]) + + (define-struct (url-exception struct:exn) ()) + + ;; This is commented out; it's here for debugging. + ;; It used to be outside the unit. + + (quote + (begin + (invoke-open-unit/sig mzlib:url@ #f) + (define url:cs (string->url "http://www.cs.rice.edu/")) + (define url:me (string->url "http://www.cs.rice.edu/~shriram/")) + (define comb combine-url/relative) + (define (test url) + (call/input-url url + get-pure-port + display-pure-port)))) + + (define url-error + (lambda (fmt . args) + (let ((s (apply format fmt (map (lambda (arg) + (if (url? arg) + (url->string arg) + arg)) + args)))) + (raise (make-url-exception s (current-continuation-marks)))))) + + ;; if the path is absolute, it just arbitrarily picks the first + ;; filesystem root. + (define unixpath->path + (letrec ([r (regexp "([^/]*)/(.*)")] + [translate-dir + (lambda (s) + (cond + [(string=? s "") 'same] ;; handle double slashes + [(string=? s "..") 'up] + [(string=? s ".") 'same] + [else s]))] + [build-relative-path + (lambda (s) + (let ([m (regexp-match r s)]) + (cond + [(string=? s "") 'same] + [(not m) s] + [else + (build-path (translate-dir (cadr m)) + (build-relative-path (caddr m)))])))]) + (lambda (s) + (cond + [(string=? s "") ""] + [(string=? s "/") (car (filesystem-root-list))] + [(char=? #\/ (string-ref s 0)) + (build-path (car (filesystem-root-list)) + (build-relative-path + (substring s 1 (string-length s))))] + [else (build-relative-path s)])))) + + ;; scheme : str + #f + ;; host : str + #f + ;; port : num + #f + ;; path : str + ;; params : str + #f + ;; query : str + #f + ;; fragment : str + #f + (define-struct url (scheme host port path params query fragment)) + + ;; name : str (all lowercase; not including the colon) + ;; value : str (doesn't have the eol delimiter) + (define-struct mime-header (name value)) + + (define url->string + (lambda (url) + (let ((scheme (url-scheme url)) + (host (url-host url)) + (port (url-port url)) + (path (url-path url)) + (params (url-params url)) + (query (url-query url)) + (fragment (url-fragment url))) + (cond + ((and scheme (string=? scheme "file")) + (string-append "file:" path)) + (else + (let ((sa string-append)) + (sa (if scheme (sa scheme "://") "") + (if host host "") + (if port (sa ":" (number->string port)) "") + ; There used to be a "/" here, but that causes an + ; extra leading slash -- wonder why it ever worked! + path + (if params (sa ";" params) "") + (if query (sa "?" query) "") + (if fragment (sa "#" fragment) "")))))))) + + ;; url->default-port : url -> num + (define url->default-port + (lambda (url) + (let ((scheme (url-scheme url))) + (cond + ((not scheme) 80) + ((string=? scheme "http") 80) + (else + (url-error "Scheme ~a not supported" (url-scheme url))))))) + + ;; make-ports : url -> in-port x out-port + (define make-ports + (lambda (url) + (let ((port-number (or (url-port url) + (url->default-port url)))) + (tcp-connect (url-host url) port-number)))) + + ;; http://get-impure-port : url [x list (str)] -> in-port + (define http://get-impure-port + (opt-lambda (url (strings '())) + (let-values (((server->client client->server) + (make-ports url))) + (let ((access-string + (url->string + (make-url #f #f #f + (url-path url) (url-params url) + (url-query url) (url-fragment url))))) + (for-each (lambda (s) + (display s client->server) + (newline client->server)) + (cons (format "GET ~a HTTP/1.0" access-string) + (cons (format "Host: ~a" (url-host url)) + strings)))) + (newline client->server) + (close-output-port client->server) + server->client))) + + ;; file://get-pure-port : url -> in-port + (define file://get-pure-port + (lambda (url) + (let ((host (url-host url))) + (if (or (not host) + (string=? host "") + (string=? host "localhost")) + (open-input-file + (unixpath->path (url-path url))) + (url-error "Cannot get files from remote hosts"))))) + + ;; get-impure-port : url [x list (str)] -> in-port + (define get-impure-port + (opt-lambda (url (strings '())) + (let ((scheme (url-scheme url))) + (cond + ((not scheme) + (url-error "Scheme unspecified in ~a" url)) + ((string=? scheme "http") + (http://get-impure-port url strings)) + ((string=? scheme "file") + (url-error "There are no impure file:// ports")) + (else + (url-error "Scheme ~a unsupported" scheme)))))) + + ;; get-pure-port : url [x list (str)] -> in-port + (define get-pure-port + (opt-lambda (url (strings '())) + (let ((scheme (url-scheme url))) + (cond + ((not scheme) + (url-error "Scheme unspecified in ~a" url)) + ((string=? scheme "http") + (let ((port (http://get-impure-port url strings))) + (purify-port port) + port)) + ((string=? scheme "file") + (file://get-pure-port url)) + (else + (url-error "Scheme ~a unsupported" scheme)))))) + + ;; display-pure-port : in-port -> () + (define display-pure-port + (lambda (server->client) + (let loop () + (let ((c (read-char server->client))) + (unless (eof-object? c) + (display c) + (loop)))) + (close-input-port server->client))) + + (define empty-url? + (lambda (url) + (and (not (url-scheme url)) (not (url-params url)) + (not (url-query url)) (not (url-fragment url)) + (andmap (lambda (c) (char=? c #\space)) + (string->list (url-path url)))))) + + ;; combine-url/relative : url x str -> url + (define combine-url/relative + (lambda (base string) + (let ((relative (string->url string))) + (cond + ((empty-url? base) ; Step 1 + relative) + ((empty-url? relative) ; Step 2a + base) + ((url-scheme relative) ; Step 2b + relative) + (else ; Step 2c + (set-url-scheme! relative (url-scheme base)) + (cond + ((url-host relative) ; Step 3 + relative) + (else + (set-url-host! relative (url-host base)) + (set-url-port! relative (url-port base)) ; Unspecified! + (let ((rel-path (url-path relative))) + (cond + ((and rel-path ; Step 4 + (not (string=? "" rel-path)) + (char=? #\/ (string-ref rel-path 0))) + relative) + ((or (not rel-path) ; Step 5 + (string=? rel-path "")) + (set-url-path! relative (url-path base)) + (or (url-params relative) + (set-url-params! relative (url-params base))) + (or (url-query relative) + (set-url-query! relative (url-query base))) + relative) + (else ; Step 6 + (if (and (url-scheme base) + (string=? (url-scheme base) "file")) + + ;; Important that: + ;; 1. You set-url-path! the new path into + ;; `relative'. + ;; 2. You return `relative' as the value + ;; from here without invoking + ;; `merge-and-normalize'. + ;; The variable `rel-path' contains the + ;; path portion of the relative URL. + + (let+ ([val base-path (url-path base)] + [val (values base name must-be-dir?) + (split-path base-path)] + [val base-dir (if must-be-dir? base-path base)] + [val ind-rel-path (unixpath->path rel-path)] + [val merged (build-path base-dir + ind-rel-path)]) + (set-url-path! relative merged) + relative) + (merge-and-normalize + (url-path base) relative)))))))))))) + + (define merge-and-normalize + (lambda (base-path relative-url) + (let ((rel-path (url-path relative-url))) + (let ((base-list (string->list base-path)) + (rel-list (string->list rel-path))) + (let* + ((joined-list + (let loop ((base (reverse base-list))) + (if (null? base) + rel-list + (if (char=? #\/ (car base)) + (append (reverse base) rel-list) + (loop (cdr base)))))) + (grouped + (let loop ((joined joined-list) (current '())) + (if (null? joined) + (list (list->string (reverse current))) + (if (char=? #\/ (car joined)) + (cons (list->string + (reverse (cons #\/ current))) + (loop (cdr joined) '())) + (loop (cdr joined) + (cons (car joined) current)))))) + (grouped + (let loop ((grouped grouped)) + (if (null? grouped) '() + (if (string=? "./" (car grouped)) + (loop (cdr grouped)) + (cons (car grouped) (loop (cdr grouped))))))) + (grouped + (let loop ((grouped grouped)) + (if (null? grouped) '() + (if (null? (cdr grouped)) + (if (string=? "." (car grouped)) '() + grouped) + (cons (car grouped) (loop (cdr grouped))))))) + (grouped + (let remove-loop ((grouped grouped)) + (let walk-loop ((r-pre '()) (post grouped)) + (if (null? post) + (reverse r-pre) + (let ((first (car post)) + (rest (cdr post))) + (if (null? rest) + (walk-loop (cons first r-pre) rest) + (let ((second (car rest))) + (if (and (not (string=? first "../")) + (string=? second "../")) + (remove-loop + (append (reverse r-pre) (cddr post))) + (walk-loop (cons first r-pre) rest))))))))) + (grouped + (let loop ((grouped grouped)) + (if (null? grouped) '() + (if (null? (cdr grouped)) grouped + (if (and (null? (cddr grouped)) + (not (string=? (car grouped) "../")) + (string=? (cadr grouped) "..")) + '() + (cons (car grouped) (loop (cdr grouped))))))))) + (set-url-path! relative-url + (apply string-append grouped)) + relative-url))))) + + ;; call/input-url : url x (url -> in-port) x (in-port -> T) + ;; [x list (str)] -> T + (define call/input-url + (let ((handle-port (lambda (server->client handler) + (dynamic-wind (lambda () 'do-nothing) + (lambda () (handler server->client)) + (lambda () (close-input-port server->client)))))) + (case-lambda + ((url getter handler) + (handle-port (getter url) handler)) + ((url getter handler params) + (handle-port (getter url params) handler))))) + + (define empty-line? + (lambda (chars) + (or (null? chars) + (and (memv (car chars) '(#\return #\linefeed #\tab #\space)) + (empty-line? (cdr chars)))))) + + (define extract-mime-headers-as-char-lists + (lambda (port) + (let headers-loop ((headers '())) + (let char-loop ((header '())) + (let ((c (read-char port))) + (if (eof-object? c) + (reverse headers) ; CHECK: INCOMPLETE MIME: SERVER BUG + (if (char=? c #\newline) + (if (empty-line? header) + (reverse headers) + (begin + (headers-loop (cons (reverse header) headers)))) + (char-loop (cons c header))))))))) + + ;; purify-port : in-port -> list (mime-header) + (define purify-port + (lambda (port) + (let ((headers-as-chars (extract-mime-headers-as-char-lists port))) + (let header-loop ((headers headers-as-chars)) + (if (null? headers) + '() + (let ((header (car headers))) + (let char-loop ((pre '()) (post header)) + (if (null? post) + (header-loop (cdr headers)) + (if (char=? #\: (car post)) + (cons (make-mime-header + (list->string (reverse pre)) + (list->string post)) + (header-loop (cdr headers))) + (char-loop (cons (char-downcase (car post)) pre) + (cdr post))))))))))) + + (define character-set-size 256) + + (define marker-list + '(#\: #\; #\? #\#)) + + (define ascii-marker-list + (map char->integer marker-list)) + + (define marker-locations + (make-vector character-set-size)) + + (define first-position-of-marker + (lambda (c) + (vector-ref marker-locations (char->integer c)))) + + ;; netscape/string->url : str -> url + (define netscape/string->url + (lambda (string) + (let ((url (string->url string))) + (if (url-scheme url) + url + (if (string=? string "") + (url-error "Can't resolve empty string as URL") + (begin + (set-url-scheme! url + (if (char=? (string-ref string 0) #\/) + "file" + "http")) + url)))))) + + ;; string->url : str -> url + (define string->url + (lambda (string) + (let loop ((markers ascii-marker-list)) + (unless (null? markers) + (vector-set! marker-locations (car markers) #f) + (loop (cdr markers)))) + (let loop ((chars (string->list string)) (index 0)) + (unless (null? chars) + (let ((first (car chars))) + (when (memq first marker-list) + (let ((posn (char->integer first))) + (unless (vector-ref marker-locations posn) + (vector-set! marker-locations posn index))))) + (loop (cdr chars) (add1 index)))) + (let + ((first-colon (first-position-of-marker #\:)) + (first-semicolon (first-position-of-marker #\;)) + (first-question (first-position-of-marker #\?)) + (first-hash (first-position-of-marker #\#))) + (let + ((scheme-start (and first-colon 0)) + (path-start (if first-colon (add1 first-colon) 0)) + (params-start (and first-semicolon (add1 first-semicolon))) + (query-start (and first-question (add1 first-question))) + (fragment-start (and first-hash (add1 first-hash)))) + (let ((total-length (string-length string))) + (let* + ((scheme-finish (and scheme-start first-colon)) + (path-finish (if first-semicolon first-semicolon + (if first-question first-question + (if first-hash first-hash + total-length)))) + (fragment-finish (and fragment-start total-length)) + (query-finish (and query-start + (if first-hash first-hash + total-length))) + (params-finish (and params-start + (if first-question first-question + (if first-hash first-hash + total-length))))) + (let ((scheme (and scheme-start + (substring string + scheme-start scheme-finish)))) + (if (and scheme + (string=? scheme "file")) + (make-url + scheme + #f ; host + #f ; port + (build-path (substring string path-start total-length)) + #f ; params + #f ; query + #f) ; fragment + (let-values (((host port path) + (parse-host/port/path + string path-start path-finish))) + (make-url + scheme + host + port + path + (and params-start + (substring string params-start params-finish)) + (and query-start + (substring string query-start query-finish)) + (and fragment-start + (substring string fragment-start + fragment-finish)))))))))))) + + ;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str + (define parse-host/port/path + (lambda (path begin-point end-point) + (let ((has-host? (and (>= (- end-point begin-point) 2) + (char=? (string-ref path begin-point) #\/) + (char=? (string-ref path (add1 begin-point)) + #\/)))) + (let ((begin-point (if has-host? + (+ begin-point 2) + begin-point))) + (let loop ((index begin-point) + (first-colon #f) + (first-slash #f)) + (cond + ((>= index end-point) + ;; We come here only if the string has not had a / + ;; yet. This can happen in two cases: + ;; 1. The input is a relative URL, and the hostname + ;; will not be specified. In such cases, has-host? + ;; will be false. + ;; 2. The input is an absolute URL with a hostname, + ;; and the intended path is "/", but the URL is missing + ;; a "/" at the end. has-host? must be true. + (let ((host/path (substring path begin-point end-point))) + (if has-host? + (values host/path #f "/") + (values #f #f host/path)))) + ((char=? #\: (string-ref path index)) + (loop (add1 index) (or first-colon index) first-slash)) + ((char=? #\/ (string-ref path index)) + (if first-colon + (values + (substring path begin-point first-colon) + (string->number (substring path (add1 first-colon) + index)) + (substring path index end-point)) + (if has-host? + (values + (substring path begin-point index) + #f + (substring path index end-point)) + (values + #f + #f + (substring path begin-point end-point))))) + (else + (loop (add1 index) first-colon first-slash)))))))) + + ) + diff --git a/collects/net/urls.ss b/collects/net/urls.ss new file mode 100644 index 00000000..c3c02a4c --- /dev/null +++ b/collects/net/urls.ss @@ -0,0 +1,18 @@ +(require-library "macro.ss") +(require-library "files.ss") + +(define-signature mzlib:url^ + ((struct url (scheme host port path params query fragment)) + (struct mime-header (name value)) + unixpath->path + get-pure-port ; url [x list (str)] -> in-port + get-impure-port ; url [x list (str)] -> in-port + display-pure-port ; in-port -> () + purify-port ; in-port -> list (mime-header) + netscape/string->url ; (string -> url) + string->url ; str -> url + url->string + call/input-url ; url x (url -> in-port) x + ; (in-port -> T) + ; [x list (str)] -> T + combine-url/relative)) ; url x str -> url diff --git a/collects/net/urlu.ss b/collects/net/urlu.ss new file mode 100644 index 00000000..e897a344 --- /dev/null +++ b/collects/net/urlu.ss @@ -0,0 +1,5 @@ +(require-library "refer.ss") +(require-library "urls.ss" "net") + +(define mzlib:url@ + (require-library-unit/sig "urlr.ss" "net")) diff --git a/collects/quasiquote/qq-client.ss b/collects/quasiquote/qq-client.ss new file mode 100644 index 00000000..374c2ee7 --- /dev/null +++ b/collects/quasiquote/qq-client.ss @@ -0,0 +1,230 @@ +; Time-stamp: <98/05/08 22:29:05 shriram> + +; * Need to make write-holdings-to-file set permissions appropriately. +; * add-{stock,fund} should check if the entry already exists. +; * Allow update of holdings. +; * Print numbers in columns. +; * Improve output quality and media. +; * Enable queries on individual holdings. + +;; Format of RC file: +;; current-seconds (when file was last written) +;; ((entity quantity price) ...) +;; +;; where entity = (stock "...") or (fund "...") + +(require-library "match.ss") +(require-library "date.ss") + +(require-library "qq.ss" "quasiquote") + +(define rc-file "~/.qqrc") + +;; entity : entity +;; quantity : num +;; price : num + +(define-struct holding (entity quantity price)) + +;; raw-holding->holding : +;; raw-holding -> holding + +(define raw-holding->holding + (lambda (rh) + (match rh + ((('stock name) quantity price) + (make-holding (stock name) quantity price)) + ((('fund name) quantity price) + (make-holding (fund name) quantity price)) + (else (error 'qq-client "~s is an invalid entry in the database" rh))))) + +;; holding->raw-holding : +;; holding -> raw-holding + +(define holding->raw-holding + (lambda (h) + (list + (let ((entity (holding-entity h))) + (cond + ((stock? entity) `(stock ,(entity-name entity))) + ((fund? entity) `(fund ,(entity-name entity))) + (else + (error 'qq-client "~s is not a valid entity" entity)))) + (holding-quantity h) + (holding-price h)))) + +;; write-holdings-to-file : +;; list (holding) -> () + +(define write-holdings-to-file + (lambda (holdings) + (let ((p (open-output-file rc-file 'replace))) + (display "; -*- Scheme -*-" p) + (newline p) (newline p) + (display "; Do not edit directly: please use QuasiQuote clients!" p) + (newline p) (newline p) + (write (current-seconds) p) + (newline p) (newline p) + (write (map holding->raw-holding holdings) p) + (newline p) + (close-output-port p)))) + +;; read-holdings-from-file : +;; () -> (seconds + #f) x list (holding) + +(define read-holdings-from-file + (lambda () + (with-handlers ((exn:i/o:filesystem? (lambda (exn) + (values #f null)))) + (let ((p (open-input-file rc-file))) + (values (read p) + (map raw-holding->holding + (read p))))))) + +;; update-holdings : +;; list (holding) -> list (holding) + +(define update-holdings + (lambda (holdings) + (map (lambda (h) + (let ((entity (holding-entity h))) + (let ((new-value (get-quote entity))) + (make-holding entity (holding-quantity h) new-value)))) + holdings))) + +;; changed-positions : +;; list (holding) x list (holding) -> +;; list (holding . num) x list (holding . num) x list (holding) + +(define changed-positions + (lambda (old-in new-in) + (let loop ((old old-in) (new new-in) + (increases null) (decreases null) (stays null)) + (if (and (null? old) (null? new)) + (values increases decreases stays) + (if (or (null? old) (null? new)) + (error 'qq-client "~s and ~s cannot be compared for changes" + old-in new-in) + (let ((first-old (car old)) (first-new (car new))) + (if (string=? (entity-name (holding-entity first-old)) + (entity-name (holding-entity first-new))) + (let* ((price-old (holding-price first-old)) + (price-new (holding-price first-new)) + (difference (- price-new price-old))) + (cond + ((= price-old price-new) + (loop (cdr old) (cdr new) + increases + decreases + (cons first-new stays))) + ((< price-old price-new) + (loop (cdr old) (cdr new) + (cons (cons first-new difference) increases) + decreases + stays)) + (else + (loop (cdr old) (cdr new) + increases + (cons (cons first-new difference) decreases) + stays)))) + (error 'qq-client "~s and ~s are in the same position" + first-old first-new)))))))) + +;; total-value : +;; list (holding) -> num + +(define total-value + (lambda (holdings) + (apply + + (map (lambda (h) + (* (holding-quantity h) (holding-price h))) + holdings)))) + +;; print-position-changes : +;; list (holding . num) x list (holding . num) x list (holding) -> () + +(define print-position-changes + (lambda (increases decreases stays) + (define print-entry/change + (lambda (holding change) + (printf "~a ~a ~a~a~n" + (entity-name (holding-entity holding)) + (holding-price holding) + (if (> change 0) "+" "-") + (abs change)))) + (define print-change + (lambda (banner changes) + (unless (null? changes) + (printf "~a:~n" banner)) + (for-each (lambda (h+delta) + (print-entry/change (car h+delta) (cdr h+delta))) + changes) + (newline))) + (print-change "Increases" increases) + (print-change "Decreases" decreases))) + +;; print-statement : +;; () -> () + +(define print-statement + (lambda () + (let-values (((old-time old-holdings) + (read-holdings-from-file))) + (let ((new-holdings (update-holdings old-holdings))) + (when old-time + (printf "Changes are since ~a~n~n" + (date->string (seconds->date old-time)))) + (let-values (((increases decreases stays) + (changed-positions old-holdings new-holdings))) + (print-position-changes increases decreases stays)) + (let ((old-total (total-value old-holdings)) + (new-total (total-value new-holdings))) + (printf "Total change: ~a~nTotal value: ~a~n" + (- new-total old-total) new-total)) + (write-holdings-to-file new-holdings))))) + +;; create-holding : +;; (str -> entity) -> str x num -> holding + +(define create-holding + (lambda (maker) + (lambda (name quantity) + (let ((entity (maker name))) + (let ((price (get-quote entity))) + (make-holding entity quantity price)))))) + +;; create-holding/stock : +;; str x num -> holding + +(define create-holding/stock + (create-holding stock)) + +;; create-holding/fund : +;; str x num -> holding + +(define create-holding/fund + (create-holding fund)) + +;; add-holding : +;; (str x num -> holding) -> x str x num -> () + +(define add-holding + (lambda (maker) + (lambda (name quantity) + (let-values (((old-time old-holdings) + (read-holdings-from-file))) + (write-holdings-to-file + (cons (maker name quantity) + old-holdings)))))) + +;; add-stock : +;; str x num -> () + +(define add-stock + (add-holding create-holding/stock)) + +;; add-fund : +;; str x num -> () + +(define add-fund + (add-holding create-holding/fund)) diff --git a/collects/quasiquote/qq.ss b/collects/quasiquote/qq.ss new file mode 100644 index 00000000..522e8edb --- /dev/null +++ b/collects/quasiquote/qq.ss @@ -0,0 +1,22 @@ +(require-library "urls.ss" "net") +(require-library "refer.ss") +(require-library "coreu.ss") +(require-library "qqu.ss" "quasiquote") + +(define quasiquote:program@ + (compound-unit/sig + (import) + (link + (MZLIB-CORE : mzlib:core^ + (mzlib:core@)) + (URL : mzlib:url^ + ((require-library-unit/sig "urlr.ss" "net") + (MZLIB-CORE file))) + (INTERFACE : quasiquote:graphical-interface^ + (quasiquote:graphical-interface@)) + (QUOTESTER : quasiquote:quotester^ + (quasiquote:quotester@ INTERFACE URL))) + (export + (open QUOTESTER)))) + +(define-values/invoke-unit/sig quasiquote:quotester^ quasiquote:program@) diff --git a/collects/quasiquote/qqguir.ss b/collects/quasiquote/qqguir.ss new file mode 100644 index 00000000..1cc1cc64 --- /dev/null +++ b/collects/quasiquote/qqguir.ss @@ -0,0 +1,21 @@ +(unit/sig quasiquote:graphical-interface^ + (import) + + (define display-image-stream + (lambda (input-port stock-name) + (let ((tmp-file-name + (build-path (current-directory) + (string-append stock-name "." + (number->string (current-seconds)) + ".gif")))) + (let ((p (open-output-file tmp-file-name))) + (let loop () + (let ((c (read-char input-port))) + (unless (eof-object? c) + (display c p) + (loop)))) + (close-output-port p) + (close-input-port input-port) + (process (string-append "xv " tmp-file-name)))))) + + ) diff --git a/collects/quasiquote/qqr.ss b/collects/quasiquote/qqr.ss new file mode 100644 index 00000000..0a92e0f6 --- /dev/null +++ b/collects/quasiquote/qqr.ss @@ -0,0 +1,98 @@ +(unit/sig quasiquote:quotester^ + (import + quasiquote:graphical-interface^ + (url : mzlib:url^)) + + (define-struct entity (name)) + (define-struct (stock struct:entity) ()) + (define-struct (fund struct:entity) ()) + + (define get-chart + (lambda (entity) + (define base-directory-for-stocks "/sm/pg/") + ;; Rule: append /.gif + (define base-directory-for-funds "/sm/trmfg/") + ;; Rule: append /.gif + (define handle-processing + (lambda (base-dir) + (let ((s (entity-name entity))) + (display-image-stream + (url:get-pure-port + (url:make-url "http" "www.stockmaster.com" #f + (string-append base-dir "/" + (string (string-ref s 0)) + "/" s ".gif") + #f #f #f)) + s)))) + (cond + ((stock? entity) + (handle-processing base-directory-for-stocks)) + ((fund? entity) + (handle-processing base-directory-for-funds)) + (else + (error 'get-chart + "~s is not a stock or fund" entity))))) + + ;; http://www.stocksmart.com/ows-bin/owa/sq.returnPrice?symbol= + ;; (regexp "\\$(.+)") + ;; no longer works -- advantage is it provided ratios instead of decimals + + ;; http://quote.yahoo.com/q?s=&d=v1 + ;; provides some quotes as ratios -- hence the second regexp + + (define extract-quote-amount + (let ((quote-pattern (regexp "(.+)")) + (ratio-pattern (regexp "([0-9]+)/([0-9]+)"))) + (lambda (port symbol) + (let loop () + (let ((line (read-line port))) + (if (eof-object? line) + (error 'get-quote + "No quote found for ~s" (entity-name symbol)) + (let ((matched (regexp-match quote-pattern line))) + (if matched + (let ((value + (let (($string (cadr matched))) + (let ((p (open-input-string $string))) + (let loop ((sum 0)) + (let ((r (read p))) + (if (eof-object? r) + sum + (loop (+ (if (number? r) + r + (let ((ratio-matched + (regexp-match + ratio-pattern + (symbol->string r)))) + (if ratio-matched + (/ (string->number + (cadr ratio-matched)) + (string->number + (caddr ratio-matched))) + (error 'get-quote + "Unrecognized quote ~s" + r)))) + sum))))))))) + ;; out of courtesy to the server, we'll read it all + (let finish-loop () + (let ((line (read-line port))) + (unless (eof-object? line) + (finish-loop)))) + value) + (loop))))))))) + + (define get-quote + (lambda (symbol) + (extract-quote-amount + (url:get-pure-port + (url:make-url "http" "quote.yahoo.com" #f + "/q" ;; leading slash essential + #f + (string-append "s=" (entity-name symbol) "&d=v1") + #f)) + symbol))) + + (define stock make-stock) + (define fund make-fund) + + ) diff --git a/collects/quasiquote/qqs.ss b/collects/quasiquote/qqs.ss new file mode 100644 index 00000000..e632436f --- /dev/null +++ b/collects/quasiquote/qqs.ss @@ -0,0 +1,11 @@ +(define-signature quasiquote:graphical-interface^ + (display-image-stream)) + +(define-signature quasiquote:quotester^ + (get-chart + get-quote + (struct entity (name)) + (struct stock ()) + (struct fund ()) + stock + fund)) diff --git a/collects/quasiquote/qqu.ss b/collects/quasiquote/qqu.ss new file mode 100644 index 00000000..7ee89513 --- /dev/null +++ b/collects/quasiquote/qqu.ss @@ -0,0 +1,8 @@ +(require-library "refer.ss") +(require-library "qqs.ss" "quasiquote") + +(define quasiquote:quotester@ + (require-library-unit/sig "qqr.ss" "quasiquote")) + +(define quasiquote:graphical-interface@ + (require-library-unit/sig "qqguir.ss" "quasiquote")) diff --git a/collects/readline/doc.txt b/collects/readline/doc.txt new file mode 100644 index 00000000..d7ed302b --- /dev/null +++ b/collects/readline/doc.txt @@ -0,0 +1,54 @@ + +The _readline_ collection (not to be confused with MzScheme's +`read-line' procedure) provides glue for using GNU's readline library +with the MzScheme read-eval-print-loop. It has been tested under Linux +(various flavors), FreeBSD, and Solaris. + +To use readline, you must be able to compile the "mzrl.c" file to +produce a MzScheme extension, which requires a C compiler. The +"mzmake.ss" program in the "readline" library attempts to compile it +for you, and the collection installer runs "mzmake.ss". Thus, if the +installation succeeds, you can use the readline library right +away. Otherwise, you may have to modified "mzmake.ss" to get it to +work. + + +Normal use of readline +---------------------- + +The _rep.ss_ library installs a readline-based function for the +prompt-and-read part of MzScheme's read-eval-print loop. + +I put the following in my ~/.mzschemerc so that MzScheme always starts +with readline support: + + (require-library "rep.ss" "readline") + +The readline history is stored across invocations in ~/.mzrl.history, +assuming MzScheme exits normally. + + +Direct bindings for readline hackers +------------------------------------ + +The _readline.ss_ library provides two functions: + +> (readline prompt-string) - prints the given prompt string and reads + an S-expression. + +> (add-history s) - adds the given string to the readline history, + which is accessible to the user via the up-arrow key + + +Known Bugs +---------- + +Hitting ctl-C more than once tends to make either readline or MzScheme +crash (I'm not sure which one). + + + + mflatt@cs.utah.edu + +Note to self: pack with + (pack "readline.plt" "readline" '("collects/readline") '(("readline"))) diff --git a/collects/readline/info.ss b/collects/readline/info.ss new file mode 100644 index 00000000..5d3093a2 --- /dev/null +++ b/collects/readline/info.ss @@ -0,0 +1,10 @@ +(lambda (request failure-thunk) + (case request + [(name) "readline"] + [(install-collection) + (lambda (path) + (parameterize ([current-namespace (make-namespace)] + [current-directory (build-path path "collects" "readline")]) + (global-defined-value 'argv #()) + (load "mzmake.ss")))] + [else (failure-thunk)])) diff --git a/collects/readline/mzmake.ss b/collects/readline/mzmake.ss new file mode 100755 index 00000000..4475a3a3 --- /dev/null +++ b/collects/readline/mzmake.ss @@ -0,0 +1,116 @@ +#!/bin/sh -f +string=? ; if [ "$PLTHOME" = "" ] ; then +string=? ; echo Please define PLTHOME +string=? ; exit -1 +string=? ; fi +string=? ; exec ${PLTHOME}/bin/mzscheme -qr $0 "$@" + +;;; This program attempts to compile and link mzrl.c. +;;; See doc.txt for more information. + +(define mach-id (string->symbol (system-library-subpath))) + +;; Is the readline library in /usr/local/gnu ? + +;; We look for the readline library and includes in the +;; following places: +(define search-path + (list "/usr" + "/usr/local/gnu" + ;; Hack for the author's convenience: + (format "/home/mflatt/proj/readline-2.1/~a" mach-id))) + +(define rl-path + (ormap (lambda (x) + (and (directory-exists? (build-path x "include" "readline")) + (or (file-exists? (build-path x "lib" "libreadline.a")) + (file-exists? (build-path x "lib" "libreadline.so"))) + x)) + search-path)) + +(unless rl-path + (error 'readline-installer + "can't find readline include files and/or library; try editing `search-path' in mzmake.ss")) + +(require-library "make.ss" "make") +(require-library "link.ss" "dynext") +(require-library "compile.ss" "dynext") +(require-library "file.ss" "dynext") + +(require-library "file.ss") +(require-library "functio.ss") + +(make-print-checking #f) + +;; Used as make dependencies: +(define header (build-path (collection-path "mzscheme" "include") "scheme.h")) +(define version-header (build-path (collection-path "mzscheme" "include") "schvers.h")) + +(define dir (build-path "compiled" "native" (system-library-subpath))) +(define mzrl.so (build-path dir (append-extension-suffix "mzrl"))) +(define mzrl.o (build-path dir (append-object-suffix "mzrl"))) + +;; Function used to add a command-line flag: +(define (add-flags fp flags) + (fp (append (fp) flags))) + +;; Add -I to compiler command-line +(add-flags current-extension-compiler-flags + (list (format "-I~a/include" rl-path))) + +;; More platform-specific compiler flags. +(case mach-id + [(rs6k-aix) + (add-flags current-extension-compiler-flags + (list "-DNEEDS_SELECT_H"))] + [else (void)]) + +;; If we don't have a .so file, we need to make the linker +;; use the whole archive: +(when (not (file-exists? (build-path rl-path "lib" "libreadline.so"))) + (case mach-id + [(sparc-solaris i386-solaris) + (add-flags current-extension-linker-flags + (list "-u" "rl_readline_name"))] + [(i386-linux i386-freebsd) + (add-flags current-extension-linker-flags + (list "--whole-archive"))] + [else (fpritnf (current-error-port) + "mzmake.ss Warning: trying to use .a library, but don't know how to force inclusion;~ + ~n result may have undefined references~n")])) + +;; Add -L and -l for readline: +(add-flags current-extension-linker-flags + (list (format "-L~a/lib" rl-path) + "-lreadline")) + +; More platform-specific linker flags. +(case mach-id + [(sparc-solaris i386-solaris) + (add-flags current-extension-linker-flags + (list "-ltermcap"))] + [(rs6k-aix) + (add-flags current-extension-linker-flags + (list "-lc"))] + [else (void)]) + +;; Add the -lcurses flag: +(add-flags current-extension-linker-flags (list "-lcurses")) + +(define (delete/continue x) + (with-handlers ([(lambda (x) #t) void]) + (delete-file x))) + +(make + ((mzrl.so (mzrl.o dir) + (link-extension #f (list mzrl.o) mzrl.so)) + + (mzrl.o ("mzrl.c" header version-header dir) + (compile-extension #f "mzrl.c" mzrl.o ())) + + ("clean" () (begin (delete/continue mzrl.o) (delete/continue mzrl.so))) + + (dir () + (make-directory* dir))) + + argv) diff --git a/collects/readline/mzrl.c b/collects/readline/mzrl.c new file mode 100644 index 00000000..c93ecffc --- /dev/null +++ b/collects/readline/mzrl.c @@ -0,0 +1,94 @@ + +#include "escheme.h" +#include +#include +#include +#ifdef NEEDS_SELECT_H +# include +#endif +#include + +/* For pre-102 compatibility: */ +#ifndef MZ_DECL_VAR_REG +# define MZ_DECL_VAR_REG(x) /* empty */ +# define MZ_VAR_REG(p, x) /* empty */ +# define MZ_CWVR(x) x +#endif + +extern Function *rl_event_hook; + +Scheme_Object *do_readline(int argc, Scheme_Object **argv) +{ + char *s; + Scheme_Object *o; + + if (!SCHEME_STRINGP(argv[0])) + scheme_wrong_type("readline", "string", 0, argc, argv); + + s = readline(SCHEME_STR_VAL(argv[0])); + if (!s) + return scheme_eof; + + o = scheme_make_string(s); + + free(s); + + return o; +} + +Scheme_Object *do_add_history(int argc, Scheme_Object **argv) +{ + char *s; + Scheme_Object *o; + + if (!SCHEME_STRINGP(argv[0])) + scheme_wrong_type("add-history", "string", 0, argc, argv); + + add_history(SCHEME_STR_VAL(argv[0])); + + return scheme_void; +} + +static int check(Scheme_Object *x) +{ + fd_set fd; + struct timeval time = {0, 0}; + + FD_ZERO(&fd); + FD_SET(0, &fd); + return select(1, &fd, NULL, NULL, &time); +} + +static void set_fd_wait(Scheme_Object *x, void *fd) +{ + MZ_FD_SET(0, (fd_set *)fd); +} + +static int block(void) +{ + scheme_block_until(check, set_fd_wait, scheme_void, 0.0); + return 0; +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + Scheme_Object *a[2]; + MZ_DECL_VAR_REG(2); + MZ_VAR_REG(0, a[0]); + MZ_VAR_REG(1, a[1]); + + a[0] = MZ_CWVR(scheme_make_prim_w_arity(do_readline, "readline", 1, 1)); + a[1] = MZ_CWVR(scheme_make_prim_w_arity(do_add_history, "add-history", 1, 1)); + + return MZ_CWVR(scheme_values(2, a)); +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + + rl_readline_name = "mzscheme"; + + rl_event_hook = block; + + return scheme_reload(env); +} diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss new file mode 100644 index 00000000..1ca6d115 --- /dev/null +++ b/collects/readline/pread.ss @@ -0,0 +1,61 @@ + +(let*-values ([(.history) "~/.mzrl.history"] + [(MAX-HISTORY) 100] + [(readline add-history) (require-library "readline.ss" "readline")] + [(leftovers) null] + [(local-history) + (with-handlers ([void (lambda (exn) null)]) + (with-input-from-file .history + (lambda () (read))))] + [(do-readline) + (lambda (p) + (let ([s (readline p)]) + (when (string? s) + (add-history s) + (if (= (length local-history) MAX-HISTORY) + (set! local-history (cdr local-history))) + (set! local-history (append local-history (list s)))) + s))] + [(save-history) + (lambda () + (with-handlers ([void void]) + (with-output-to-file .history + (lambda () (write local-history)) + 'truncate)))]) + (exit-handler (let ([old (exit-handler)]) + (lambda (v) + (save-history) + (old v)))) + (for-each add-history local-history) + (let ([prompt-read-using-readline + (lambda (get-prompt) + (if (pair? leftovers) + (begin0 + (car leftovers) + (set! leftovers (cdr leftovers))) + (let big-loop () + (let loop ([s (do-readline (get-prompt 0))][next-pos 1]) + (if (eof-object? s) + (begin + (save-history) + s) + (with-handlers ([exn:read:eof? + (lambda (exn) + (loop (string-append + s + (string #\newline) + (do-readline (get-prompt next-pos))) + (add1 next-pos)))]) + (let* ([p (open-input-string s)] + [rs (let loop () + (let ([r (read p)]) + (if (eof-object? r) + null + (cons r (loop)))))]) + (if (null? rs) + (big-loop) + (begin0 + (car rs) + (set! leftovers (cdr rs)))))))))))]) + prompt-read-using-readline)) + diff --git a/collects/readline/readline.ss b/collects/readline/readline.ss new file mode 100644 index 00000000..f0362ae1 --- /dev/null +++ b/collects/readline/readline.ss @@ -0,0 +1,2 @@ + +(load-relative-extension (build-path "compiled" "native" (system-library-subpath) "mzrl.so")) diff --git a/collects/readline/rep.ss b/collects/readline/rep.ss new file mode 100644 index 00000000..20c67727 --- /dev/null +++ b/collects/readline/rep.ss @@ -0,0 +1,10 @@ + +(current-prompt-read + (let ([read (require-library "pread.ss" "readline")] + [orig-read (current-prompt-read)] + [orig-input (current-input-port)]) + (lambda () + (if (eq? (current-input-port) orig-input) + (read (lambda (n) (if (zero? n) "> " " "))) + (orig-read))))) + diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt new file mode 100644 index 00000000..142ac759 --- /dev/null +++ b/collects/setup/doc.txt @@ -0,0 +1,289 @@ + +_Setup PLT_ or _setup-plt_: Collection Setup and Unpacking +========================================================== + +The Setup PLT executable (bin/setup-plt for Unix) performs two +services: + + * Compiling and setting up all collections: When Setup PLT is run + without any arguments, it finds all of the current collections + (using the PLTHOME and PLTCOLLECTS environment variable) + and compiles all collections with an info.ss library that + indicates how the collection is compiled (see the + --collection-zos flag for mzc). + + The --clean (or -c) flag to Setup PLT causes it to delete + all existing .zo and extension files, thus ensuring a clean + build from the source files. (Exactly which files are deleted + is controlled by the info.ss file. See below for more info.) + + The -l flag takes one or more collection names and restricts + Setup PLT's action to those collections. + + In addition to compilation, a collection's info.ss library + can specify executables to be installed in the plt directory + (plt/bin under Unix) or other installation actions. + + * Unpacking _.plt_ files: A .plt file is a platform-indepedent + distribution archive for MzScheme- and MrEd-based software. + When one or more file names are provided as the command line + arguments to Setup PLT, the files contained in the .plt + archive are unpacked (according to specifications embedded in + the .plt file; see below) and only the collections specified + by the plt file are compiled and setup (they are setup as if + the "-c" or "--clean" flag had been passed to setup plt) + + Compiling and Setting Up Collections + ------------------------------------ + +Setup PLT attempts to compile and set up any collection that: + + * has an info.ss library; + + * is a top-level collection (not a sub-collection; top-level + collections can specify subcollections to be compiled and + set up with the `compile-subcollections' info.ss field); + and + + * has the 'name info.ss field. + +Collections meeting this criteria are compiled using the +`compile-collection-zos' procedure described above. If the -e or +--extension flag is specified, then the collections are also compiled +using the `compile-collection-extension' procedure described above. + +Additional info.ss fields trigger additional setup actions: + +> 'mzscheme-launcher-names - a list of executable names to be + installed in plt (or plt/bin) to run MzScheme programs implemented + by the collection. A parallel list of library names must be + provided by `mzscheme-launcher-libraries'. For each name, a + launching executable is set up using the launcher collection's + `install-mzscheme-program-launcher'. If the executable already + exists, no action is taken. + +> 'mzscheme-launcher-libraries - a list of library names in + parallel to `mzscheme-launcher-names'. + +> 'mred-launcher-names - a list of executable names to be installed + in plt (or plt/bin) to run MrEd programs implemented by the + collection. A parallel list of library names must be provided by + `mred-launcher-libraries'. For each name, a launching executable is + set up using the launcher collection's + `install-mred-program-launcher'. If the executable already exists, + no action is taken. + +> 'mred-launcher-libraries - a list of library names in + parallel to `mred-launcher-names'. + +> 'install-collection - a procedure that accepts a directory path + argument (the path to the collection) and performs + collection-specific installation work. This procedure should avoid + unnecessary work in the case that it is called multiple times for + the same installation. + +> 'clean - a list of pathnames to be deleted when the --clean or + -c flag is passed to setup-plt. The pathnames must be relative to + the collection. If the any path names a directory, each of the + files in the directory are deleted but none of the subdirectories of that + directory are checked. If the path names a file, + the file is deleted. The default, if this flag is not specified, is + to delete all files in the compiled subdirectory. + and all of the files in the architecture-specific subdirectory of + the compiled directory, for the architecture that setup-plt + is running under. + + + Unpacking .plt Distribution Archives + ------------------------------------ + +The extension ".plt" is not required for a distribution archive; this +convention merely helps users identify the purpose of a distribution +file. + +The raw format of a distribution file is described below. This format +is uncompressed and sensitive to communication modes (text +vs. binary), so the distribution format is derived from the raw format +by first compressing the file using gzip, then encoding the gzipped +file with the MIME base64 standard (which relies only the characters +A-Z, a-z, 0-9, +, /, and =; all other characters are ignored when +a base64-encoded file is decoded). + +The raw format is + + * "PLT" are the first three characters. + + * An info.ss-like procedure that takes a symbol and a failure thunk + and returns information about archive for recognized symbols. The + two required info fields are: + + + 'name - a human-readable string describing the archive's + contents. This name is used only for printing messages to the + user during unpacking. + + + 'unpacker - a symbol indicating the expected unpacking + environment. Currently, the only allowed value is 'mzscheme. + + The procedure is extracted from the archive using MzScheme's + `read' and `eval' procedures. + + * An unsigned unit that drives the unpacking process. The unit accepts two + imports: a path string for the plt directory and an `unmztar' + procedure. The remainder of the unpacking process consists of invoking + ths unit. It is expected that the unit will call `unmztar' procedure to + unpack directories and files that are defined in the input archive afer + this unit. The result of invoking the unit must be a list of collection + paths (where each collection path is a list of strings); once the + archive is unpacked, Setup PLT will compile and setup the specified + collections, as if it was invoked with the "-c" option, so the + "compiled" directories will be deleted. + + The `unmztar' procedure takes one argument: a filter + procedure. The filter procedure is called for each directory and + file to be unpacked. It is called with three arguments: + + + 'dir, 'file, 'file-replace - indicates whether the item to be + unpacked is a directory, a file, or a file to be replaced; + + + a relative path string - the pathname of the directory or file + to be unpacked, relative to the plt directory; and + + + a path string for the plt directory. + + If the filter procedure returns #f for a directory or file, the + directory or file is not unpacked. If the filter procedure returns + #t and the directory or file for 'dir or 'file already exists, it + is not created. (The file for 'file-replace need not exist + already.) + + When a directory is unpacked, intermediate directies are created + as necessary to create the specified directory. When a file is + unpacked, the directory must already exist. + + The unit is extracted from the archive using MzScheme's `read' + and `eval' procedures. + +Assuming that the unpacking unit calls the `unmztar' procedure, the +archive should continue with unpackables. Unpackables are extracted +until the end-of-file is found (as indicated by an `=' in the +base64-encoded input archive). + +An unpackable is one of the following: + + * The symbol 'dir followed by a list. The `build-path' procedure + will be applied to the list to obtain a relative path for the + directory (and the relatie path is combined with the plt directory + path to ge a complete path). + + The 'dir symbol and list are extracted from the archive using + MzScheme's `read' (and the result is *not* `eval'uated). + + * The symbol 'file, a list, a number, an asterisk, and the file + data. The list specifies the file's relative path, just as for + directories. The number indicates the size of the file to be + unpacked in bytes. The asterisk indicates the start of the file + data; the next n bytes are written to the file, where n is the + specified size of the file. + + The symbol, list, and number are all extracted from the archive + using MzScheme's `read' (and the result is *not* `eval'uated). + After the number is read, input characters are discarded until + an asterisk is found. The file data must follow this asterisk + immediately. + + * The symbol 'file-replace is treated like 'file, but if the file + exists on disk already, the file in the archive replaces the file + on disk. + + Making .plt archives + -------------------- + +The setup collection's pack.ss library provides functions to help +make .plt archives, especially under Unix: + +> (pack dest name paths collections [filter encode? file-mode]) - + Creates the .plt file specified by the pathname `dest', using the + string `name' as the name reported to Setup PLT as the archive's + description, and `collections' as the list of colection paths + returned by the unpacking unit. The `paths argument must be a list + of relative paths for directories and files; the contents of these + files and directories will be packed into the archive. + + The `filter' procedure is called with the relative path of each + candidate for packing. If it returns #f for some path, then that + file or directory is omitted from the archive. If it returns 'file + or 'file-replace for a file, the file is packed with that mode, + rather than the default mode. The default `filter' is `std-filter' + (defined below). + + If `encode?' is #f, then the output archive is in raw form, and + still must be gzipped and mime-encoded. If `encode?' is #t, then + gzip and mmencode must be in the shell's path for executables. + the default value is #t. + + The `file-mode' argument must be 'file or 'file-replace, indicating + the default mode for a file in the archive. The default value is + 'file. + +> (std-filter p) - returns #t unless `p' matches one of the following + regular expressions: "CVS$", "compiled$", "~$", or "^#.*#$". + +> (mztar path output filter file-mode) - called by `pack' to write one + directory/file `path' to the output port `output' using the filter + procedure `filter' (see `pack' for a description of `filter'). The + `file-mode' argument specifies the default mode for packing a file, + either 'file or 'file-replace. + + Setup PLT as a Unit + ------------------- + +The _setupr.ss_ library in the setup collection contains a signed +unit that imports + + setup-option^ - described below + mzlib:file^ + compiler^ - from sig.ss in the compiler collection + compiler:option^ - from sig.ss in the compiler collection + launcher-maker^ - from launchers.ss in the `launcher' collection + +Invoking this unit starts the setup process. The _setupsig.ss_ library +defines the +> setup-option^ +signature, which is implemented by the unit in _setup-optionr.ss_. It +defines the following parameters that control the setup process: + +> verbose - #t => prints message from `make' to stderr [default: #f] +> make-verbose - #t => verbose `make' [default: #f] +> compiler-verbose - #t => verbose `compiler' [default: #f] +> clean - #t => delete .zo and .so/.dll files in the specified collections + [default: #f] +> make-zo - #t => compile .zo files [default #t] +> make-so - #t => compile .so/.dll files [default: #f] +> make-launchers - #t => make collection info.ss-specified launchers + [default: #t] +> call-install - #t => call collection info.ss-specified setup code + [default: #t] +> specific-collections - a list of collections to set up; the empty + list means set-up all collections if the archives + list is also empty [default: null] +> archives - a list of .plt archives to unpack; any collections specified + by the archives are set-up in addition to the collections + listed in specific-collections [default: null] + +Thus, to unpack a single .plt archive "x.plt", set the `archives' +parameter to (list "x.plt") and leave `specific-collections' as null. + +Link the options and setup units so that your option-setting code is +initialized between them, e.g.: + + (compound-unit/sig + ... + (link ... + [OPTIONS : setup-option^ + ((require-library "setup-optionr.ss" "setup"))] + [MY-CODE : () + ((require-library "init-options.ss") OPTIONS)] + [SETUP : () + ((require-library "setupr.ss" "setup") + OPTIONS ...)]) + ...) diff --git a/collects/setup/info.ss b/collects/setup/info.ss new file mode 100644 index 00000000..480347a5 --- /dev/null +++ b/collects/setup/info.ss @@ -0,0 +1,12 @@ + +(lambda (request failure) + (case request + [(name) "Setup PLT"] + [(compile-prefix) `(begin + (require-library "refer.ss") + (require-library "setupsig.ss" "setup"))] + [(compile-omit-files) (list "setup.ss" "setupsig.ss")] + [(compile-elaboration-zos) (list "setupsig.ss")] + [(mzscheme-launcher-libraries) (list "setup.ss")] + [(mzscheme-launcher-names) (list "Setup PLT")] + [else (failure)])) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss new file mode 100644 index 00000000..abb3f454 --- /dev/null +++ b/collects/setup/pack.ss @@ -0,0 +1,100 @@ + +;; Utilities for creating a .plt package, relies on gzip and mmencode + +(define pack + (case-lambda + [(dest name paths collections) + (pack dest name paths collections std-filter #t 'file)] + [(dest name paths collections filter) + (pack dest name paths collections filter #t 'file)] + [(dest name paths collections filter encode?) + (pack dest name paths collections filter encode? 'file)] + [(dest name paths collections filter encode? file-mode) + (let* ([p (if encode? + (process (format "gzip -c | mmencode > ~s" dest)) + #f)] + [stdin (if p + (cadr p) + (open-output-file dest 'truncate/replace))] + [echo (lambda (p) + (thread + (lambda () + (let loop () + (let ([l (read-line p 'any)]) + (unless (eof-object? l) + (printf "~a~n" l) + (loop)))))))] + [t1 (and p (echo (car p)))] + [t2 (and p (echo (list-ref p 3)))]) + (fprintf stdin "PLT~n") + (write + `(lambda (request failure) + (case request + [(name) ,name] + [(unpacker) 'mzscheme])) + stdin) + (newline stdin) + (write + `(unit + (import plthome mzuntar) + (export) + (mzuntar void) + (quote ,collections)) + stdin) + (newline stdin) + (for-each + (lambda (path) + (mztar path stdin filter file-mode)) + paths) + (close-output-port stdin) + (when p + (thread-wait t1) + (thread-wait t2)))])) + +(define (mztar path output filter file-mode) + (define (path->list p) + (let-values ([(base name dir?) (split-path p)]) + (if (string? base) + (append (path->list base) (list name)) + (list name)))) + (define-values (init-dir init-files) + (if (file-exists? path) + (let-values ([(base name dir?) (split-path path)]) + (values base (list name))) + (values path #f))) + + (let loop ([dir init-dir][dpath (path->list init-dir)][files init-files]) + (printf "MzTarring ~a~a...~n" dir + (if files (car files) "")) + (fprintf output "~s~n~s~n" 'dir dpath) + (for-each + (lambda (f) + (let* ([p (build-path dir f)] + [filter-val (filter p)]) + (when filter-val + (if (directory-exists? p) + (loop p (append dpath (list f)) #f) + (let ([len (file-size p)]) + ; (printf "MzTarring ~a~n" p) + (fprintf output "~s~n~s~n~s~n*" + (case filter-val + [(file) 'file] + [(file-replace) 'file-replace] + [else file-mode]) + (append dpath (list f)) + len) + (with-input-from-file p + (lambda () + (let loop () + (let ([c (read-char)]) + (unless (eof-object? c) + (write-char c output) + (loop))))))))))) + (or files (directory-list dir))))) + +(define (std-filter path) + (not (or (regexp-match "CVS$" path) + (regexp-match "compiled$" path) + (regexp-match "~$" path) + (regexp-match "^#.*#$" path)))) + diff --git a/collects/setup/setup-optionr.ss b/collects/setup/setup-optionr.ss new file mode 100644 index 00000000..9684dc3c --- /dev/null +++ b/collects/setup/setup-optionr.ss @@ -0,0 +1,19 @@ + +(unit/sig setup-option^ + (import) + + (define verbose (make-parameter #f)) + (define make-verbose (make-parameter #f)) + (define compiler-verbose (make-parameter #f)) + (define clean (make-parameter #f)) + (define make-zo (make-parameter #t)) + (define make-so (make-parameter #f)) + (define make-launchers (make-parameter #t)) + (define call-install (make-parameter #t)) + (define pause-on-errors (make-parameter #f)) + + (define specific-collections (make-parameter null)) + (define archives (make-parameter null))) + + + diff --git a/collects/setup/setup.ss b/collects/setup/setup.ss new file mode 100644 index 00000000..875d492b --- /dev/null +++ b/collects/setup/setup.ss @@ -0,0 +1,91 @@ + +(parameterize ([use-compiled-file-kinds 'none]) + (require-library "compile.ss" "compiler")) + +(parameterize ([use-compiled-file-kinds 'none]) + (require-library "cmdline.ss") + (require-relative-library "setupsig.ss") + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig setup-option^ + (parameterize ([use-compiled-file-kinds 'none]) + (require-relative-library "setup-optionr.ss"))) + +(define-values (x-specific-collections x-archives) + (command-line + "setup-plt" + argv + (once-each + [("-c" "--clean") "Delete existing compiled files" + (clean #t)] + [("-n" "--no-zo") "Do not produce .zo files" + (make-zo #f)] + [("-x" "--no-launcher") "Do not produce launcher programs" + (make-launchers #f)] + [("-i" "--no-install") "Do not call collection-specific installers" + (call-install #f)] + [("-e" "--extension") "Produce native code extensions" + (make-so #t)] + [("-v" "--verbose") "See names of compiled files and info printfs" + (verbose #t)] + [("-m" "--make-verbose") "See make and compiler usual messages" + (make-verbose #t)] + [("-r" "--compile-verbose") "See make and compiler verbose messages" + (make-verbose #t) + (compiler-verbose #t)] + [("-p" "--pause") "Pause at the end if there are any errors" + (pause-on-errors #t)] + [("-l") => + (lambda (flag . collections) + (map list collections)) + '("Setup specific s only" "collection")]) + (=> + (lambda (collections . archives) + (values (if (null? collections) + null + (car collections)) + archives)) + '("archive") + (lambda (s) + (display s) + (printf "If no or -l is specified, all collections are setup~n") + (exit 0))))) + +(specific-collections x-specific-collections) +(archives x-archives) + +(parameterize ([use-compiled-file-kinds (if (clean) 'none (use-compiled-file-kinds))]) + (require-library "sig.ss" "compiler")) + +(parameterize ([use-compiled-file-kinds (if (clean) 'none (use-compiled-file-kinds))]) + (invoke-unit/sig + (compound-unit/sig + (import (SOPTION : setup-option^)) + (link [STRING : mzlib:string^ ((require-library "stringr.ss"))] + [FILE : mzlib:file^ ((require-library "filer.ss") STRING FUNCTION)] + [FUNCTION : mzlib:function^ ((require-library "functior.ss"))] + [COMPILE : mzlib:compile^ ((require-library "compiler.ss"))] + [PRETTY-PRINT : mzlib:pretty-print^ ((require-library "prettyr.ss"))] + [LAUNCHER : launcher-maker^ ((require-library "launcherr.ss" "launcher") FILE)] + [DCOMPILE : dynext:compile^ ((require-library "compiler.ss" "dynext"))] + [DLINK : dynext:link^ ((require-library "linkr.ss" "dynext"))] + [DFILE : dynext:file^ ((require-library "filer.ss" "dynext"))] + [OPTION : compiler:option^ ((require-library "optionr.ss" "compiler"))] + [COMPILER : compiler^ ((require-library "compiler.ss" "compiler") + OPTION + FUNCTION + PRETTY-PRINT + FILE + STRING + COMPILE + DCOMPILE + DLINK + DFILE)] + [SETUP : () ((require-relative-library "setupr.ss") + SOPTION + FILE + COMPILER + OPTION + LAUNCHER)]) + (export)) + setup-option^)) diff --git a/collects/setup/setupr.ss b/collects/setup/setupr.ss new file mode 100644 index 00000000..d5a67472 --- /dev/null +++ b/collects/setup/setupr.ss @@ -0,0 +1,587 @@ + +; Expects parameters to be set before invocation. +; Calls `exit' when done. + +(unit/sig () + (import setup-option^ + mzlib:file^ + compiler^ + (compiler:option : compiler:option^) + launcher-maker^) + + (define plthome + (or (getenv "PLTHOME") + (let ([dir (collection-path "mzlib")]) + (and dir + (let-values ([(base name dir?) (split-path dir)]) + (and (string? base) + (let-values ([(base name dir?) (split-path base)]) + (and (string? base) + (complete-path? base) + base)))))))) + + (define setup-fprintf + (lambda (p s . args) + (apply fprintf p (string-append "setup-plt: " s "~n") args))) + + (define setup-printf + (lambda (s . args) + (apply setup-fprintf (current-output-port) s args))) + + (setup-printf "Setup version is ~a" (version)) + (setup-printf "PLT home directory is ~a" plthome) + (setup-printf "Collection Paths are: ~a" (current-library-collection-paths)) + + (exit-handler + (let ([oh (exit-handler)]) + (lambda (num) + (let ([error-log (build-path (collection-path "setup") "errors")]) + (if (zero? num) + (when (file-exists? error-log) + (delete-file error-log)) + (call-with-output-file error-log + (lambda (port) + (show-errors port)) + 'truncate)) + (oh num))))) + + (define (warning s x) + (setup-printf s + (if (exn? x) + (exn-message x) + x))) + + (define (pretty-name f) + (with-handlers ([void (lambda (x) f)]) + (let-values ([(base name dir?) (split-path f)]) + (format "~a in ~a" name base)))) + + (define (call-info info flag default test) + (with-handlers ([void (lambda (x) + (warning + (format "Warning: error getting ~a info: ~~a" + flag) + x) + default)]) + (let ([v (info flag (lambda () default))]) + (test v) + v))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Archive Unpacking ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (port64->port p) + (let* ([waiting 0] + [waiting-bits 0] + [at-eof? #f] + [push + (lambda (v) + (set! waiting (+ (arithmetic-shift waiting 6) v)) + (set! waiting-bits (+ waiting-bits 6)))]) + (make-input-port + (lambda () + (let loop () + (if at-eof? + eof + (if (>= waiting-bits 8) + (begin0 + (integer->char (arithmetic-shift waiting (- 8 waiting-bits))) + (set! waiting-bits (- waiting-bits 8)) + (set! waiting (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits))))) + (let* ([c (read-char p)] + [n (if (eof-object? c) + (#%char->integer #\=) + (char->integer c))]) + (cond + [(<= (#%char->integer #\A) n (#%char->integer #\Z)) (push (- n (#%char->integer #\A)))] + [(<= (#%char->integer #\a) n (#%char->integer #\z)) (push (+ 26 (- n (#%char->integer #\a))))] + [(<= (#%char->integer #\0) n (#%char->integer #\9)) (push (+ 52 (- n (#%char->integer #\0))))] + [(= (#%char->integer #\+) n) (push 62)] + [(= (#%char->integer #\/) n) (push 63)] + [(= (#%char->integer #\=) n) (set! at-eof? #t)]) + (loop)))))) + (lambda () + (or at-eof? (char-ready? p))) + void))) + + (define (port64gz->port p64gz) + (let ([gunzip-through-ports + (invoke-unit/sig + (compound-unit/sig + (import) + (link [I : (gunzip-through-ports) ((require-library "inflater.ss"))] + [X : () ((unit/sig () (import (gunzip-through-ports)) gunzip-through-ports) I)]) + (export)))]) + ; Inflate in a thread so the whole input isn't read at once + (let*-values ([(pgz) (port64->port p64gz)] + [(waiting?) #f] + [(ready) (make-semaphore)] + [(read-pipe write-pipe) (make-pipe)] + [(out) (make-output-port + (lambda (s) + (set! waiting? #t) + (semaphore-wait ready) + (set! waiting? #f) + (display s write-pipe)) + (lambda () + (close-output-port write-pipe)))] + [(get) (make-input-port + (lambda () + (if (char-ready? read-pipe) + (read-char read-pipe) + (begin + (semaphore-post ready) + (read-char read-pipe)))) + (lambda () + (or (char-ready? read-pipe) waiting?)) + (lambda () + (close-input-port read-pipe)))]) + (thread (lambda () + (with-handlers ([void (lambda (x) + (warning "Warning: unpacking error: ~a" x))]) + (gunzip-through-ports pgz out)) + (close-output-port out))) + get))) + + (define (unmztar p filter) + (let loop () + (let ([kind (read p)]) + (unless (eof-object? kind) + (case kind + [(dir) (let ([s (apply build-path (read p))]) + (unless (relative-path? s) + (error "expected a directory name relative path string, got" s)) + (when (filter 'dir s plthome) + (let ([d (build-path plthome s)]) + (unless (directory-exists? d) + (when (verbose) + (setup-printf " making directory ~a" (pretty-name d))) + (make-directory* d)))))] + [(file file-replace) + (let ([s (apply build-path (read p))]) + (unless (relative-path? s) + (error "expected a file name relative path string, got" s)) + (let ([len (read p)]) + (unless (and (number? len) (integer? len)) + (error "expected a file name size, got" len)) + (let* ([write? (filter kind s plthome)] + [path (build-path plthome s)]) + (let ([out (and write? + (if (file-exists? path) + (if (eq? kind 'file) + #f + (open-output-file path 'truncate)) + (open-output-file path)))]) + (when (and write? (not out)) + (setup-printf " skipping ~a; already exists" (pretty-name path))) + (when (and out (or #t (verbose))) + (setup-printf " unpacking ~a" (pretty-name path))) + ; Find starting * + (let loop () + (let ([c (read-char p)]) + (cond + [(char=? c #\*) (void)] ; found it + [(char-whitespace? c) (loop)] + [(eof-object? c) (void)] ; signal the error below + [else (error + (format + "unexpected character setting up ~a, looking for #\*" + path) + c)]))) + ; Copy file data + (let loop ([n len]) + (unless (zero? n) + (let ([c (read-char p)]) + (when (eof-object? c) + (error (format + "unexpected end-of-file while ~a ~a (at ~a of ~a)" + (if out "unpacking" "skipping") + path + (- len n -1) len))) + (when out + (write-char c out))) + (loop (sub1 n)))) + (when out + (close-output-port out))))))] + [else (error "unknown file tag" kind)]) + (loop))))) + + (define (unpack-archive archive) + (with-handlers ([void + (lambda (x) + (warning (format "Warning: error unpacking ~a: ~~a" + archive) + x) + null)]) + (call-with-input-file archive + (lambda (p64) + (let* ([p (port64gz->port p64)]) + (unless (and (eq? #\P (read-char p)) + (eq? #\L (read-char p)) + (eq? #\T (read-char p))) + (error "not an unpackable distribution archive")) + (let* ([n (make-namespace)] + [info (eval (read p) n)]) + (unless (and (procedure? info) + (procedure-arity-includes? info 2)) + (error "expected a procedure of arity 2, got" info)) + (let ([name (call-info info 'name #f + (lambda (n) + (unless (string? n) + (if n + (error "couldn't find the package name") + (error "expected a string")))))] + [unpacker (call-info info 'unpacker #f + (lambda (n) + (unless (eq? n 'mzscheme) + (error "unpacker isn't mzscheme:" n))))]) + (unless (and name unpacker) + (error "bad name or unpacker")) + (setup-printf "Unpacking ~a from ~a" name archive) + (let ([u (eval (read p) n)]) + (unless (unit? u) + (error "expected a unit, got" u)) + (let ([plthome plthome] + [unmztar (lambda (filter) + (unmztar p filter))]) + (invoke-unit u plthome unmztar)))))))))) + + (define x-specific-collections + (apply + append + (specific-collections) + (map unpack-archive (archives)))) + + (define (done) + (setup-printf "Done setting up")) + + (unless (null? (archives)) + (when (null? x-specific-collections) + (done) + (exit 0))) ; done + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Collection Compilation ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-struct cc (collection path name info)) + + (define collection->cc + (lambda (collection-p) + (with-handlers ([void (lambda (x) #f)]) + (let ([dir (apply collection-path collection-p)]) + (with-handlers ([(lambda (x) + (and (exn:i/o:filesystem? x) + (string=? (exn:i/o:filesystem-pathname x) + (build-path dir "info.ss")))) + (lambda (x) #f)] + [void + (lambda (x) + (warning "Warning: error loading info.ss: ~a" x) + #f)]) + (let* ([info (parameterize ([use-compiled-file-kinds 'none]) + (apply require-library/proc "info.ss" collection-p))] + [name (call-info info 'name #f + (lambda (x) + (unless (string? x) + (error "result is not a string:" x))))]) + (and + name + ;(call-info info 'compile-prefix #f #t) + (make-cc + collection-p + (apply collection-path collection-p) + name + info)))))))) + + (define (cannot-compile c) + (error 'setup-plt "don't know how to compile collection: ~a" + (if (= (length c) 1) + (car c) + c))) + + (define collections-to-compile + (if (null? x-specific-collections) + (let ([ht (make-hash-table)]) + (let loop ([collection-paths (current-library-collection-paths)]) + (cond + [(null? collection-paths) + (hash-table-map ht (lambda (k v) v))] + [else (let ([cp (car collection-paths)]) + (let loop ([collections (if (directory-exists? cp) + (directory-list cp) + null)]) + (cond + [(null? collections) (void)] + [else (let* ([collection (car collections)] + [coll-sym (string->symbol collection)]) + (hash-table-get + ht + coll-sym + (lambda () + (let ([cc (collection->cc (list collection))]) + (when cc + (hash-table-put! + ht + coll-sym + cc)))))) + (loop (cdr collections))]))) + (loop (cdr collection-paths))]))) + (map + (lambda (c) + (or (collection->cc c) + (cannot-compile c))) + x-specific-collections))) + + (define control-io-apply + (lambda (print-doing f args) + (if (make-verbose) + (begin + (apply f args) + #t) + (let* ([oop (current-output-port)] + [printed? #f] + [on? #f] + [op (make-output-port + (lambda (s) + (let loop ([s s]) + (if on? + (let ([m (regexp-match-positions (string #\newline) s)]) + (if m + (begin + (set! on? #f) + (when (verbose) + (display (substring s 0 (add1 (caar m))) oop) + (flush-output oop)) + (loop (substring s (add1 (caar m)) (string-length s)))) + (when (verbose) + (display s oop) + (flush-output oop)))) + (let ([m (or (regexp-match-positions "making" s) + (regexp-match-positions "compiling" s))]) + (when m + (unless printed? + (set! printed? #t) + (print-doing oop)) + (set! on? #t) + (when (verbose) + (display " " oop)) ; indentation + (loop (substring s (caar m) (string-length s)))))))) + void)]) + (parameterize ([current-output-port op]) + (apply f args) + printed?))))) + + ; Close over sub-collections + (set! collections-to-compile + (let loop ([l collections-to-compile]) + (if (null? l) + null + (let* ([cc (car l)] + [info (cc-info cc)]) + (append + (list cc) + (map + (lambda (subcol) + (or + (collection->cc subcol) + (cannot-compile subcol))) + (call-info info 'compile-subcollections null + (lambda (x) + (unless (and (list? x) + (andmap + (lambda (x) + (list? x) + (andmap + (lambda (x) + (and (string? x) + (relative-path? x))) + x)) + x)) + (error "result is not a list of relative path string lists:" x))))) + (loop (cdr l))))))) + + (define (delete-files-in-directory path printout) + (for-each + (lambda (end-path) + (let ([path (build-path path end-path)]) + (cond + [(directory-exists? path) + (void)] + [(file-exists? path) + (printout) + (unless (delete-file path) + (error 'delete-files-in-directory + "unable to delete file: ~a" path))] + [else (error 'delete-files-in-directory + "encountered ~a, neither a file nor a directory" + path)]))) + (directory-list path))) + + (define (is-subcollection? collection sub-coll) + (cond + [(null? collection) #t] + [(null? sub-coll) #f] + [else (and (string=? (car collection) (car sub-coll)) + (is-subcollection? (cdr collection) (cdr sub-coll)))])) + + (define (clean-collection cc) + (let* ([info (cc-info cc)] + [default (box 'default)] + [paths (call-info + info + 'clean + (list "compiled" (build-path "compiled" "native" (system-library-subpath))) + (lambda (x) + (unless (or (eq? x default) + (and (list? x) + (andmap string? x))) + (error 'setup-plt "expected a list of strings for 'clean, got: ~s" + x))))] + [printed? #f] + [print-message + (lambda () + (unless printed? + (set! printed? #t) + (setup-printf "Deleting files for ~a." (cc-name cc))))]) + (for-each (lambda (path) + (let ([full-path (build-path (cc-path cc) path)]) + (cond + [(directory-exists? full-path) + (delete-files-in-directory + full-path + print-message)] + [(file-exists? full-path) + (delete-file full-path) + (print-message)] + [else (void)]))) + paths))) + + (when (clean) + (for-each clean-collection collections-to-compile)) + + (when (or (make-zo) (make-so)) + (compiler:option:verbose (compiler-verbose)) + (compiler:option:compile-subcollections #f)) + + (define errors null) + (define (record-error cc desc go) + (with-handlers ([(lambda (x) (not (exn:misc:user-break? x))) + (lambda (x) + (if (exn? x) + (begin + (fprintf (current-error-port) "~a~n" (exn-message x)) + (when (defined? 'print-error-trace) + ((global-defined-value 'print-error-trace) + (current-error-port) + x))) + (fprintf (current-error-port) "~s~n" x)) + (set! errors (cons (list cc desc x) errors)))]) + (go))) + (define (show-errors port) + (for-each + (lambda (e) + (let ([cc (car e)] + [desc (cadr e)] + [x (caddr e)]) + (setup-fprintf port + " Error during ~a for ~a (~a)" + desc (cc-name cc) (cc-path cc)) + (if (exn? x) + (setup-fprintf port " ~a" (exn-message x)) + (setup-fprintf port " ~s" x)))) + errors)) + + (define (make-it desc compile-collection) + (for-each (lambda (cc) + (record-error + cc + (format "Making ~a" desc) + (lambda () + (unless (let ([b (box 1)]) (eq? b ((cc-info cc) 'compile-prefix (lambda () b)))) + (unless (control-io-apply + (lambda (p) (setup-fprintf p "Making ~a for ~a at ~a" desc (cc-name cc) (cc-path cc))) + compile-collection + (cc-collection cc)) + (setup-printf "No need to make ~a for ~a at ~a" desc (cc-name cc) (cc-path cc))))))) + collections-to-compile)) + + (when (make-zo) (make-it ".zos" compile-collection-zos)) + (when (make-so) (make-it "extension" compile-collection-extension)) + + (when (make-launchers) + (let ([name-list + (lambda (l) + (unless (and (list? l) + (andmap (lambda (x) + (and (string? x) + (relative-path? x))) + l)) + (error "result is not a list of relative path strings:" l)))]) + (for-each (lambda (cc) + (record-error + cc + "Launcher Setup" + (lambda () + (when (= 1 (length (cc-collection cc))) + (let ([info (cc-info cc)]) + (map + (lambda (kind + mzscheme-launcher-libraries + mzscheme-launcher-names + mzscheme-program-launcher-path + install-mzscheme-program-launcher) + (let ([mzlls (call-info info mzscheme-launcher-libraries null + name-list)] + [mzlns (call-info info mzscheme-launcher-names null + name-list)]) + (if (= (length mzlls) (length mzlns)) + (map + (lambda (mzll mzln) + (let ([p (mzscheme-program-launcher-path mzln)]) + (unless (file-exists? p) + (setup-printf "Installing ~a launcher ~a" kind p) + (install-mzscheme-program-launcher + mzll + (car (cc-collection cc)) + mzln)))) + mzlls mzlns) + (setup-printf "Warning: ~a launcher library list ~s doesn't match name list ~s" + kind mzlls mzlns)))) + '("MzScheme" "MrEd") + '(mzscheme-launcher-libraries mred-launcher-libraries) + '(mzscheme-launcher-names mred-launcher-names) + (list mzscheme-program-launcher-path mred-program-launcher-path) + (list install-mzscheme-program-launcher install-mred-program-launcher))))))) + collections-to-compile))) + + (when (call-install) + (for-each (lambda (cc) + (let/ec k + (record-error + cc + "General Install" + (lambda () + (let ([t ((cc-info cc) 'install-collection (lambda () (k #f)))]) + (unless (and (procedure? t) + (procedure-arity-includes? t 1)) + (error 'setup-plt + "install-collection: result is not a procedure of arity 1 for ~a" + (cc-name cc))) + (setup-printf "Installing ~a" (cc-name cc)) + (t plthome)))))) + collections-to-compile)) + + (done) + + (unless (null? errors) + (setup-printf "") + (show-errors (current-error-port)) + (when (pause-on-errors) + (fprintf (current-error-port) + "INSTALLATION FAILED.~nPress Enter to continue...~n") + (read-line)) + (exit 1)) + + (exit 0)) diff --git a/collects/setup/setupsig.ss b/collects/setup/setupsig.ss new file mode 100644 index 00000000..72b59fca --- /dev/null +++ b/collects/setup/setupsig.ss @@ -0,0 +1,20 @@ + +(begin-elaboration-time + (require-library "launchers.ss" "launcher") + (require-library "dynexts.ss" "dynext") + (require-library "functios.ss") + (require-library "files.ss") + (require-library "sig.ss" "compiler")) + +(define-signature setup-option^ + (verbose + make-verbose + compiler-verbose + clean + make-zo + make-so + make-launchers + call-install + pause-on-errors + specific-collections + archives)) diff --git a/collects/slatex/doc.txt b/collects/slatex/doc.txt new file mode 100644 index 00000000..8606177a --- /dev/null +++ b/collects/slatex/doc.txt @@ -0,0 +1,38 @@ +_SLaTeX_ +======== + +The use SLaTeX as a standalone program, either drag your .tex file onto +SLaTeX (on the macintosh or windows), or type "slatex file" at the command +prompt (under windows or X). + +Under the macintosh, SLaTeX will attempt to run OzTeX. If you do not have +OzTeX installed, or use another version of LaTeX, this will fail and you +can run your own version manually. + +To use SLaTeX in a program, require _slatex.ss_: + + (require-library "slatex.ss" "slatex") + +The file slatex.ss defines three procedures: + +> (slatex filename) + +This procedure accepts a string naming a file and runs slatex and latex on +the file. It calls `filename->latex-filename' on `filename'. + +> (slatex/no-latex filename) + +This procedure slatex's the file named by filename, without calling +latex. That is, it only processes the .tex file to produce the .Z files. +It calls filename->latex-filename on `filename'. + +> (latex filename) + +This procedure `latex's the file named by filename. It calls +filename->latex-filename on `filename'. + +> (filename->latex-filename filename) + +This procedure accepts a filename and, if that file exists, it returns +it. If the filename appended with the suffix `.tex' exists, that filename +is returned. Otherwise, error is called. diff --git a/collects/slatex/info.ss b/collects/slatex/info.ss new file mode 100644 index 00000000..dabb83da --- /dev/null +++ b/collects/slatex/info.ss @@ -0,0 +1,23 @@ +(lambda (request fail) + (case request + ((name) "SLaTeX") + ((install-collection) + (lambda (plt-home) + (unless (file-exists? (build-path (collection-path "slatex") "compiled" "slatexsrc.zo")) + (let ([slatex-code-directory (build-path (collection-path "slatex") "slatex-code")] + [compiled-directory (build-path (collection-path "slatex") "compiled")]) + (parameterize ([current-namespace (make-namespace)] + [current-output-port (make-output-port void void)] + [current-directory slatex-code-directory]) + (require-library "slaconfg.scm" "slatex" "slatex-code")) + (unless (directory-exists? compiled-directory) + (make-directory compiled-directory)) + (copy-file (build-path slatex-code-directory "slatex.scm") ; this file is actually a .zo file + (build-path compiled-directory "slatexsrc.zo")))) + (require-library "launcher.ss" "launcher") + (make-mzscheme-launcher + (list "-qge" + "(require-library \"slatex-launcher.scm\" + \"slatex\")") + (mzscheme-program-launcher-path "SLaTeX")))) + (else (fail)))) diff --git a/collects/slatex/slatex-code/2col.tex b/collects/slatex/slatex-code/2col.tex new file mode 100644 index 00000000..b843f07d --- /dev/null +++ b/collects/slatex/slatex-code/2col.tex @@ -0,0 +1,54 @@ +% from the TeXbook, p. 257 + +\newdimen\fullhsize +\fullhsize\hsize + +\def\fullline{\hbox to\fullhsize} + +\ifx\plainmakeheadline\undefined +% ensure that we do this only once! +\let\plainmakeheadline\makeheadline +\let\plainmakefootline\makefootline +\fi + +% the text width spans both columns, as far as +% head- and footlines are concerned + +\def\textwideline{\hbox to\fullhsize} + +\def\makeheadline{{\let\line\textwideline\plainmakeheadline}} +\def\makefootline{{\let\line\textwideline\plainmakefootline}} + +% space between the two columns -- can be changed +% immediately after loading 2col + +\def\gutter#1{\hsize\fullhsize +\advance\hsize-#1 +\hsize.5\hsize +} + +\gutter{1.5pc} + +\let\lr=L + +\newbox\leftcolumn + +\output={\if L\lr +\global\setbox\leftcolumn=\columnbox +\global\let\lr=R\else +\doubleformat +\global\let\lr L\fi +\ifnum\outputpenalty>-20000 \else +\dosupereject\fi} + +\def\doubleformat{\shipout\vbox{\makeheadline +\fullline{\box\leftcolumn\hfil\columnbox}% +\makefootline}\advancepageno} + +\def\columnbox{\leftline{\pagebody}} + +% \bye cleans up. + +\outer\def\bye{\vfill\supereject +\if R\lr\null\vfill\eject\fi +\end} diff --git a/collects/slatex/slatex-code/8pt.tex b/collects/slatex/slatex-code/8pt.tex new file mode 100644 index 00000000..2de4a4f2 --- /dev/null +++ b/collects/slatex/slatex-code/8pt.tex @@ -0,0 +1,49 @@ +\ifdim\the\fontdimen2\tenrm=3.33333pt +% almost definitely using CM fonts +\font\eightrm cmr8 +\font\eighti cmmi8 +\font\eightsy cmsy8 +\font\eightit cmti8 +\font\eightbf cmbx8 +\font\eighttt cmtt8 +\else\ifx\ljmagnification\undefined +\def\fontstem#1{\expandafter\fontstemII\fontname#1 \end}% +\def\fontstemII#1 #2\end{#1 }% +\font\eightrm \fontstem\tenrm at 8pt +\font\eighti cmmi8 +\font\eightsy cmsy8 +\font\eightit \fontstem\tenit at 8pt +\font\eightbf \fontstem\tenbf at 8pt +\font\eighttt \fontstem\tentt at 8pt +\else +\setcountCCLVtoljmag +\font\eighti cmmi8 scaled \count255 +\font\eightsy cmsy8 scaled \count255 +\multiply\count255 by 4 +\divide\count255 by 5 +\font\eightrm \fontstem\tenrm scaled \count255 +\font\eightit \fontstem\tenit scaled \count255 +\font\eightbf \fontstem\tenbf scaled \count255 +\font\eighttt \fontstem\tentt scaled \count255 +\fi\fi + +\skewchar\eighti'177 +\skewchar\eightsy'60 + +\def\eightpoint{% +\textfont0\eightrm +\textfont1\eighti +\textfont2\eightsy +\textfont\itfam\eightit +\textfont\bffam\eightbf +\textfont\ttfam\eighttt +\def\rm{\fam0\eightrm}% +\def\oldstyle{\fam1\eighti}% +\def\it{\fam\itfam\eightit}% +\def\bf{\fam\bffam\eightbf}% +\def\tt{\fam\ttfam\eighttt}% +\rm +\setbox\strutbox\hbox{\vrule height .85em depth .35em width +0pt }% +\normalbaselineskip 1.2em +\normalbaselines} diff --git a/collects/slatex/slatex-code/README b/collects/slatex/slatex-code/README new file mode 100644 index 00000000..2ae6bd88 --- /dev/null +++ b/collects/slatex/slatex-code/README @@ -0,0 +1,114 @@ +README +SLaTeX Version 2.4 +(c) Dorai Sitaram +dorai@cs.rice.edu + +Read me first + + ... + +1. A brief description of SLaTeX + +SLaTeX is a Scheme program that allows you to write program +code (or code fragments) "as is" in your LaTeX or TeX +source. SLaTeX is particularly geared to the programming +languages Scheme (R5RS) and other Lisps, e.g., Common Lisp. +The formatting of the code includes assigning appropriate +fonts to the various tokens in the code (keywords, +variables, constants, data), at the same time retaining the +proper indentation when going to the non-monospace +(non-typewriter) fonts provided by TeX. SLaTeX comes with +two databases that recognize the identifier conventions of +Scheme and CL respectively. + +While it is certainly possible to get by with a minimal +knowledge of SLaTeX commands, the package comes with a +variety of features for manipulating output positioning, +modifying/enhancing the database, changing the fonting +defaults, adding special symbols, and selective disabling of +SLaTeX. For a detailed documentation of SLaTeX, run slatex +on the file slatxdoc.tex in the SLaTeX distribution after +finishing the installation process. + + ... + +2. Obtaining SLaTeX + +SLaTeX is available at the URL +http://www.cs.rice.edu/CS/PLT/packages/slatex/slatex.tar.gz. +Ungzipping and untarring produces a directory slatex, +containing the SLaTeX files. (The file "manifest" lists the +files in the distribution -- make sure nothing is missing.) + + ... + +3. Requisites for installing SLaTeX + +SLaTeX is implemented in R5RS-compliant Scheme -- macros are +not needed. The code uses the non-standard procedures +delete-file, file-exists? and flush-output, but a Scheme +without these procedures can also run SLaTeX. The +configuration defines the corresponding variables to be +dummy procedures, since they are not crucial. The +distribution comes with code to allow SLaTeX to run also on +Common Lisp. The dialects that SLaTeX has run successfully +on are: Bigloo, Chez Scheme, CLISP, Elk, Gnu Common Lisp, +Gambit, Guile, Ibuki Common Lisp, MIT C Scheme, MzScheme, +Scheme-to-C, SCM, UMB Scheme, and VSCM on Unix; MzScheme on +Windows 95; CLISP and SCM on OS/2; Austin Kyoto Common Lisp, +CLISP, MIT C Scheme, and SCM on MSDOS; and Macintosh Common +Lisp on Mac OS. + + ... + +4. Installing SLaTeX + +Refer to the file "install" for configuring SLaTeX to your +dialect and ways of invoking it on your (La)TeX files. + + ... + +5. Using SLaTeX + +The file slatxdoc.tex is a manual describing "How to Use +SLaTeX". A version of the corresponding .dvi file, +slatxdoc.dvi, is included in the distribution, but you could +create your own (and thereby check that SLaTeX works on your +system). Save the provided slatxdoc.dvi file in case your +setup doesn't work, and type + +slatex slatxdoc + +You may create a file slatxdoc.ind that arranges the index +information from the file slatxdoc.idx generated by LaTeX. +Run LaTeX on slatxdoc another time to sort out the index and +the citations. + +If you have run Scheme (or CL) on config.scm (Sec. 1 of +install) but haven't been able to decide how to set up the +paths or the shell/bat script or the most suitable invoking +method (Sec. 2 and 3 of install), perform the following +actions (in the directory where you unpacked the +distribution) to get slatxdoc.dvi: + +1) Start up Scheme (or CL). + +2) Type (load "slatex.scm"). + +3) Type (SLaTeX.process-main-tex-file "slatxdoc"). + +4) Exit Scheme (or CL). + +5) Call latex on slatxdoc.tex. (Use makeindex to generate +slatxdoc.ind, if possible. Call latex a second time to get +the citations right and to generate an index if available.) + + ... + +6. Bugs, etc. + +Bug reports, flames, criticisms and suggestions are +most welcome -- send to + +Dorai Sitaram +dorai@cs.rice.edu diff --git a/collects/slatex/slatex-code/aliases.scm b/collects/slatex/slatex-code/aliases.scm new file mode 100644 index 00000000..550f62e2 --- /dev/null +++ b/collects/slatex/slatex-code/aliases.scm @@ -0,0 +1,125 @@ +(make-slatex-alias + '( + global-adjoin adjoin + global-assoc assoc + global-delete delete + global-error error + global-make-string make-string + global-member member + global-peek-char peek-char + global-read read + global-read-char read-char + global-string string + )) + +(case dialect + ((bigloo) 'skip + ) + ((chez) + (make-slatex-alias + '( + force-output flush-output + some ormap + ))) + ((cl) + (make-slatex-alias + `( + adjoin slatex::%adjoin + append! nconc + assoc slatex::%assoc + begin progn + char? characterp + char=? char= + char-alphabetic? alpha-char-p + delete slatex::%delete + display princ + else t + eq? eq + equal? equal + eqv? eql + file-exists? probe-file + fluid-let let + for-each mapc + integer->char code-char + lambda slatex::%lambda + let slatex::%let + list-tail subseq + make-string slatex::%make-string + map mapcar + member slatex::%member + memq member + memv member + newline terpri + null? null + pair? consp + peek-char slatex::%peek-char + position-char position + read slatex::%read + read-char slatex::%read-char + *return* ,(read-from-string "#\\return") + reverse! nreverse + set! setq + set-car! rplaca + set-cdr! rplacd + string slatex::%string + string=? string= + string-ci=? string-equal + string-length length + string-ref char + sublist subseq + substring subseq + *tab* ,(read-from-string "#\\tab") + void values + ))) + ((cscheme) + (make-slatex-alias + `( + mapcan append-map! + *return* ,(with-input-from-string "#\\return" read) + *tab* ,(with-input-from-string "#\\tab" read) + ))) + ((elk) + (make-slatex-alias + '( + force-output flush-output-port + ))) + ((gambit) + (make-slatex-alias + '( + force-output flush-output + ))) + ((guile) + (make-slatex-alias + `( + *return* ,(call-with-input-string "#\\return" read) + *tab* ,(call-with-input-string "#\\tab" read) + ))) + ((mzscheme) + (make-slatex-alias + `( + force-output flush-output + some ormap + *return* ,(let ((i (open-input-string "#\\return"))) + (begin0 (read i) (close-input-port i))) + *tab* ,(let ((i (open-input-string "#\\tab"))) + (begin0 (read i) (close-input-port i))) + ))) + ((pcsge) 'skip + ) + ((scm) + (make-slatex-alias + `( + *return* ,(call-with-input-string "#\\return" read) + *tab* ,(call-with-input-string "#\\tab" read) + ))) + ((stk) + (make-slatex-alias + `( + force-output flush + ))) + ((vscm) + (make-slatex-alias + '( + delete-file remove-file + force-output flush + )))) diff --git a/collects/slatex/slatex-code/batconfg.lsp b/collects/slatex/slatex-code/batconfg.lsp new file mode 100644 index 00000000..ada53d7d --- /dev/null +++ b/collects/slatex/slatex-code/batconfg.lsp @@ -0,0 +1,197 @@ +;batconfg.lsp +;Configures SLaTeX batfile/shellscript (CL version) +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +#+gcl +(or (find-package :slatex) (make-package :slatex)) + +#-gcl +(defpackage slatex (:use cl)) + +(set-dispatch-macro-character #\# #\t + #'(lambda (p ig ig2) + (declare (ignore ig ig2)) + t)) + +(set-dispatch-macro-character #\# #\f + #'(lambda (p ig ig2) + (declare (ignore ig ig2)) + nil)) + +(format t "~&Beginning configuring command script -- wait...") + +(defvar *slatex-directory* (directory-namestring *load-pathname*)) + +(defvar *op-sys*) +(defvar cl-pathname) +(defvar slatex-pathname) +(defvar texinputs) +(defvar texinputs-list) +(defvar accepts-echo) +(defvar accepts-cmdline-file) +(defvar accepts-initfile) +(defvar system-procedure nil) + +#+clisp +(setf system-procedure 'run-shell-command) + +(with-open-file (inp (concatenate 'string *slatex-directory* + "config.dat") + :direction :input) + (read inp) ;we already know dialect + (setf *op-sys* (read inp) + cl-pathname (read inp) + slatex-pathname (read inp) + texinputs (read inp) + texinputs-list (read inp) + accepts-echo (read inp) + accepts-cmdline-file (read inp) + accepts-initfile (read inp)) ) + +(defvar bat-file) +(setf bat-file + (concatenate 'string *slatex-directory* + (case *op-sys* + ((os2 os2fat) "slatex.cmd") + ((windows dos) "slatex.bat") + (unix "slatex")))) + +(unless (eq *op-sys* 'mac-os) + (if (probe-file bat-file) (delete-file bat-file))) + +(defun princn (x o) + (princ x o) + (terpri o)) + +(defun n (o) + (terpri o)) + +(with-open-file + (o bat-file :direction :output) + (case *op-sys* + ((unix) + (cond (accepts-echo + (princn "echo '" o) + (princ "(load " o) + (prin1 slatex-pathname o) + (princn ")" o) + (princ "(setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princn ")" o) + (princ "(setq slatex::*texinputs-list* `" o) + (prin1 texinputs-list o) + (princn ")" o) + (princ "(slatex::process-main-tex-file \"'$1'\")' | " o) + (princn cl-pathname o)) + (accepts-cmdline-file + (princ "echo '(load " o) + (prin1 slatex-pathname o) + (princn ")' > Zslatex.jnk" o) + (princ "echo '(setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princn ")' >> Zslatex.jnk" o) + (princ "echo '(setq slatex::*texinputs-list* `" o) + (prin1 texinputs-list o) + (princn ")' >> Zslatex.jnk" o) + (princn "echo '(slatex::process-main-tex-file \"'$1'\")' >> Zslatex.jnk" o) + (princn "echo '(slatex::exit-scheme)' >> Zslatex.jnk" o) + (princ cl-pathname o) + (princ " " o) + (princ accepts-cmdline-file o) + (princn " Zslatex.jnk" o) + (princn "rm -f Zslatex.jnk" o)) + (accepts-initfile + (princ "echo '(load " o) + (prin1 slatex-pathname o) + (princ ")' > " o) + (princn accepts-initfile o) + (princ "echo '(setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princ ")' >> " o) + (princn accepts-initfile o) + (princ "echo '(setq slatex::*texinputs-list* (quote " o) + (prin1 texinputs-list o) + (princ ")' >> " o) + (princn accepts-initfile o) + (princ "echo '(slatex::process-main-tex-file \"'$1'\")' >> " o) + (princn accepts-initfile o) + (princn cl-pathname o) + (princ "rm -f " o) + (princn accepts-initfile o))) + (princn "if test -f pltexchk.jnk" o) + (princn "then tex $1; rm pltexchk.jnk" o) + (princn "else latex $1" o) + (princn "fi" o)) + ((windows dos os2fat os2) + (princn "@echo off" o) + (cond (accepts-echo + (princ "echo (load " o) + (prin1 slatex-pathname o) + (princn ") > Zslatex.jnk" o) + (princ "echo (setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princn ") >> Zslatex.jnk" o) + (princ "echo (setq slatex::*texinputs-list* '" o) + (prin1 texinputs-list o) + (princn ") >> Zslatex.jnk" o) + (princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o) + (princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o) + (princ "echo (load \"Zslatex.jnk\") | " o) + (princn cl-pathname o) + (princn "del Zslatex.jnk" o)) + (accepts-cmdline-file + (princ "echo (load " o) + (prin1 slatex-pathname o) + (princn ") > Zslatex.jnk" o) + (princ "echo (setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princn ") >> Zslatex.jnk" o) + (princ "echo (setq slatex::*texinputs-list* '" o) + (prin1 texinputs-list o) + (princn ") >> Zslatex.jnk" o) + (princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o) + (princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o) + (princ cl-pathname o) + (princ " " o) + (princ accepts-cmdline-file o) + (princn " Zslatex.jnk" o) + (princn "del Zslatex.jnk" o)) + (accepts-initfile + (princ "echo (load " o) + (prin1 slatex-pathname o) + (princ ") > " o) + (princn accepts-initfile o) + (princ "echo (setq slatex::*texinputs* " o) + (prin1 texinputs o) + (princ ") >> " o) + (princn accepts-initfile o) + (princ "echo (setq slatex::*texinputs-list* '" o) + (prin1 texinputs-list o) + (princ ") >> " o) + (princn accepts-initfile o) + (princ "echo (slatex::process-main-tex-file \"%1\") >> " o) + (princn accepts-initfile o) + (princ "echo (slatex::exit-scheme) >> " o) + (princn accepts-initfile o) + (princn cl-pathname o) + (princ "del " o) + (princn accepts-initfile o))) + (princn "if exist pltexchk.jnk goto one" o) + (princn "goto two" o) + (princn ":one" o) + (princn "call tex %1" o) + (princn "del pltexchk.jnk" o) + (princn "goto end" o) + (princn ":two" o) + (princn "call latex %1" o) + (princn ":end" o)))) + +(format t "~&Finished configuring command script.~%") + +(when (eq *op-sys* 'unix) + #+(or allegro clisp) + (run-shell-command "chmod +x slatex") + #+gcl + (system "chmod +x slatex") + #-(or gcl clisp) + (format t "~&Type (chmod +x slatex) on Unix command line~%")) diff --git a/collects/slatex/slatex-code/batconfg.scm b/collects/slatex/slatex-code/batconfg.scm new file mode 100644 index 00000000..30992722 --- /dev/null +++ b/collects/slatex/slatex-code/batconfg.scm @@ -0,0 +1,206 @@ +;batconfg.scm;-*-scheme-*- +;Configures SLaTeX batfile/shellscript (Scheme version) +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(display "Beginning configuring command script -- wait...") +(newline) + +(define dialect 'forward) +(define *op-sys* 'forward) +(define scheme-pathname 'forward) +(define slatex-pathname 'forward) +(define texinputs 'forward) +(define texinputs-list 'forward) +(define accepts-echo 'forward) +(define accepts-cmdline-file 'forward) +(define accepts-initfile 'forward) +(define system-procedure #f) + +(call-with-input-file "config.dat" + (lambda (ip) + (set! dialect (read ip)) + (set! *op-sys* (read ip)) + (set! scheme-pathname (read ip)) + (set! slatex-pathname (read ip)) + (set! texinputs (read ip)) + (set! texinputs-list (read ip)) + (set! accepts-echo (read ip)) + (set! accepts-cmdline-file (read ip)) + (set! accepts-initfile (read ip)) + (cond ((or (eof-object? dialect) + (eof-object? *op-sys*) + (eof-object? scheme-pathname) + (eof-object? slatex-pathname) + (eof-object? texinputs) + (eof-object? texinputs-list) + (eof-object? accepts-echo) + (eof-object? accepts-cmdline-file) + (eof-object? accepts-initfile)) + (error "config.dat has too few answers")) + ((eof-object? (read ip)) #t) + (else (error "config.dat has too many answers"))))) + +(case dialect + ((bigloo chez cscheme guile mzscheme scm stk) + (set! system-procedure 'system))) + +(define bat-file 'forward) + +(case *op-sys* + ((os2 os2bat) + (set! bat-file "slatex.cmd")) + ((windows dos) + (set! bat-file "slatex.bat")) + ((unix) + (set! bat-file "slatex"))) + +;(if (memq *op-sys* '(unix windows dos os2fat os2)) ;why here? + +(if (memq dialect '(bigloo chez cscheme guile mzscheme pcsge scm)) + (if (file-exists? bat-file) + (delete-file bat-file))) + +(define modified-newline newline) + +(cond ((and (eq? dialect 'mzscheme) + (memq *op-sys* '(windows dos))) + (set! modified-newline + (let ((cr (integer->char 13)) + (lf (integer->char 10))) + (lambda (o) + (display cr o) + (display lf o)))))) + +(define princn + (lambda (x o) + (display x o) + (modified-newline o))) + +(call-with-output-file bat-file + (lambda (o) + (case *op-sys* + ((unix) + (cond (accepts-echo + (princn "echo '" o) + (display "(load " o) + (write slatex-pathname o) + (princn ")" o) + (display "(set! slatex::*texinputs* " o) + (write texinputs o) + (princn ")" o) + (display "(set! slatex::*texinputs-list* `" o) + (write texinputs-list o) + (princn ")" o) + (display "(slatex::process-main-tex-file \"'$1'\")' | " o) + (princn scheme-pathname o)) + (accepts-cmdline-file + (display "echo '(load " o) + (write slatex-pathname o) + (princn ")' > Zslatex.jnk" o) + (display "echo '(set! slatex::*texinputs* " o) + (write texinputs o) + (princn ")' >> Zslatex.jnk" o) + (display "echo '(set! slatex::*texinputs-list* `" o) + (write texinputs-list o) + (princn ")' >> Zslatex.jnk" o) + (princn "echo '(slatex::process-main-tex-file \"'$1'\")' >> Zslatex.jnk" o) + (princn "echo '(slatex::exit-scheme)' >> Zslatex.jnk" o) + (display scheme-pathname o) + (display " " o) + (display accepts-cmdline-file o) + (princn " Zslatex.jnk" o) + (princn "rm -f Zslatex.jnk" o)) + (accepts-initfile + (display "echo '(load " o) + (write slatex-pathname o) + (display ")' > " o) + (princn accepts-initfile o) + (display "echo '(set! slatex::*texinputs* " o) + (write texinputs o) + (display ")' >> " o) + (princn accepts-initfile o) + (display "echo '(set! slatex::*texinputs-list* (quote " o) + (write texinputs-list o) + (display ")' >> " o) + (princn accepts-initfile o) + (display "echo '(slatex::process-main-tex-file \"'$1'\")' >> " o) + (princn accepts-initfile o) + (princn scheme-pathname o) + (display "rm -f " o) + (princn accepts-initfile o))) + (princn "if test -f pltexchk.jnk" o) + (princn "then tex $1; rm pltexchk.jnk" o) + (princn "else latex $1" o) + (princn "fi" o)) + ((windows dos os2fat os2) + (princn "@echo off" o) + (cond (accepts-echo + (display "echo (load " o) + (write slatex-pathname o) + (princn ") > Zslatex.jnk" o) + (display "echo (set! slatex::*texinputs* " o) + (write texinputs o) + (princn ") >> Zslatex.jnk" o) + (display "echo (set! slatex::*texinputs-list* '" o) + (write texinputs-list o) + (princn ") >> Zslatex.jnk" o) + (princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o) + (princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o) + (display "echo (load \"Zslatex.jnk\") | " o) + (princn scheme-pathname o) + (princn "del Zslatex.jnk" o)) + (accepts-cmdline-file + (display "echo (load " o) + (write slatex-pathname o) + (princn ") > Zslatex.jnk" o) + (display "echo (set! slatex::*texinputs* " o) + (write texinputs o) + (princn ") >> Zslatex.jnk" o) + (display "echo (set! slatex::*texinputs-list* '" o) + (write texinputs-list o) + (princn ") >> Zslatex.jnk" o) + (princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o) + (princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o) + (display scheme-pathname o) + (display " " o) + (display accepts-cmdline-file o) + (display " Zslatex.jnk" o) + (princn "del Zslatex.jnk" o)) + (accepts-initfile + (display "echo (load " o) + (write slatex-pathname o) + (display ") > " o) + (princn accepts-initfile o) + (display "echo (set! slatex::*texinputs* " o) + (write texinputs o) + (display ") >> " o) + (princn accepts-initfile o) + (display "echo (set! slatex::*texinputs-list* '" o) + (write texinputs-list o) + (display ") >> " o) + (princn accepts-initfile o) + (display "echo (slatex::process-main-tex-file \"%1\") >> " o) + (princn accepts-initfile o) + (display "echo (slatex::exit-scheme) >> " o) + (princn accepts-initfile o) + (princn scheme-pathname o) + (display "del " o) + (princn accepts-initfile o))) + (princn "if exist pltexchk.jnk goto one" o) + (princn "goto two" o) + (princn ":one" o) + (princn "call tex %1" o) + (princn "del pltexchk.jnk" o) + (princn "goto end" o) + (princn ":two" o) + (princn "call latex %1" o) + (princn ":end" o))))) + +(display "Finished configuring batfile/shellscript") +(newline) +(if (eq? *op-sys* 'unix) + (case system-procedure + ((system) (system "chmod +x slatex")) + (else + (display "Type (chmod +x slatex) on Unix command line") + (newline)))) diff --git a/collects/slatex/slatex-code/cfg4lsp.lsp b/collects/slatex/slatex-code/cfg4lsp.lsp new file mode 100644 index 00000000..e2228f5b --- /dev/null +++ b/collects/slatex/slatex-code/cfg4lsp.lsp @@ -0,0 +1,7 @@ +(load "slaconfg.lsp") +(load "batconfg.lsp") + +(cond ((fboundp 'bye) (bye)) + ((fboundp 'exit) (exit)) + ((fboundp 'quit) (quit)) + (t (format t "~&You may exit CL now!~%"))) diff --git a/collects/slatex/slatex-code/cfg4scm.scm b/collects/slatex/slatex-code/cfg4scm.scm new file mode 100644 index 00000000..b6885005 --- /dev/null +++ b/collects/slatex/slatex-code/cfg4scm.scm @@ -0,0 +1,10 @@ +(load "slaconfg.scm") +(load "batconfg.scm") + +(case dialect + ((scm) (quit)) + ((cscheme) (%exit)) + ((bigloo) (exit 0)) + (else (exit) + (display "You may exit Scheme now!") + (newline))) \ No newline at end of file diff --git a/collects/slatex/slatex-code/cltl.sty b/collects/slatex/slatex-code/cltl.sty new file mode 100644 index 00000000..745d830c --- /dev/null +++ b/collects/slatex/slatex-code/cltl.sty @@ -0,0 +1,57 @@ +%cltl.sty +%SLaTeX Version 1.99 +%Style file to be used in (La)TeX when using SLaTeX for Common Lisp +%(c) Dorai Sitaram, December 1991, Rice University + +\input slatex.sty + +% The database in this file was generated from CL as follows: + +% (defun canonical-special-form-p (x) +% (and (special-form-p x) (not (macro-function x)))) + +% (defun gather (pred) +% (sort (let ((x '())) +% (do-all-symbols (y) +% (if (funcall pred y) (setq x (cons y x)))) +% x) +% #'string< :key #'symbol-name)) + +% A rather old (1987) version of Ibuki CL was used. So you may want +% to regenerate the keywords using the above functions in _your_ CL. + +% CL sp. forms, i.e., (gather #'canonical-special-form-p) + +\setkeyword{block catch compiler-let declare eval-when flet function +go if labels let let* macrolet multiple-value-call +multiple-value-prog1 progn progv quote return-from setq tagbody the +throw unwind-protect} + +% CL macros, i.e., (gather #'macro-function) + +\setkeyword{and assert compiler::base-used case ccase check-type +compiler::ck-spec compiler::ck-vl clines compiler::cmpck +system::coerce-to-package conditions::conc-name cond ctypecase decf +debugger::def-command defcfun defconstant defentry +system:define-compiler-macro conditions:define-condition +system:define-inline-function define-modify-macro define-setf-method +define-user-stream-type defla defmacro defparameter defsetf defstruct +deftype defun debugger::defun-property defvar do do* do-all-symbols +do-external-symbols do-symbols system::docdoc system::docfun +system::doctype system::docvar dolist compiler::dolist* +compiler::dolist** dotimes compiler::dotimes* compiler::dotimes** +ecase etypecase compiler::get-output-pathname conditions:handler-bind +conditions:handler-case system::if-error conditions:ignore-errors incf +system::inspect-print system::inspect-recursively locally loop +conditions::make-function multiple-value-bind multiple-value-list +multiple-value-setq compiler::next-cfun compiler::next-cmacro +compiler::next-cvar compiler::next-label compiler::next-label* or +conditions::parent-type pop prog prog* prog1 prog2 psetf psetq push +pushnew remf conditions::report-function conditions::resolve-function +conditions:restart-bind conditions:restart-case return rotatef +compiler::safe-compile setf shiftf conditions::slots step time trace +typecase unless untrace when debugger::with-debugger-environment +with-input-from-string conditions::with-keyword-pairs with-open-file +with-open-stream with-output-to-string conditions:with-simple-restart +compiler::wt compiler::wt-go compiler::wt-h compiler::wt-label +compiler::wt-nl compiler::wt-nl1} diff --git a/collects/slatex/slatex-code/codeset.scm b/collects/slatex/slatex-code/codeset.scm new file mode 100644 index 00000000..56a81074 --- /dev/null +++ b/collects/slatex/slatex-code/codeset.scm @@ -0,0 +1,259 @@ +;codeset.scm +;SLaTeX Version 2.4 +;Displays the typeset code made by SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1999 + +(eval-within slatex + + (define slatex::display-tex-line + (lambda (line) + (cond;((and (flush-comment-line? line) + ; (char=? (of line =char / 1) #\%)) + ; (display "\\ZZZZschemecodebreak" *out*) + ; (newline *out*)) + (else + (let loop ((i (if (flush-comment-line? line) 1 0))) + (let ((c (of line =char / i))) + (if (char=? c #\newline) + (if (not (eq? (of line =tab / i) &void-tab)) + (newline *out*)) + (begin (write-char c *out*) (loop (+ i 1)))))))))) + + (define slatex::display-scm-line + (lambda (line) + (let loop ((i 0)) + (let ((c (of line =char / i))) + (cond ((char=? c #\newline) + (let ((tab (of line =tab / i))) + (cond ((eq? tab &tabbed-crg-ret) + (display "\\\\%" *out*) + (newline *out*)) + ((eq? tab &plain-crg-ret) (newline *out*)) + ((eq? tab &void-tab) + (write-char #\% *out*) + (newline *out*))))) + ((eq? (of line =notab / i) &begin-comment) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (loop (+ i 1))) + ((eq? (of line =notab / i) &mid-comment) + (write-char c *out*) + (loop (+ i 1))) + ((eq? (of line =notab / i) &begin-string) + (display-tab (of line =tab / i) *out*) + (display "\\dt{" *out*) + (if (char=? c #\space) + (display-space (of line =space / i) *out*) + (display-tex-char c *out*)) + (loop (+ i 1))) + ((eq? (of line =notab / i) &mid-string) + (if (char=? c #\space) + (display-space (of line =space / i) *out*) + (display-tex-char c *out*)) + (loop (+ i 1))) + ((eq? (of line =notab / i) &end-string) + (if (char=? c #\space) + (display-space (of line =space / i) *out*) + (display-tex-char c *out*)) + (write-char #\} *out*) + (if *in-qtd-tkn* (set! *in-qtd-tkn* #f) + (if *in-mac-tkn* (set! *in-mac-tkn* #f))) + (loop (+ i 1))) + ((eq? (of line =notab / i) &begin-math) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (loop (+ i 1))) + ((eq? (of line =notab / i) &mid-math) + (write-char c *out*) + (loop (+ i 1))) + ((eq? (of line =notab / i) &end-math) + (write-char c *out*) + (if *in-qtd-tkn* (set! *in-qtd-tkn* #f) + (if *in-mac-tkn* (set! *in-mac-tkn* #f))) + (loop (+ i 1))) + ; ((memq (of line =notab / i) (list &mid-math &end-math)) + ; (write-char c *out*) + ; (loop (+ i 1))) + ((char=? c #\space) + (display-tab (of line =tab / i) *out*) + (display-space (of line =space / i) *out*) + (loop (+ i 1))) + ((char=? c #\') + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (if (or *in-qtd-tkn* + (> *in-bktd-qtd-exp* 0) + (and (pair? *bq-stack*) + (not (of (car *bq-stack*) =in-comma)))) + #f + (set! *in-qtd-tkn* #t)) + (loop (+ i 1))) + ((char=? c #\`) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (if (or (null? *bq-stack*) + (of (car *bq-stack*) =in-comma)) + (set! *bq-stack* + (cons (let ((f (make-bq-frame))) + (setf (of f =in-comma) #f) + (setf (of f =in-bq-tkn) #t) + (setf (of f =in-bktd-bq-exp) 0) + f) + *bq-stack*))) + (loop (+ i 1))) + ((char=? c #\,) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (if (not (or (null? *bq-stack*) + (of (car *bq-stack*) =in-comma))) + (set! *bq-stack* + (cons (let ((f (make-bq-frame))) + (setf (of f =in-comma) #t) + (setf (of f =in-bq-tkn) #t) + (setf (of f =in-bktd-bq-exp) 0) + f) + *bq-stack*))) + (if (char=? (of line =char / (+ i 1)) #\@) + (begin (display-tex-char #\@ *out*) (loop (+ 2 i))) + (loop (+ i 1)))) + ((memv c '(#\( #\[)) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f) + (set! *in-bktd-qtd-exp* 1)) + ((> *in-bktd-qtd-exp* 0) + (set! *in-bktd-qtd-exp* (+ *in-bktd-qtd-exp* 1)))) + (cond (*in-mac-tkn* (set! *in-mac-tkn* #f) + (set! *in-bktd-mac-exp* 1)) + ((> *in-bktd-mac-exp* 0) ;is this possible? + (set! *in-bktd-mac-exp* (+ *in-bktd-mac-exp* 1)))) + (if (not (null? *bq-stack*)) + (let ((top (car *bq-stack*))) + (cond ((of top =in-bq-tkn) + (setf (of top =in-bq-tkn) #f) + (setf (of top =in-bktd-bq-exp) 1)) + ((> (of top =in-bktd-bq-exp) 0) + (setf (of top =in-bktd-bq-exp) + (+ (of top =in-bktd-bq-exp) 1)))))) + (if (not (null? *case-stack*)) + (let ((top (car *case-stack*))) + (cond ((of top =in-ctag-tkn) + (setf (of top =in-ctag-tkn) #f) + (setf (of top =in-bktd-ctag-exp) 1)) + ((> (of top =in-bktd-ctag-exp) 0) + (setf (of top =in-bktd-ctag-exp) + (+ (of top =in-bktd-ctag-exp) 1))) + ((> (of top =in-case-exp) 0) + (setf (of top =in-case-exp) + (+ (of top =in-case-exp) 1)) + (if (= (of top =in-case-exp) 2) + (set! *in-qtd-tkn* #t)))))) + (loop (+ i 1))) + ((memv c '(#\) #\])) + (display-tab (of line =tab / i) *out*) + (write-char c *out*) + (if (> *in-bktd-qtd-exp* 0) + (set! *in-bktd-qtd-exp* (- *in-bktd-qtd-exp* 1))) + (if (> *in-bktd-mac-exp* 0) + (set! *in-bktd-mac-exp* (- *in-bktd-mac-exp* 1))) + (if (not (null? *bq-stack*)) + (let ((top (car *bq-stack*))) + (if (> (of top =in-bktd-bq-exp) 0) + (begin + (setf (of top =in-bktd-bq-exp) + (- (of top =in-bktd-bq-exp) 1)) + (if (= (of top =in-bktd-bq-exp) 0) + (set! *bq-stack* (cdr *bq-stack*))))))) + (let loop () + (if (not (null? *case-stack*)) + (let ((top (car *case-stack*))) + (cond ((> (of top =in-bktd-ctag-exp) 0) + (setf (of top =in-bktd-ctag-exp) + (- (of top =in-bktd-ctag-exp) 1)) + (if (= (of top =in-bktd-ctag-exp) 0) + (setf (of top =in-case-exp) 1))) + ((> (of top =in-case-exp) 0) + (setf (of top =in-case-exp) + (- (of top =in-case-exp) 1)) + (if (= (of top =in-case-exp) 0) + (begin + (set! *case-stack* (cdr *case-stack*)) + (loop)))))))) + (loop (+ i 1))) + (else (display-tab (of line =tab / i) *out*) + (loop (slatex::do-token line i)))))))) + + (define slatex::do-token + (let ((token-delims (list #\( #\) #\[ #\] #\space *return* + #\" #\' #\` + #\newline #\, #\;))) + (lambda (line i) + (let loop ((buf '()) (i i)) + (let ((c (of line =char / i))) + (cond ((char=? c #\\ ) + (loop (cons (of line =char / (+ i 1)) (cons c buf)) + (+ i 2))) + ((or (memv c token-delims) + (memv c *math-triggerers*)) + (slatex::output-token (list->string (reverse! buf))) + i) + ((char? c) (loop (cons (of line =char / i) buf) (+ i 1))) + (else (error "do-token: token contains non-char ~s?" + c)))))))) + + (define slatex::output-token + (lambda (token) + (if (not (null? *case-stack*)) + (let ((top (car *case-stack*))) + (if (of top =in-ctag-tkn) + (begin + (setf (of top =in-ctag-tkn) #f) + (setf (of top =in-case-exp) 1))))) + (if (lassoc token special-symbols (function token=?)) + (begin + (if *in-qtd-tkn* (set! *in-qtd-tkn* #f) + (if *in-mac-tkn* (set! *in-mac-tkn* #f))) + (display (cdr (lassoc token special-symbols (function token=?))) + *out*)) + (display-token + token + (cond (*in-qtd-tkn* + (set! *in-qtd-tkn* #f) + (cond ((equal? token "else") 'syntax) + ((lmember token data-tokens (function token=?)) 'data) + ((lmember token constant-tokens (function token=?)) + 'constant) + ((lmember token variable-tokens (function token=?)) + 'constant) + ((lmember token keyword-tokens (function token=?)) + 'constant) + ((prim-data-token? token) 'data) + (else 'constant))) + ((> *in-bktd-qtd-exp* 0) 'constant) + ((and (not (null? *bq-stack*)) + (not (of (car *bq-stack*) =in-comma))) 'constant) + (*in-mac-tkn* (set! *in-mac-tkn* #f) + (set-keyword token) 'syntax) + ((> *in-bktd-mac-exp* 0) (set-keyword token) 'syntax) + ((lmember token data-tokens (function token=?)) 'data) + ((lmember token constant-tokens (function token=?)) 'constant) + ((lmember token variable-tokens (function token=?)) 'variable) + ((lmember token keyword-tokens (function token=?)) + (cond ((token=? token "quote") (set! *in-qtd-tkn* #t)) + ((lmember token macro-definers (function token=?)) + (set! *in-mac-tkn* #t)) + ((lmember token case-and-ilk (function token=?)) + (set! *case-stack* + (cons (let ((f (make-case-frame))) + (setf (of f =in-ctag-tkn) #t) + (setf (of f =in-bktd-ctag-exp) 0) + (setf (of f =in-case-exp) 0) + f) + *case-stack*)))) + 'syntax) + ((prim-data-token? token) 'data) + (else 'variable)) + *out*)) + (if (and (not (null? *bq-stack*)) (of (car *bq-stack*) =in-bq-tkn)) + (set! *bq-stack* (cdr *bq-stack*))))) + ) diff --git a/collects/slatex/slatex-code/config.dat b/collects/slatex/slatex-code/config.dat new file mode 100644 index 00000000..63697a3f --- /dev/null +++ b/collects/slatex/slatex-code/config.dat @@ -0,0 +1,12 @@ +;mzschemeunix.cfg +;sample config.dat for MzScheme on Unix + +mzscheme +unix +"mzscheme" +"/home/dorai/tex/slatex/slatex.scm" +"/home/dorai/tex/0tex" +() +#t +"-f" +#f diff --git a/collects/slatex/slatex-code/config.scm b/collects/slatex/slatex-code/config.scm new file mode 100644 index 00000000..01863cca --- /dev/null +++ b/collects/slatex/slatex-code/config.scm @@ -0,0 +1,7 @@ +;config.scm +;Configures SLaTeX for your system +;(c) Dorai Sitaram, 1991-8 + +; 'nil is a symbol in Scheme, but nil in CL + +(load (if 'nil "cfg4scm.scm" "cfg4lsp.lsp")) diff --git a/collects/slatex/slatex-code/copying b/collects/slatex/slatex-code/copying new file mode 100644 index 00000000..43785311 --- /dev/null +++ b/collects/slatex/slatex-code/copying @@ -0,0 +1,25 @@ +copying +SLaTeX Version 2.4 +Dorai Sitaram, 1991, 1998 +ds26@gte.com + +SLaTeX is provided free of charge. + +You are free to use, copy and distribute verbatim +copies of SLaTeX provided this License Agreement is +included, provided you don't change the authorship +notice that heralds each file, and provided you give +the recipient(s) the same permissions that this +agreement allows you. + +You are free to use, modify and distribute modified +copies of SLaTeX provided you follow the conditions +described above, with the further condition that you +prominently state the changes you made. + +Neither Rice University, nor GTE Labs Inc., nor Dorai +Sitaram assume any responsibility for any damages arising +out of using SLaTeX. + +Dorai Sitaram +ds26@gte.com diff --git a/collects/slatex/slatex-code/defaults.scm b/collects/slatex/slatex-code/defaults.scm new file mode 100644 index 00000000..21176dd7 --- /dev/null +++ b/collects/slatex/slatex-code/defaults.scm @@ -0,0 +1,139 @@ +;defaults.scm +;SLaTeX v. 2.3 +;Default database for SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-if (cl) + (eval-within slatex + (defvar slatex::*slatex-case-sensitive?* #f))) + +(eval-unless (cl) + (eval-within slatex + (defvar slatex::*slatex-case-sensitive?* #t))) + +(eval-within slatex + + (defvar slatex::keyword-tokens + '( + ;RnRS (plus some additional Scheme) keywords + "=>" + "%" + "abort" + "and" + "begin" + "begin0" + "case" + "case-lambda" + "cond" + "define" + "define!" + "define-macro!" + "define-syntax" + "defmacro" + "defrec!" + "delay" + "do" + "else" + "extend-syntax" + "fluid-let" + "if" + "lambda" + "let" + "let*" + "letrec" + "let-syntax" + "letrec-syntax" + "or" + "quasiquote" + "quote" + "rec" + "record-case" + "record-evcase" + "recur" + "set!" + "sigma" + "struct" + "syntax" + "syntax-rules" + "trace" + "trace-lambda" + "trace-let" + "trace-recur" + "unless" + "unquote" + "unquote-splicing" + "untrace" + "when" + "with" + )) + + (defvar slatex::variable-tokens '()) + + (defvar slatex::constant-tokens '()) + + (defvar slatex::data-tokens '()) + + (defvar slatex::special-symbols + '( + ("." . ".") + ("..." . "{\\dots}") + ("-" . "$-$") + ("1-" . "\\va{1$-$}") + ("-1+" . "\\va{$-$1$+$}") + )) + + (defvar slatex::macro-definers + '("define-syntax" "syntax-rules" "defmacro" + "extend-syntax" "define-macro!")) + + (defvar slatex::case-and-ilk + '("case" "record-case")) + + (define slatex::tex-analog + (lambda (c) + ;find a TeX string that corresponds to the character c + (case c + ((#\$ #\& #\% #\# #\_) (string #\\ c)) + ;((#\#) "{\\sf\\#}") + ;((#\\) "{\\ttbackslash}") + ((#\{ #\}) (string #\$ #\\ c #\$)) + ((#\\) "$\\backslash$") + ((#\+) "$+$") + ((#\*) "$\\ast$") + ((#\=) "$=$") + ((#\<) "$\\lt$") + ((#\>) "$\\gt$") + ((#\^) "\\^{}") + ((#\|) "$\\vert$") + ;((#\~) "\\verb-~-") + ((#\~) "\\~{}") + ((#\@) "{\\atsign}") + ((#\") "{\\tt\\dq}") + (else (string c))))) + + (define slatex::token=? + (lambda (t1 t2) + ;tests if t1 and t2 are identical tokens + (funcall (if *slatex-case-sensitive?* (function string=?) + (function string-ci=?)) + t1 t2))) + + (defvar slatex::*slatex-enabled?* #t) + (defvar slatex::*slatex-reenabler* "UNDEFINED") + (defvar slatex::*intext-triggerers* (list "scheme")) + (defvar slatex::*resultintext-triggerers* (list "schemeresult")) + (defvar slatex::*display-triggerers* (list "schemedisplay")) + (defvar slatex::*response-triggerers* (list "schemeresponse")) + (defvar slatex::*respbox-triggerers* (list "schemeresponsebox")) + (defvar slatex::*box-triggerers* (list "schemebox")) + (defvar slatex::*top-box-triggerers* (list "schemetopbox")) + (defvar slatex::*input-triggerers* (list "schemeinput")) + (defvar slatex::*region-triggerers* (list "schemeregion")) + (defvar slatex::*math-triggerers* '()) + (defvar slatex::*slatex-in-protected-region?* #f) + (defvar slatex::*protected-files* '()) + (defvar slatex::*include-onlys* 'all) + (defvar slatex::*latex?* #t) + (defvar slatex::*slatex-separate-includes?* #f) + (defvar slatex::*tex-calling-directory* "") + ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/defun.tex b/collects/slatex/slatex-code/defun.tex new file mode 100644 index 00000000..6eb02b40 --- /dev/null +++ b/collects/slatex/slatex-code/defun.tex @@ -0,0 +1,24 @@ +\def\defun#1{\def\defuntype{#1}% +\medbreak +\line\bgroup + \hbox\bgroup + \aftergroup\enddefun + \vrule width .5ex \thinspace + \vrule \enspace + \vbox\bgroup\setbox0=\hbox{\defuntype}% + \advance\hsize-\wd0 + \advance\hsize-1em + \obeylines + \parindent=0pt + \aftergroup\egroup + \strut + \let\dummy=} + +\def\enddefun{\hfil\defuntype\egroup\smallskip} + + +%\def\defprocedure{\defun{procedure}} + +%\def\defessentialprocedure{\defun{\hbox{% +% \vbox{\hbox{essential}\hbox{procedure}}}}} + diff --git a/collects/slatex/slatex-code/fileproc.scm b/collects/slatex/slatex-code/fileproc.scm new file mode 100644 index 00000000..64a4d418 --- /dev/null +++ b/collects/slatex/slatex-code/fileproc.scm @@ -0,0 +1,59 @@ +;fileproc.scm +;SLaTeX Version 2.3 +;File-manipulation routines used by SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +;file-exists? + +(eval-if (vscm) + (eval-within slatex + (define slatex::file-exists? + (if (eq? *op-sys* 'unix) + (lambda (f) + (system (string-append "test -f " f))) + (lambda (f) 'assume-file-exists))))) + +(eval-unless (bigloo chez cl cscheme elk gambit guile mzscheme pcsge scm stk + vscm) + (eval-within slatex + (define slatex::file-exists? + (lambda (f) #t))));assume file exists + +;delete-file + +(eval-if (schemetoc stk umbscheme) + (eval-within slatex + (define slatex::delete-file + (lambda (f) + (call-with-output-file f + (lambda (p) 'file-deleted)))))) + +(eval-unless (bigloo chez cl cscheme guile mzscheme pcsge + schemetoc scm stk umbscheme vscm) + (eval-within slatex + (define slatex::delete-file + (lambda (f) 'assume-file-deleted)))) + +;force-output + +;the DOS version of C Scheme has flush-output, the Unix version doesn't + +(eval-if (cscheme) + (eval-within slatex + (define slatex::force-output + (if (environment-bound? user-initial-environment 'flush-output) + flush-output + (lambda z 'assume-output-forced))))) + +(eval-if (bigloo) + (eval-within slatex + (define slatex::force-output + (lambda z + (if (null? z) + (flush-output-port (current-output-port)) + (flush-output-port (car z))))))) + +(eval-unless (bigloo chez cl cscheme elk guile mzscheme scm vscm) + (eval-within slatex + (define slatex::force-output + (lambda z 'assume-output-forced)))) diff --git a/collects/slatex/slatex-code/helpers.scm b/collects/slatex/slatex-code/helpers.scm new file mode 100644 index 00000000..05961f55 --- /dev/null +++ b/collects/slatex/slatex-code/helpers.scm @@ -0,0 +1,197 @@ +;helpers.scm +;SLaTeX v. 2.4 +;Helpers for SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-unless (cl) + (eval-within slatex + (define slatex::prim-data-token? + (lambda (token) + ;token cannot be empty string! + (or (char=? (string-ref token 0) #\#) + (string->number token)))))) + +(eval-if (cl) + (eval-within slatex + (defun prim-data-token? (token) + (declare (global-string token)) + (let ((c (char token 0))) + (or (char= c #\#) + (char= c #\:) + (numberp (read-from-string token))))))) + +(eval-within slatex + + (define slatex::set-keyword + (lambda (x) + ;add token x to the keyword database + (if (not (lmember x keyword-tokens (function token=?))) + (begin + (set! constant-tokens + (delete x constant-tokens (function token=?))) + (set! variable-tokens + (delete x variable-tokens (function token=?))) + (set! data-tokens (delete x data-tokens (function token=?))) + (set! keyword-tokens (cons x keyword-tokens)))))) + + (define slatex::set-constant + (lambda (x) + ;add token x to the constant database + (if (not (lmember x constant-tokens (function token=?))) + (begin + (set! keyword-tokens + (delete x keyword-tokens (function token=?))) + (set! variable-tokens + (delete x variable-tokens (function token=?))) + (set! data-tokens (delete x data-tokens (function token=?))) + (set! constant-tokens (cons x constant-tokens)))))) + + (define slatex::set-variable + (lambda (x) + ;add token x to the variable database + (if (not (lmember x variable-tokens (function token=?))) + (begin + (set! keyword-tokens (delete x keyword-tokens (function token=?))) + (set! constant-tokens + (delete x constant-tokens (function token=?))) + (set! data-tokens (delete x data-tokens (function token=?))) + (set! variable-tokens (cons x variable-tokens)))))) + + (define slatex::set-data + (lambda (x) + ;add token x to the "data" database + (if (not (lmember x data-tokens (function token=?))) + (begin + (set! keyword-tokens + (delete x keyword-tokens (function token=?))) + (set! constant-tokens + (delete x constant-tokens (function token=?))) + (set! variable-tokens + (delete x variable-tokens (function token=?))) + (set! data-tokens (cons x data-tokens)))))) + + (define slatex::set-special-symbol + (lambda (x transl) + ;add token x to the special-symbol database with + ;the translation transl + (let ((c (lassoc x special-symbols (function token=?)))) + (if c (set-cdr! c transl) + (set! special-symbols + (cons (cons x transl) special-symbols)))))) + + (define slatex::unset-special-symbol + (lambda (x) + ;disable token x's special-symbol-hood + (set! special-symbols + (delete-if + (lambda (c) + (token=? (car c) x)) special-symbols)))) + + (define slatex::texify + (lambda (s) + ;create a tex-suitable string out of token s + (list->string (slatex::texify-aux s)))) + + (define slatex::texify-data + (lambda (s) + ;create a tex-suitable string out of the data token s + (let loop ((l (texify-aux s)) (r '())) + (if (null? l) (list->string (reverse! r)) + (let ((c (car l))) + (loop (cdr l) + (if (char=? c #\-) (append! (list #\$ c #\$) r) + (cons c r)))))))) + + (define slatex::texify-aux + (let* ((arrow (string->list "-$>$")) + (em-dash (string->list "---")) + (en-dash (string->list "--")) + (arrow2 (string->list "$\\to$")) + (em-dash-2 (string->list "${-}{-}{-}$")) + (en-dash-2 (string->list "${-}{-}$"))) + (lambda (s) + ;return the list of tex characters corresponding to token s. + ;perhaps some extra context-sensitive prettifying + ;could go in the making of texified-sl below + (let ((texified-sl (mapcan + (lambda (c) (string->list (tex-analog c))) + (string->list s)))) + (let loop ((d texified-sl)) + ;cdr down texified-sl + ;to transform any character combinations + ;as desired + (cond ((null? d) #f) + ((list-prefix? arrow d) ; $->$ + (let ((d2 (list-tail d 4))) + (set-car! d (car arrow2)) + (set-cdr! d (append (cdr arrow2) d2)) + (loop d2))) + ((list-prefix? em-dash d) ; --- + (let ((d2 (list-tail d 3))) + (set-car! d (car em-dash-2)) + (set-cdr! d (append (cdr em-dash-2) d2)) + (loop d2))) + ((list-prefix? en-dash d) ; -- + (let ((d2 (list-tail d 2))) + (set-car! d (car en-dash-2)) + (set-cdr! d (append (cdr en-dash-2) d2)) + (loop d2))) + (else (loop (cdr d))))) + texified-sl)))) + + (define slatex::display-begin-sequence + (lambda (out) + (if (or *intext?* (not *latex?*)) + (begin + (display "\\" out) + (display *code-env-spec* out) + (newline out)) + (begin + (display "\\begin{" out) + (display *code-env-spec* out) + (display "}%" out) + (newline out))))) + + (define slatex::display-end-sequence + (lambda (out) + (cond (*intext?* ;(or *intext?* (not *latex?*)) + (display "\\end" out) + (display *code-env-spec* out) + ;(display "{}" out) + (newline out)) + (*latex?* + (display "\\end{" out) + (display *code-env-spec* out) + (display "}" out) + (newline out)) + (else + (display "\\end" out) + (display *code-env-spec* out) + (newline out))))) + + (define slatex::display-tex-char + (lambda (c p) + (display (if (char? c) (tex-analog c) c) p))) + + (define slatex::display-token + (lambda (s typ p) + (cond ((eq? typ 'syntax) + (display "\\sy{" p) + (display (texify s) p) + (display "}" p)) + ((eq? typ 'variable) + (display "\\va{" p) + (display (texify s) p) + (display "}" p)) + ((eq? typ 'constant) + (display "\\cn{" p) + (display (texify s) p) + (display "}" p)) + ((eq? typ 'data) + (display "\\dt{" p) + (display (texify-data s) p) + (display "}" p)) + (else (error "display-token: ~ +Unknown token type ~s." typ))))) + + ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/history b/collects/slatex/slatex-code/history new file mode 100644 index 00000000..4b193be2 --- /dev/null +++ b/collects/slatex/slatex-code/history @@ -0,0 +1,180 @@ +2.4w + +9 Oct 1999 + +Read cr before lf when reading files on Windows (Shriram report) + +Token delimitation strengthened (John Clements bug +report). + +CL set-dispatch-macro-character arg should be uppercase +character because CLISP doesn't automatically upcase +it as standard suggests + +2.4v + +8 Mar 1999 + +Comma'd forms inside backquote should get the right font +assignment even if preceded by quote. (Shriram bug report) + +2.4u + +15 Jan 1999 + +Use require-library instead of reference-library. + +pathproc.scm: *path-separator*, *directory-mark*, +*file-hider* have approp values for OS = Windows. + +MzScheme/Win95 slatex.bat should contain Windows-style +line termination. + +Config file for CLISP on Win 95. + +Jun 8, 1998 + +2.4t + +distribution mishap fix + +May 1, 1998 + +2.4s + +Port to STk + +Apr 21, 1998 + +2.4r + +Port to Allegro Common Lisp for Linux. Minor config +bugs nixed. + +Apr 1998 + +2.4q + +Ports to Windows 95, Gambit, MIT Scheme. + +Apr 1997 + +2.4 p + +{schemeregion} should not collapse lines with TeX comments +into one (nor should it eat the comment character). + +v. 2.4o + +Fixed indentation bug caused by implicit space after \\ +in tab environment. + +Feb 1997 +v. 2.4n + +Fixed bug that caused \begin{schemebox} to produce space at +paragraph begin (Matthias). + +Ported to Bigloo, thanks to Christian Queinnec. + +* typesets as \ast. (* "as is" is too high.) + +Ported to Guile. + +May 1996 +v 2.4m + +Ported to MzScheme. + +Check that config.dat has right number of answers. +Eliminates common typos while setting up config.dat +(Shriram's sugg.). + +Accommodate Schemes that allow loading of files mentioned on +the command-line, but using an option such as -load or -f +(Shriram's sugg). + +Changed names in preproc.scm to avoid collision with +existing Scheme procs, if any. (Shriram Krishnamurthi's +idea.) + +Ported to GCL (Linux). +Changes to package system -- uses CL's package sys in CL. +dump-display made more efficient. +Cleaned up bat config. + +Feb 1996 +v 2.4l + +Ported to Macintosh Common Lisp. + +Version number reported on invocation and whilst loading +slatex.sty (to enable trenchant bug reporting). + +No longer requires "system" procedure spec from user via +config.dat. Other config info should be sufficient to +deduce this. One less confusion. + +v 2.4k + +-- and --- in Scheme tokens are treated as minuses rather +than en- and em-dash. Mike Ernst's idea. + +v 2.4j + +Now recognizes :keywords as data in CL. + +Left margin error in indented {schemedisplay}s corrected + +Package system made more robust + +Apr 1995 +v 2.4 +Support for OS/2, both FAT and HPFS. + +Included sample Rexx script (for OS/2 + emTeX + scm) +that has robust TEXINPUT recognition. + +Fixed paragraph indentation bug after {schemedisplay} +within {schemeregion}. + +Recognizes LaTeX2e files in addition to LaTeX2.09. + +Sentence-ending space doesn't follow null?, set!, etc. + +Documentation converted to plain TeX. + +Added {schemeresponse}, {schemeresponsebox}, and their +corresponding \defscheme*token and \undefscheme*token. + +Fixed bug related to quoted special symbols; +quoted math escapes; and quoted strings. + +Added \setdata in analogy with \setkeyword, +\setvariable, and \setconstant. +\schemeresult, etc., distinguish between constant and +data -- data items are set in \datafont; everything +else in \constantfont. + +Removed bogus \ignorespaces from \slatexdisable. + +Typeset code is now frenchspaced (instead of using +\null's) to avoid sentence-ending spaces after ! and ?. +Mark Krentel's idea. + +Added config code for Matthias Blume's VSCM. + +Jan 1994 +v 2.3 + +The Dark Years +Several bug fixes + +Dec 1991 +First major update + +Mar 1991 +First public release + +1990 +First Rice PLT release diff --git a/collects/slatex/slatex-code/index.tex b/collects/slatex/slatex-code/index.tex new file mode 100644 index 00000000..98a752ed --- /dev/null +++ b/collects/slatex/slatex-code/index.tex @@ -0,0 +1,233 @@ +\input tex2html + + +\htmlonly + +\htmlstylesheet{tex2html.css} + +\gifpreamble +\magnification\magstep1 +\endgifpreamble + +\let\byline\leftline + +\endhtmlonly + + +\let\n\noindent + +%%% + +\subject{SLaTeX} + +\byline{\urlh{slatex.tar.gz}{[Download version \input version ]}} + +\smallskip + +\byline{\urlh{http://www.cs.rice.edu/~dorai}{Dorai Sitaram}} +\byline{\urlh{mailto:ds26@gte.com}{ds26@gte.com}} + +\bigskip + +\section{Introduction} + +SLaTeX is a Scheme program that allows you to write +program code (or code fragments) ``as is'' in your +LaTeX or plain TeX source. SLaTeX will typeset the +code with appropriate fonts for the various token +categories --- e.g., {\bf boldface} for keywords and +{\em italics} for variables ---, at the same time +retaining the proper indentations and vertical +alignments in TeX's non-monospace fonts. + +\subsection{SLaTeX for LaTeX users} + +For example, consider a LaTeX file \p{example.tex} +with the following contents: + +\verb+ +\documentclass{article} +\usepackage{slatex} +\begin{document} + +In Scheme, the expression +\scheme|(set! x 42)| returns +an unspecified value, rather +than \scheme'42'. However, +one could get a \scheme{set!} +of the latter style with: + +\begin{schemedisplay} +(define-syntax setq + (syntax-rules () + [(setq var val) + (begin (set! var val) + var)])) +\end{schemedisplay} + +\end{document} ++ + +When run through SLaTeX, the resulting \p{example.dvi} file +looks as follows: + +--- + +\htmlgif +\input slatex.sty +\input margins +\sidemargin 1.75 true in +In Scheme, the expression +\scheme|(set! x 42)| returns +an unspecified value, rather +than \scheme'42'. However, +one could get a \scheme{set!} +of the latter style with: + +\schemedisplay +(define-syntax setq + (syntax-rules () + [(setq var val) + (begin (set! var val) + var)])) +\endschemedisplay +\endhtmlgif + +--- + +As the example shows, {\em in-text} code is introduced by +the control sequence \p{\scheme} and is flanked by either +identical characters or by matching braces. Code meant for +{\em display} is presented between +\p{\begin{schemedisplay}} and +\p{\end{schemedisplay}}. Note that you write the code +as you would when writing a program --- no special +annotation is needed to get the typeset version. + +\subsection{SLaTeX for plain TeX users} + +SLaTeX works much the same way with plain TeX as with +LaTeX, but for only two exceptions. First, since plain +TeX doesn't have \p{\documentstyle}, the file +\p{slatex.sty} must be introduced via an \p{\input} +statement before its commands can be used in the plain +TeX source. + +Second, since plain TeX does not have LaTeX's +\p|\begin{|{\em env}\p|} ... \end{|{\em env}\p|}| +style of environments, any +environment commands in SLaTeX are invoked with the +opening \p{\}{\em env} and the closing +\p{\end}{\it env}. + +The plain TeX version of \p{quick.tex} looks like: + +--- + +\verb+ +% quick.tex +\input slatex.sty + +In Scheme, the expression +\scheme|(set! x 42)| returns +an unspecified value, rather +than \scheme'42'. However, +one could get a \scheme{set!} +of the latter style with: + +\schemedisplay +(define-syntax setq + (syntax-rules () + [(setq x a) + (begin (set! x a) + x)])) +\endschemedisplay +\bye ++ + +--- + +The file is now SLaTeX'd by invoking \p{slatex} as +before --- SLaTeX is clever enough to figure out +whether the file it operates on should later be sent to +LaTeX or plain TeX. + +\section{Automatic token recognition} + +By default, SLaTeX recognizes the tokens of Scheme. +This default can be changed with the commands +\p{\setkeyword}, \p{\setvariable}, +\p{\setconstant}, and \p{\setdata}. The arguments of +these commands is a space-separated list enclosed in +braces. E.g., + +\p{ +\setconstant{infinity -infinity} +} + +\n tells SLaTeX that \scheme{infinity} and +\scheme{-infinity} are to be typeset as constants. +The file \p{cltl.sty} uses these commands to modify +SLaTeX's default so that it recognizes the tokens of +Common Lisp rather than Scheme. You may fashion your +own \p{.sty} files on the model of +\p{cltl.sty}. + +The user need not use \p{\setkeyword} to specify such +new keywords as are introduced by Scheme's (or Common +Lisp's) macro definition facilities. SLaTeX will +automatically recognize new macros and auxiliary +keywords, as in the example above, where \p{setq} is +recognized as a keyword because of the context in which +it occurs, although it is not normally a keyword in +Scheme. No special treatment is needed to ensure that +it will continue to be treated as a keyword in any +subsequent Scheme code in the document. + +In addition, quoted material is recognized as +``constant'', and strings, numbers, booleans and +characters are recognized as ``data'' without the need +to identify them with \p{\setconstant} and \p{\setdata} +respectively. + +\subsection{Tokens as arbitrary symbols} + +Although your program code is naturally restricted to +using ascii identifiers that follow some convention, +the corresponding typeset code could be more mnemonic +and utilize the full suite of mathematical and other +symbols provided by TeX. This of course should not +require you to interfere with your code itself, which +should run in its ascii representation. It is only the +typeset version that has the new look. For instance, +if you want all occurrences of the ascii token +\p{lambda} to be typeset as the Greek letter $\lambda$, +you could say + +\p{ +\setspecialsymbol{lambda}{$\lambda$} +} + +You can use \p{\unsetspecialsymbol} on a token to have +it revert to its default behavior. + +In effect, \p{\setspecialsymbol} generalizes the act of +``fonting'' a token to converting it into any arbitrary +symbol. + +\section{Additional documentation} + +More comprehensive documentation of all that +is possible with SLaTeX is provided in the +distribution. + +Although SLaTeX is written in Scheme, a configuration +option is provided to make it run on Common Lisp. +SLaTeX has tested successfully on many different Scheme +and Common Lisp dialects, viz., Allegro Common Lisp, +Austin Kyoto Common Lisp, Bigloo, Chez Scheme, CLISP, +Elk, Gambit, Gnu Common Lisp, Guile, Ibuki Common Lisp, +Macintosh Common Lisp, MIT Scheme, MzScheme, +Scheme{\tt->}C, SCM, UMB Scheme, and VSCM. + +\bye diff --git a/collects/slatex/slatex-code/install b/collects/slatex/slatex-code/install new file mode 100644 index 00000000..e26c06f0 --- /dev/null +++ b/collects/slatex/slatex-code/install @@ -0,0 +1,173 @@ +INSTALL +SLaTeX Version 2.4 +(c) Dorai Sitaram + +Installation instructions for SLaTeX + + ... + +1. Configuring SLaTeX for your system + +1) Go to the directory slatex. + +2) Edit the file config.dat as suggested in the +comments there. Some sample config.dat's are provided in +the configs/ subdirectory. + +3) Invoke your Scheme interpreter. (If you're using +Common Lisp, invoke the Common Lisp interpreter.) Load +the file config.scm into Scheme (or Common Lisp). This +is done by typing + +(load "config.scm") + +at the Scheme (or Common Lisp) prompt. + +This will configure SLaTeX for your Scheme dialect and +operating system, creating an appropriate slatex.scm file. +(For Chez and MzScheme, slatex.scm is a compiled version.) A +script file (called slatex.bat on DOS, slatex.cmd on OS/2, +and just slatex on Unix) is also created for convenient +invocation on your operating system command line. A +Scheme/Common Lisp file callsla.scm is also created to +provide access to SLaTeX from Scheme/Common Lisp. + +4) Exit Scheme (or Common Lisp). + +(Note: In many Schemes and Common Lisps on Unix, you can +combine steps 3 and 4 with a command such as + +echo '(load "config.scm")' | scheme + +) + + ... + +2. Setting paths and modifying script file + +(If your dialect is Bigloo, you may ignore this section.) + +1) Copy or move or link slatex.scm into a suitable +place, e.g., your bin or lib, or the system bin or +lib. + +2) Copy or move or link slatex.sty into a suitable +place, e.g., somewhere in your TEXINPUT(S) path. For +installing on system, place in directory containing +the LaTeX style files (on mine this is +/usr/local/lib/tex/macros). + +3) (If your platform is a Mac, ignore this.) Copy or move +or link the shellscript slatex or batfile slatex.bat to a +suitable place in your PATH, e.g., your bin or the system +bin. Note that slatex(.bat) sets SLaTeX.*texinputs*. If +you're making the same shellscript/batfile available to +multiple users, you should change the line + +(set! slatex::*texinputs* "...") + +to + +(set! slatex::*texinputs* ) + +(But see scripts/readme.) + +4) Run slatex on slatxdoc.tex for documentation. +(This also checks that slatex does indeed work on your +machine.) Refer to slatxdoc.dvi when befuddled. + + ... + +3. Other ways of invoking SLaTeX + +The configuration process creates shellscript/batfile +slatex(.bat) for a standard invoking mechanism for +SLaTeX. The shellscript/batfile is created to exploit +the way your Scheme is called, e.g., matters like +whether it accepts echo'd s-expressions (e.g., Chez), +whether it loads command line files (e.g., SCM), and +whether it always checks for an "init" file (e.g., MIT +C Scheme). + +1) If your Scheme doesn't fall into either of these +categories, you may have to write your own +shellscript/batfile or devise some other mechanism. + +2) The shellscript/batfile invokes Scheme. If, +however, you are already in Scheme and spend most of +the time continuously at the Scheme prompt rather than +the operating system prompt, you may want to avoid some +of the delays inherent in the shellscript/batfile. + +3) If your platform is a Macintosh, no shellscript/batfile +is created. The idea mentioned below is your only choice. +However, it is so easy to use that it may soon become your +preferred way of invoking SLaTeX, even on Unix or OS/2. + +The file callsla.scm, which contains just one small +procedure named call-slatex, and which is created by +the configuration process, provides a simple calling +mechanism from Scheme/Common Lisp, as opposed to the +operating system command line. You may use it as an +alternative to the slatex shellscript/batfile. The +usage is as follows: load callsla.scm into +Scheme/Common Lisp + +(load "callsla.scm") + +and type + +(call-slatex ) + +when you need to call SLaTeX on the (La)TeX file +. This invokes the SLaTeX preprocessor on +. If your Scheme has a "system" procedure +that can call the operating system command line, +call-slatex will also send your file to TeX or LaTeX. +If your Scheme does not have such a procedure, +call-slatex will simply prod you to call TeX or LaTeX +yourself. + +The outline of the shellscript/batfile or callsla.scm +or of any strategy you devise for using SLaTeX should +include the following actions: + +1) Load the file slatex.scm (created by the +configuration process) into Scheme. + +2) Set the variable slatex::*texinputs-list* to the +list of directories in which TeX looks for \input +files. If you have a a "regular" TEXINPUTS, you could +set slatex::*texinputs-list* to + +(slatex::path-to-list ) + +(In shell scripts, can be +obtained with some for unquoting. In Schemes with +getenv, you could use (getenv "TEXINPUTS").) + +3) Call the procedure slatex::process-main-tex-file on the +.tex file to be processed. + +4) Call either latex or tex on the .tex file. + +You may devise your own way of calling +process-main-tex-file, provided your method makes sure +that slatex.scm has been loaded, slatex::.*texinputs* set +appropriately _before_ the call and latex/tex is called +_after_ the call. + +Note that if you prefer to stay in Scheme most of the +time, it is a good idea to pre-load the procedure +call-slatex, perhaps through an init file. Call-slatex +is just a "one-liner" "call-by-need" hook to SLaTeX and +does not take up much resources. (Global name clashes +between your own code and SLaTeX code won't occur +unless you use variable names starting with 'slatex::') +If you made no calls to call-slatex, the bigger file +slatex.scm is not loaded at all. If you make several +calls to call-slatex, slatex.scm is loaded only once, +at the time of the first call. + +;end of file \ No newline at end of file diff --git a/collects/slatex/slatex-code/lerror.scm b/collects/slatex/slatex-code/lerror.scm new file mode 100644 index 00000000..4cc2b67a --- /dev/null +++ b/collects/slatex/slatex-code/lerror.scm @@ -0,0 +1,131 @@ +;lerror.scm +;SLaTeX v. 2.3 +;Display and error routines +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +;#\newline and #\space are r5rs +;#\return and #\tab aren't + +(eval-unless (cl scm) + (eval-within slatex + (defvar slatex::*return* (integer->char 13)) + (defvar slatex::*tab* (integer->char 9)))) + +(eval-if (guile scm) + (eval-within slatex + (define slatex::error + (lambda vv + (let ((ep (current-error-port))) + (display "Error: " ep) + (for-each + (lambda (v) + (display v ep) + (newline ep)) + vv) + (abort)))))) + +(eval-if (chez elk schemetoc) + (eval-within slatex + (define slatex::error + (lambda vv + (display "Error: ") + (for-each + (lambda (v) + (display v) (newline)) + vv) + (global-error #f ""))))) + +(eval-if (stk) + (eval-within slatex + (define slatex::error + (lambda vv + (display "Error: ") + (for-each + (lambda (v) (display v) (newline)) + vv) + (global-error "Error"))))) + +(eval-if (bigloo) + (eval-within slatex + (define slatex::error + (lambda vv + (display "Error: ") + (for-each + (lambda (v) + (display v) (newline)) + vv) + (global-error 'SLaTeX "error" #f))))) + +(eval-unless (bigloo chez cl elk guile schemetoc scm) + (eval-within slatex + (define slatex::error + (lambda vv + (display "Error: ") + (for-each + (lambda (v) + (display v) (newline)) + vv) + (global-error ""))))) + +(eval-if (vscm) + (eval-within slatex + (define void + ;(void) is a no-op expression that's useful in some places + ;where use of a dummy value would make VSCM "warn" about + ;unused values + (let ((x 0)) + (lambda () + (set! x 0)))))) + +(eval-unless (vscm cl chez gambit mzscheme) + (eval-within slatex + (define slatex::void + (lambda () + (if #f #f))))) + +(eval-if (cl) + (eval-within slatex + (defun slatex::function-available (s) + (let ((x (find-symbol s + (if (member 'gcl *features*) :lisp :cl)))) + (if (and x (fboundp x)) x nil))) + + (defun slatex::exit-scheme () + (let ((quitter + (or (function-available "BYE") + (function-available "EXIT") + (function-available "QUIT")))) + (if quitter (funcall quitter) + (progn + (format t "You may exit CL now!~%") + (funcall 'barf))))))) + +(eval-if (chez elk mzscheme pcsge schemetoc stk umbscheme vscm) + (eval-within slatex + (define slatex::exit-scheme + (lambda () ;in case it's a macro + (exit))))) + +(eval-if (cscheme) + (eval-within slatex + (define slatex::exit-scheme + (lambda () + (%exit))))) + +(eval-if (guile scm) + (eval-within slatex + (define slatex::exit-scheme quit))) + +(eval-if (bigloo) + (eval-within slatex + (define slatex::exit-scheme + (lambda () (exit 0))))) + +(eval-unless (bigloo chez cl cscheme elk guile mzscheme pcsge + schemetoc scm umbscheme vscm) + (eval-within slatex + (define slatex::exit-scheme + (lambda () + (display "Exit Scheme!") + (newline) + (barf))))) diff --git a/collects/slatex/slatex-code/manifest b/collects/slatex/slatex-code/manifest new file mode 100644 index 00000000..1fd1322c --- /dev/null +++ b/collects/slatex/slatex-code/manifest @@ -0,0 +1,81 @@ +;manifest +;SLaTeX Version 2.4 +;List of files provided in the SLaTeX distribution +;(c) Dorai Sitaram +;ds26@gte.com + +README +install +history +manifest +version +copying +config.dat + +;documentation +slatxdoc.tex +slatxdoc.bbl +slatxdoc.dvi +index.tex +tex2html.css +margins.tex + +;misc TeX macros +8pt.tex +2col.tex +defun.tex +tex2html.tex + +;style files +slatex.sty +cltl.sty + +config.scm +cfg4scm.scm +cfg4lsp.lsp + +slaconfg.lsp +preproc.lsp +batconfg.lsp + +slaconfg.scm +preproc.scm +batconfg.scm +aliases.scm + +s4.scm +seqprocs.scm +fileproc.scm +defaults.scm +lerror.scm +structs.scm +helpers.scm +peephole.scm +codeset.scm +pathproc.scm +texread.scm +proctex.scm +proctex2.scm + +;alternative ways to invoke SLaTeX +scripts/readme +scripts/slatex.cmd + +;sample config.dats +configs/template.cfg +configs/rice.cfg +configs/scmunix.cfg +configs/gclunix.cfg +configs/clispunix.cfg +configs/clispw95.cfg +configs/mzschemeunix.cfg +configs/mzschemew95.cfg +configs/mcl.cfg +configs/guileunix.cfg +configs/bigloounix.cfg +configs/mitschemeunix.cfg +configs/gambitunix.cfg +configs/acllinux.cfg +configs/stkunix.cfg + +;eof diff --git a/collects/slatex/slatex-code/margins.tex b/collects/slatex/slatex-code/margins.tex new file mode 100644 index 00000000..f793025a --- /dev/null +++ b/collects/slatex/slatex-code/margins.tex @@ -0,0 +1,11 @@ +\def\sidemargin{\afterassignment\sidemarginII\hoffset} + +\def\sidemarginII{\advance\hoffset -1true in +\advance\hsize -2\hoffset} + +\def\vertmargin{\afterassignment\vertmarginII\voffset} + +\def\vertmarginII{\advance\voffset -1true in +\advance\vsize -2\voffset} + + diff --git a/collects/slatex/slatex-code/pathproc.scm b/collects/slatex/slatex-code/pathproc.scm new file mode 100644 index 00000000..fb720672 --- /dev/null +++ b/collects/slatex/slatex-code/pathproc.scm @@ -0,0 +1,158 @@ +;pathproc.scm +;SLaTeX Version 1.99 +;File-manipulation routines used by SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-unless (cl) + (eval-within slatex + (define slatex::directory-namestring + (lambda (f) + (let ((p (string-position-right slatex::*directory-mark* f))) + (if p + (substring f 0 (+ p 1)) "")))) + + (define slatex::basename + (lambda (f) + (let ((p (string-position-right *directory-mark* f))) + (if p + (set! f (substring f (+ p 1) (string-length f)))) + (let ((p (string-position-right #\. f))) + (if p + (substring f 0 p) + f))))) + + )) + +(eval-if (cl) + (eval-within slatex + (defun basename (f) + (let ((f (file-namestring (merge-pathnames + (make-pathname :type "x") f)))) + (subseq f 0 (- (length f) 2)))))) + +(eval-within slatex + + (defvar slatex::*texinputs* "") + + (defvar slatex::*texinputs-list* #f) + + (defvar slatex::*path-separator* + (cond ((eq? *op-sys* 'unix) #\:) + ((eq? *op-sys* 'mac-os) (integer->char 0)) + ((memq *op-sys* '(windows os2 dos os2fat)) #\;) + (else (error "Couldn't determine path separator character.")))) + + (defvar slatex::*directory-mark* + (cond ((eq? *op-sys* 'unix) #\/) + ((eq? *op-sys* 'mac-os) #\:) + ((memq *op-sys* '(windows os2 dos os2fat)) #\\) + (else (error "Couldn't determine directory mark.")))) + + (defvar slatex::*directory-mark-string* + (list->string (list *directory-mark*))) + + (defvar slatex::*file-hider* + (cond ((memq *op-sys* '(windows os2 unix mac-os)) ".") + ((memq *op-sys* '(dos os2fat)) "x") ;no such luck for dos & os2fat + (else "."))) ;use any old character + + (define slatex::path-to-list + (lambda (p) + ;convert a unix or dos representation of a path to a list of + ;directory names (strings) + (let loop ((p (string->list p)) (r (list ""))) + (let ((separator-pos (position-char *path-separator* p))) + (if separator-pos + (loop (list-tail p (+ separator-pos 1)) + (cons (list->string (sublist p 0 separator-pos)) + r)) + (reverse! (cons (list->string p) r))))))) + + (define slatex::find-some-file + (lambda (path . files) + ;look through each directory in path till one of files is found + (let loop ((path path)) + (if (null? path) #f + (let ((dir (car path))) + (let loop1 ((files + (if (or (string=? dir "") (string=? dir ".")) + files + (map (lambda (file) + (string-append dir + *directory-mark-string* + file)) files)))) + (if (null? files) (loop (cdr path)) + (let ((file (car files))) + (if (file-exists? file) file + (loop1 (cdr files))))))))))) + + (define slatex::file-extension + (lambda (filename) + ;find extension of filename + (let ((i (string-position-right #\. filename))) + (if i (substring filename i (string-length filename)) + #f)))) + + (define slatex::full-texfile-name + (lambda (filename) + ;find the full pathname of the .tex/.sty file filename + (let ((extn (file-extension filename))) + (if (and extn (or (string=? extn ".sty") (string=? extn ".tex"))) + (find-some-file *texinputs-list* filename) + (find-some-file *texinputs-list* + (string-append filename ".tex") filename))))) + + (define slatex::full-styfile-name + (lambda (filename) + ;find the full pathname of the .sty file filename + (find-some-file *texinputs-list* + (string-append filename ".sty")))) + + (define slatex::full-clsfile-name + (lambda (filename) + ;find the full pathname of the .cls file filename + (find-some-file *texinputs-list* + (string-append filename ".cls")))) + + (define slatex::full-scmfile-name + (lambda (filename) + ;find the full pathname of the scheme file filename; + ;acceptable extensions are .scm .ss .s + (apply (function find-some-file) *texinputs-list* + filename + (map (lambda (extn) (string-append filename extn)) + '(".scm" ".ss" ".s"))))) + + (defvar slatex::subjobname 'fwd) + + (defvar slatex::primary-aux-file-count -1) + + (define slatex::new-primary-aux-file + (lambda e + ;used by new-aux-file unless in protected region; + ;this is the default + (set! primary-aux-file-count + (+ primary-aux-file-count 1)) + (apply (function string-append) *tex-calling-directory* + *file-hider* "Z" + (number->string primary-aux-file-count) + subjobname e))) + + (define slatex::new-secondary-aux-file + (let ((n -1)) + (lambda e + ;used by new-aux-file when in protected region + (set! n (+ n 1)) + (apply (function string-append) *tex-calling-directory* + *file-hider* + "ZZ" (number->string n) subjobname e)))) + + (define slatex::new-aux-file + (lambda e + ;create a new auxiliary file with provided extension if any + (apply (if *slatex-in-protected-region?* + (function new-secondary-aux-file) + (function new-primary-aux-file)) + e))) + + ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/peephole.scm b/collects/slatex/slatex-code/peephole.scm new file mode 100644 index 00000000..92afb6a5 --- /dev/null +++ b/collects/slatex/slatex-code/peephole.scm @@ -0,0 +1,397 @@ +;peephole.scm +;SLaTeX Version 2.3 +;Peephole adjuster used by the SLaTeX typesetter +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-within slatex + + (define slatex::get-line + (let ((curr-notab &void-notab)) + (lambda (line) + ;read the current tex line into "line"; + ;returns false on eof + (let ((graphic-char-seen? #f)) + (let loop ((i 0)) + (let ((c (read-char *in*))) + (cond (graphic-char-seen? (void)) + ((or (eof-object? c) + (char=? c *return*) + (char=? c #\newline) + (char=? c #\space) (char=? c *tab*)) + (void)) + (else (set! graphic-char-seen? #t))) + (cond + ((eof-object? c) + (cond ((eq? curr-notab &mid-string) + (if (> i 0) + (setf (of line =notab / (- i 1)) &end-string))) + ((eq? curr-notab &mid-comment) + (set! curr-notab &void-notab)) + ((eq? curr-notab &mid-math) + (error "get-line: Found eof inside math."))) + (setf (of line =char / i) #\newline) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &void-notab) + (setf (of line =rtedge) i) + (if (eq? (of line =notab / 0) &mid-string) + (setf (of line =notab / 0) &begin-string)) + (if (= i 0) #f #t)) + ((or (char=? c *return*) (char=? c #\newline)) + (if (and (memv slatex::*op-sys* '(dos windows os2 os2fat)) + (char=? c *return*)) + (if (char=? (peek-char *in*) #\newline) + (read-char *in*))) + (cond ((eq? curr-notab &mid-string) + (if (> i 0) + (setf (of line =notab / (- i 1)) &end-string))) + ((eq? curr-notab &mid-comment) + (set! curr-notab &void-notab)) + ((eq? curr-notab &mid-math) + (error "get-line: Sorry, you can't split ~ + math formulas across lines in Scheme code."))) + (setf (of line =char / i) #\newline) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) + (cond ((eof-object? (peek-char *in*)) &plain-crg-ret) + (*intext?* &plain-crg-ret) + (else &tabbed-crg-ret))) + (setf (of line =notab / i) &void-notab) + (setf (of line =rtedge) i) + (if (eq? (of line =notab / 0) &mid-string) + (setf (of line =notab / 0) &begin-string)) + #t) + ((eq? curr-notab &mid-comment) + (setf (of line =char / i) c) + (setf (of line =space / i) + (cond ((char=? c #\space) &plain-space) + ((char=? c *tab*) &plain-space) + (else &void-space))) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &mid-comment) + (loop (+ i 1))) + ((char=? c #\\) + (setf (of line =char / i) c) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) curr-notab) + (let ((i+1 (+ i 1)) (c+1 (read-char *in*))) + (if (char=? c+1 *tab*) (set! c+1 #\space)) + (setf (of line =char / i+1) c+1) + (setf (of line =space / i+1) + (if (char=? c+1 #\space) &plain-space + &void-space)) + (setf (of line =tab / i+1) &void-tab) + (setf (of line =notab / i+1) curr-notab) + (loop (+ i+1 1)))) + ((eq? curr-notab &mid-math) + (if (char=? c *tab*) (set! c #\space)) + (setf (of line =space / i) + (if (char=? c #\space) &plain-space + &void-space)) + (setf (of line =tab / i) &void-tab) + (cond ((memv c *math-triggerers*) + (setf (of line =char / i) #\$) + (setf (of line =notab / i) &end-math) + (setf curr-notab &void-notab)) + (else (setf (of line =char / i) c) + (setf (of line =notab / i) &mid-math))) + (loop (+ i 1))) + ((eq? curr-notab &mid-string) + (if (char=? c *tab*) (set! c #\space)) + ;or should tab and space be treated differently? + (setf (of line =char / i) c) + (setf (of line =space / i) + (if (char=? c #\space) &inner-space &void-space)) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) + (cond ((char=? c #\") + (set! curr-notab &void-notab) + &end-string) + (else &mid-string))) + (loop (+ i 1))) + ;henceforth curr-notab is &void-notab + ((char=? c #\space) + (setf (of line =char / i) c) + (setf (of line =space / i) + (cond (*intext?* &plain-space) + (graphic-char-seen? &inner-space) + (else &init-space))) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &void-notab) + (loop (+ i 1))) + ((char=? c *tab*) + (let loop1 ((i i) (j 0)) + (if (< j 8) + (begin + (setf (of line =char / i) #\space) + (setf (of line =space / i) + (cond (*intext?* &plain-space) + (graphic-char-seen? &inner-space) + (else &init-space))) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &void-notab) + (loop1 (+ i 1) (+ j 1))))) + (loop (+ i 8))) + ((char=? c #\") + (setf (of line =char / i) c) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &begin-string) + (set! curr-notab &mid-string) + (loop (+ i 1))) + ((char=? c #\;) + (setf (of line =char / i) c) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &begin-comment) + (set! curr-notab &mid-comment) + (loop (+ i 1))) + ((memv c *math-triggerers*) + (setf (of line =char / i) #\$) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &begin-math) + (set! curr-notab &mid-math) + (loop (+ i 1))) + (else (setf (of line =char / i) c) + (setf (of line =space / i) &void-space) + (setf (of line =tab / i) &void-tab) + (setf (of line =notab / i) &void-notab) + (loop (+ i 1)))))))))) + + (define slatex::peephole-adjust + (lambda (curr prev) + ;adjust the tabbing information on the current line curr and + ;its previous line prev relative to each other + (if (or (slatex::blank-line? curr) + (slatex::flush-comment-line? curr)) + (if (not *latex-paragraph-mode?*) + (begin + (set! *latex-paragraph-mode?* #t) + (if (not *intext?*) + (begin + (slatex::remove-some-tabs prev 0) + (let ((prev-rtedge (of prev =rtedge))) + (if (eq? (of prev =tab / prev-rtedge) &tabbed-crg-ret) + (setf (of prev =tab / (of prev =rtedge)) + &plain-crg-ret))))))) + (begin + (if *latex-paragraph-mode?* + (set! *latex-paragraph-mode?* #f) + (if (not *intext?*) + (let ((remove-tabs-from #f)) + (let loop ((i 0)) + (cond + ((char=? (of curr =char / i) #\newline) + (set! remove-tabs-from i)) + ((char=? (of prev =char / i) #\newline) + (set! remove-tabs-from #f)) + ((eq? (of curr =space / i) &init-space) + ;eating initial space of curr + (if (eq? (of prev =notab / i) &void-notab) + (begin + (cond + ((or (char=? (of prev =char / i) #\() + (eq? (of prev =space / i) &paren-space)) + (setf (of curr =space / i) &paren-space)) + ((or (char=? (of prev =char / i) #\[) + (eq? (of prev =space / i) &bracket-space)) + (setf (of curr =space / i) &bracket-space)) + ((or (memv (of prev =char / i) '(#\' #\` #\,)) + (eq? (of prev =space / i) "e-space)) + (setf (of curr =space / i) "e-space))) + (if (memq (of prev =tab / i) + (list &set-tab &move-tab)) + (setf (of curr =tab / i) &move-tab)))) + (loop (+ i 1))) + ;finished tackling &init-spaces of curr + ((= i 0) ;curr starts left-flush + (set! remove-tabs-from 0)) + ;at this stage, curr[notab,i] + ;is either #f or a &begin-comment/string + ((not (eq? (of prev =tab / i) &void-tab)) + ;curr starts with nice alignment with prev + (set! remove-tabs-from (+ i 1)) + (if (memq (of prev =tab / i) + (list &set-tab &move-tab)) + (setf (of curr =tab / i) &move-tab))) + ((memq (of prev =space / i) + (list &init-space &init-plain-space + &paren-space &bracket-space + "e-space)) + ;curr starts while prev is still empty + (set! remove-tabs-from (+ i 1))) + ((and (char=? (of prev =char / (- i 1)) #\space) + (eq? (of prev =notab / (- i 1)) &void-notab)) + ;curr can induce new alignment straightaway + (set! remove-tabs-from (+ i 1)) + (setf (of prev =tab / i) &set-tab) + (setf (of curr =tab / i) &move-tab)) + (else ;curr stakes its &move-tab (modulo parens/bkts) + ;and induces prev to have corresp &set-tab + (set! remove-tabs-from (+ i 1)) + (let loop1 ((j (- i 1))) + (cond ((<= j 0) 'exit-loop1) + ((not (eq? (of curr =tab / j) &void-tab)) + 'exit-loop1) + ((memq (of curr =space / j) + (list &paren-space &bracket-space + "e-space)) + (loop1 (- j 1))) + ((or (not (eq? (of prev =notab / j) + &void-notab)) + (char=? (of prev =char / j) #\space)) + (let ((k (+ j 1))) + (if (not (memq (of prev =notab / k) + (list &mid-comment + &mid-math &end-math + &mid-string + &end-string))) + (begin + (if (eq? (of prev =tab / k) + &void-tab) + (setf (of prev =tab / k) + &set-tab)) + (setf (of curr =tab / k) + &move-tab))))) + (else 'anything-else?) + ))))) + (remove-some-tabs prev remove-tabs-from)))) + (if (not *intext?*) (slatex::add-some-tabs curr)) + (slatex::clean-init-spaces curr) + (slatex::clean-inner-spaces curr))))) + + (define slatex::add-some-tabs + (lambda (line) + ;add some tabs in the body of line "line" so the next line + ;can exploit them + (let loop ((i 1) (succ-parens? #f)) + (let ((c (of line =char / i))) + (cond ((char=? c #\newline) 'exit-loop) + ((not (eq? (of line =notab / i) &void-notab)) + (loop (+ i 1) #f)) + ((char=? c #\[) + (if (eq? (of line =tab / i) &void-tab) + (setf (of line =tab / i) &set-tab)) + (loop (+ i 1) #f)) + ((char=? c #\() + (if (eq? (of line =tab / i) &void-tab) + (if (not succ-parens?) + (setf (of line =tab / i) &set-tab))) + (loop (+ i 1) #t)) + (else (loop (+ i 1) #f))))))) + + (define slatex::remove-some-tabs + (lambda (line i) + ;remove useless tabs on line "line" after index i + (if i + (let loop ((i i)) + (cond ((char=? (of line =char / i) #\newline) 'exit) + ((eq? (of line =tab / i) &set-tab) + (setf (of line =tab / i) &void-tab) + (loop (+ i 1))) + (else (loop (+ i 1)))))))) + + (define slatex::clean-init-spaces + (lambda (line) + ;remove init-spaces on line "line" because + ;tabs make them defunct + (let loop ((i (of line =rtedge))) + (cond ((< i 0) 'exit-loop) + ((eq? (of line =tab / i) &move-tab) + (let loop1 ((i (- i 1))) + (cond ((< i 0) 'exit-loop1) + ((memq (of line =space / i) + (list &init-space &paren-space &bracket-space + "e-space)) + (setf (of line =space / i) &init-plain-space) + (loop1 (- i 1))) + (else (loop1 (- i 1)))))) + (else (loop (- i 1))))))) + + (define slatex::clean-inner-spaces + (lambda (line) + ;remove single inner spaces in line "line" since + ;paragraph mode takes care of them + (let loop ((i 0) (succ-inner-spaces? #f)) + (cond ((char=? (of line =char / i) #\newline) 'exit-loop) + ((eq? (of line =space / i) &inner-space) + (if (not succ-inner-spaces?) + (setf (of line =space / i) &plain-space)) + (loop (+ i 1) #t)) + (else (loop (+ i 1) #f)))))) + + (define slatex::blank-line? + (lambda (line) + ;check if line "line" is blank + (let loop ((i 0)) + (let ((c (of line =char / i))) + (cond ((char=? c #\space) + (if (eq? (of line =notab / i) &void-notab) + (loop (+ i 1)) #f)) + ((char=? c #\newline) + (let loop1 ((j (- i 1))) + (if (not (<= j 0)) + (begin + (setf (of line =space / i) &void-space) + (loop1 (- j 1))))) + #t) + (else #f)))))) + + (define slatex::flush-comment-line? + (lambda (line) + ;check if line "line" is one with ; in the leftmost column + (and (char=? (of line =char / 0) #\;) + (eq? (of line =notab / 0) &begin-comment) + (not (char=? (of line =char / 1) #\;))))) + + (define slatex::do-all-lines + (lambda () + ;process all lines, adjusting each adjacent pair + (let loop ((line1 *line1*) (line2 *line2*)) + (let* ((line2-paragraph? *latex-paragraph-mode?*) + (more? (get-line line1))) + ; + (peephole-adjust line1 line2) + ; + (funcall (if line2-paragraph? + (function slatex::display-tex-line) + (function slatex::display-scm-line)) line2) + ; + (if (not (eq? line2-paragraph? *latex-paragraph-mode?*)) + (funcall (if *latex-paragraph-mode?* + (function display-end-sequence) + (function display-begin-sequence)) *out*)) + ; + (if more? (loop line2 line1)))))) + + ;scheme2tex is the "interface" procedure supplied by this file -- + ;it takes Scheme code from inport and produces LaTeX source for same + ;in outport + + (define slatex::scheme2tex + (lambda (inport outport) + ;create a typeset version of scheme code from inport + ;in outport; + ;local setting of keywords, etc.? + (set! *in* inport) + (set! *out* outport) + (set! *latex-paragraph-mode?* #t) + (set! *in-qtd-tkn* #f) + (set! *in-bktd-qtd-exp* 0) + (set! *in-mac-tkn* #f) + (set! *in-bktd-mac-exp* 0) + (set! *case-stack* '()) + (set! *bq-stack* '()) + (let ((flush-line ;needed anywhere else? + (lambda (line) + (setf (of line =rtedge) 0) + (setf (of line =char / 0) #\newline) + (setf (of line =space / 0) &void-space) + (setf (of line =tab / 0) &void-tab) + (setf (of line =notab / 0) &void-notab)))) + (funcall flush-line *line1*) + (funcall flush-line *line2*)) + (do-all-lines))) + ) diff --git a/collects/slatex/slatex-code/preproc.lsp b/collects/slatex/slatex-code/preproc.lsp new file mode 100644 index 00000000..27137b68 --- /dev/null +++ b/collects/slatex/slatex-code/preproc.lsp @@ -0,0 +1,157 @@ +;preproc.lsp +;Preprocessor to allow CL interpret the brand of Scheme +;used in SLaTeX. +;(c) Dorai Sitaram, Nov. 1992 + +#+gcl +(make-package :slatex) + +#-gcl +(defpackage slatex + (:use cl)) + +;print lower-case + +(setq *print-case* :downcase) + +;defmacro-slatex + +(defmacro defmacro-slatex (m vv &rest ee) + `(progn + (setf (get nil ',m) ',m) + (setf (get ',m 'defmacro-slatex) + #'(lambda ,vv ,@ee)))) + +(defun slatex-macro-p (s) + (and (symbolp s) (get s 'defmacro-slatex))) + +(defun expand-macrocalls (e) + (if (not (consp e)) e + (let* ((a (car e)) (xfmr (slatex-macro-p a))) + (if xfmr + (expand-macrocalls (apply xfmr (cdr e))) + (case a + ((quote) e) + ((lambda) + `(lambda ,(cadr e) + ,@(mapcar #'expand-macrocalls (cddr e)))) + ((case) + `(case ,(expand-macrocalls (cadr e)) + ,@(mapcar #'(lambda (clause) + `(,(car clause) + ,@(mapcar #'expand-macrocalls (cdr clause)))) + (cddr e)))) + (t (mapcar #'expand-macrocalls e))))))) + +;some macros + +;package + +(defvar *alias-alist* '()) + +(defun make-slatex-alias (zz) + (loop + (when (null zz) (return)) + (push (cons (car zz) (cadr zz)) *alias-alist*) + (setq zz (cddr zz)))) + +(load "aliases.scm") + +(defmacro-slatex eval-within (p &rest ee) + (let ((ee (nsublis *alias-alist* ee))) + (case (length ee) + ((0) nil) + ((1) (car ee)) + (t (cons 'progn ee))))) + +(defmacro-slatex slatex::%lambda (parms &rest body) + `(function + (lambda ,(dot-to-and-rest parms) ; cl::lambda + ,@body))) + +(defun dot-to-and-rest (vv) + ;Change the . z format of Scheme lambdalists to + ;CL's &rest z format + (cond ((null vv) nil) + ((symbolp vv) `(&rest ,vv)) + (t (let* ((last-vv (last vv)) + (cdr-last-vv (cdr last-vv))) + (if cdr-last-vv + (progn + (setf (cdr last-vv) `(&rest ,cdr-last-vv)) + vv) + vv))))) + +(defmacro-slatex define (x e) + (unless (and x (symbolp x) (consp e)) + (error "define ~s ~s" x e)) + (let ((a (car e))) + (case a + ((slatex::%let let*) + `(,a ,(cadr e) + (define ,x ,(caddr e)))) + ((slatex::%lambda) + `(defun ,x ,(dot-to-and-rest (cadr e)) + ,@(cddr e))) + (t (error "define ~s ~s" x e))))) + +(defmacro-slatex slatex::%let (n &rest ee) + ;Named let with name containing the string "loop" + ;is considered to be iterative and is transformed + ;into CL loop. + (if (and n (symbolp n)) + (let ((tail-recursive-p + (search "LOOP" (symbol-name n)))) + (if (and tail-recursive-p (eq n 'loop)) + (setf n '%%%loop%%% + ee (nsublis `((loop . ,n)) ee))) + `(,(if tail-recursive-p 'named-let-tail-recursive + 'named-let-non-tail-recursive) ,n ,@ee)) + `(let ,n ,@ee))) ; cl::let? + +(defmacro-slatex named-let-non-tail-recursive (n xvxv &rest ee) + `(labels ((,n ,(mapcar 'car xvxv) ,@ee)) + (,n ,@(mapcar 'cadr xvxv)))) + +(defmacro-slatex named-let-tail-recursive (n xvxv &rest ee) + (let ((xx (mapcar 'car xvxv))) + `(let ,xvxv + (flet ((,n ,xx + (throw ',n (values ,@xx)))) + (loop + (multiple-value-setq ,xx + (let ,(mapcar #'(lambda (x) `(,x ,x)) xx) + (catch ',n + (return ,(if (= (length ee) 1) (car ee) + (cons 'progn ee))))))))))) + +(defmacro-slatex defenum (&rest z) + (do ((z z (cdr z)) + (n 0 (1+ n)) + (r '() (cons `(defvar ,(car z) (code-char ,n)) r))) + ((null z) `(progn ,@r)))) + +(defmacro-slatex defrecord (name &rest fields) + (do ((fields fields (cdr fields)) + (i 0 (1+ i)) + (r '() (cons `(defvar ,(car fields) ,i) r))) + ((null fields) + `(progn + (defun ,name () (make-array ,i)) + ,@r)))) + +(defmacro-slatex of (r i &rest z) + (cond ((null z) `(elt ,r ,i)) + ((and (eq i '/) (= (length z) 1)) + `(char ,r ,(car z))) + (t `(of (elt ,r ,i) ,@z)))) + +(defmacro-slatex eval-if (dialects &rest body) + (if (member 'cl dialects) + (if (= (length body) 1) (car body) + `(progn ,@body)))) + +(defmacro-slatex eval-unless (dialects &rest body) + (if (not (member 'cl dialects)) + (if (= (length body) 1) (car body) + `(progn ,@body)))) diff --git a/collects/slatex/slatex-code/preproc.scm b/collects/slatex/slatex-code/preproc.scm new file mode 100644 index 00000000..2a65d57c --- /dev/null +++ b/collects/slatex/slatex-code/preproc.scm @@ -0,0 +1,247 @@ +;preproc.scm +;Macro preprocessor for SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +;property lists + +(define preproc:*properties* '()) + +(define preproc:get + (lambda (sym prop . default) + (let ((sym-props (assoc sym preproc:*properties*))) + (cond (sym-props + (let ((prop-val (assoc prop (cdr sym-props)))) + (cond (prop-val (cdr prop-val)) + ((pair? default) (car default)) + (else #f)))) + ((pair? default) (car default)) + (else #f))))) + +(define preproc:put + (lambda (sym prop val) + (let ((sym-props (assoc sym preproc:*properties*))) + (if sym-props + (let* ((props (cdr sym-props)) + (prop-val (assoc prop props))) + (if prop-val + (set-cdr! prop-val val) + (set-cdr! sym-props + (cons (cons prop val) props)))) + (set! preproc:*properties* + (cons (cons sym (list (cons prop val))) + preproc:*properties*)))))) + +;define-macro + +(define defmacro-preproc + (lambda (kw xfmr) + (preproc:put #f kw kw) + (preproc:put kw 'defmacro-preproc xfmr))) + +(define preproc:macro? + (lambda (s) + (and (symbol? s) + (preproc:get s 'defmacro-preproc)))) + +(define expand-macrocalls + (lambda (e) + (if (not (pair? e)) e + (let* ((a (car e)) (xfmr (preproc:macro? a))) + (if xfmr + (expand-macrocalls (apply xfmr (cdr e))) + (case a + ;;something that looks like a macro call + ;;within quote shouldn't be expanded + ((quote) e) + ;;lambda-arg can contain dotted list -- so + ;;we avoid letting else-clause map across it + ((lambda) + `(lambda ,(cadr e) + ,@(map expand-macrocalls (cddr e)))) + ;;case-tags can look like macro calls -- these + ;;shouldn't be expanded + ((case) + `(case ,(expand-macrocalls (cadr e)) + ,@(map (lambda (clause) + `(,(car clause) + ,@(map expand-macrocalls (cdr clause)))) + (cddr e)))) + ;;expand-macrocalls can be mapped across the rest -- + ;;it isn't likely that we can have an expression + ;;that looks like a macro call but isn't + (else (map expand-macrocalls e)))))))) + +;some macros + +;package + +(define make-slatex-alias + (lambda (zz) + (if (not (null? zz)) + (begin + (preproc:put 'slatex (car zz) (cadr zz)) + (make-slatex-alias (cddr zz)))))) + +(load "aliases.scm") + +(define preproc:string-index + (lambda (s c) + (let ((n (string-length s))) + (let loop ((i 0)) + (cond ((>= i n) #f) + ((char=? (string-ref s i) c) i) + (else (loop (+ i 1)))))))) + +(defmacro-preproc 'in-package + (lambda (p) #f)) + +(defmacro-preproc 'shadow + (lambda (xx) #f)) + +(define *current-package* #f) + +(defmacro-preproc 'eval-within + (lambda (p . ee) + (let ((ee + (let insert-qualifieds ((e ee)) + (cond ((pair? e) + (set-car! e (insert-qualifieds (car e))) + (set-cdr! e (insert-qualifieds (cdr e))) + e) + ((symbol? e) + (%eval-within-get-qualified-symbol p e)) + (else e))))) + (case (length ee) + ((0) #f) + ((1) (car ee)) + (else (cons 'begin ee)))))) + +(define %eval-within-get-qualified-symbol + (lambda (curr-p px) + (let* ((px-s (symbol->string px)) + (i (%eval-within-dblcolon-index px-s))) + (cond (i (let ((p (string->symbol (substring px-s 0 i))) + (x (string->symbol (substring px-s (+ i 2) + (string-length px-s))))) + (if (eq? p curr-p) (preproc:put p x px)) + px)) + (else (cond ((preproc:get curr-p px)) + ((preproc:get #f px)) + (else px))))))) + +(define %eval-within-dblcolon-index + (lambda (s) + (let ((i (preproc:string-index s #\:))) + (if (or (not i) + (= i (- (string-length s) 1))) #f + (let ((i+1 (+ i 1))) + (if (char=? (string-ref s i+1) #\:) + i #f)))))) + +;defvar + +(defmacro-preproc 'defvar + (lambda (x e) + `(define ,x ,e))) + +;fluid-let + +(define gentemp + (let ((n -1)) + (lambda () + ;;generates an allegedly new symbol. This is a + ;;gross hack since there is no standardized way + ;;of getting uninterned symbols + (set! n (+ n 1)) + (string->symbol (string-append "%:g" (number->string n) "%"))))) + +(defmacro-preproc 'fluid-let + (lambda (let-pairs . body) + (let ((x-s (map car let-pairs)) + (i-s (map cadr let-pairs)) + (old-x-s (map (lambda (p) (gentemp)) let-pairs))) + `(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s) + ,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s) + (let ((%temp% (begin ,@body))) + ,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s) + %temp%))))) + +;defenum + +(defmacro-preproc 'defenum + (lambda z + (let loop ((z z) (n 0) (r '())) + (if (null? z) `(begin ,@r) + (loop (cdr z) (+ n 1) + (cons `(define ,(car z) (integer->char ,n)) r)))))) + +;defrecord + +(defmacro-preproc 'defrecord + (lambda (name . fields) + (let loop ((fields fields) (i 0) (r '())) + (if (null? fields) + `(begin (define ,name (lambda () (make-vector ,i))) + ,@r) + (loop (cdr fields) (+ i 1) + (cons `(define ,(car fields) ,i) r)))))) + +;of + +(defmacro-preproc 'of + (lambda (r i . z) + (cond ((null? z) `(vector-ref ,r ,i)) + ((and (eq? i '/) (= (length z) 1)) + `(string-ref ,r ,(car z))) + (else `(of (vector-ref ,r ,i) ,@z))))) + +;setf + +(defmacro-preproc 'setf + (lambda (l r) + (if (symbol? l) `(set! ,l ,r) + (let ((a (car l))) + (if (eq? a 'list-ref) + `(set-car! (list-tail ,@(cdr l)) ,r) + `(,(cond ((eq? a 'list-ref) 'list-set!) + ((eq? a 'string-ref) 'string-set!) + ((eq? a 'vector-ref) 'vector-set!) + ((eq? a 'of) 'the-setter-for-of) + (else + (error "(setf ~s ~s) is ill-formed." l r))) + ,@(cdr l) ,r)))))) + +;the-setter-for-of + +(defmacro-preproc 'the-setter-for-of + (lambda (r i j . z) + (cond ((null? z) `(vector-set! ,r ,i ,j)) + ((and (eq? i '/) (= (length z) 1)) + `(string-set! ,r ,j ,(car z))) + (else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z))))) + +;eval-{if,unless} + +(defmacro-preproc 'eval-if + (lambda (dialects . body) + (if (memq dialect dialects) + (if (= (length body) 1) (car body) + `(begin ,@body)) + `#f))) + +(defmacro-preproc 'eval-unless + (lambda (dialects . body) + (if (not (memq dialect dialects)) + (if (= (length body) 1) (car body) + `(begin ,@body)) + `#f))) + +;func{tion, all} + +(defmacro-preproc 'function + (lambda (x) + `,x)) + +(defmacro-preproc 'funcall + (lambda (f . args) + `(,f ,@args))) diff --git a/collects/slatex/slatex-code/proctex.scm b/collects/slatex/slatex-code/proctex.scm new file mode 100644 index 00000000..692bec75 --- /dev/null +++ b/collects/slatex/slatex-code/proctex.scm @@ -0,0 +1,245 @@ +;proctex.scm +;SLaTeX v. 2.4 +;Implements SLaTeX's piggyback to LaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1999 + +(eval-if (cl) + (eval-within slatex + (defun ignore2 (i ii) + (declare (ignore i ii)) + (values)))) + +(eval-unless (cl) + (eval-within slatex + (define slatex::ignore2 + (lambda (i ii) + ;ignores its two arguments + 'void)))) + +(eval-within slatex + + (defvar slatex::version-number "2.4w") + + (define slatex::disable-slatex-temply + (lambda (in) + ;tell slatex that it should not process slatex commands till + ;the enabling control sequence is called + (set! *slatex-enabled?* #f) + (set! *slatex-reenabler* (read-grouped-latexexp in)))) + + (define slatex::enable-slatex-again + (lambda () + ;tell slatex to resume processing slatex commands + (set! *slatex-enabled?* #t) + (set! *slatex-reenabler* "UNDEFINED"))) + + (define slatex::add-to-slatex-db + (lambda (in categ) + ;some scheme identifiers to be added to the token category categ + (if (memq categ '(keyword constant variable)) + (slatex::add-to-slatex-db-basic in categ) + (slatex::add-to-slatex-db-special in categ)))) + + (define slatex::add-to-slatex-db-basic + (lambda (in categ) + ;read the following scheme identifiers and add them to the + ;token category categ + (let ((setter (cond ((eq? categ 'keyword) (function set-keyword)) + ((eq? categ 'constant) (function set-constant)) + ((eq? categ 'variable) (function set-variable)) + (else (error "add-to-slatex-db-basic: ~ +Unknown category ~s." categ)))) + (ids (read-grouped-schemeids in))) + (for-each setter ids)))) + + (define slatex::add-to-slatex-db-special + (lambda (in what) + ;read the following scheme identifier(s) and either + ;enable/disable its special-symbol status + (let ((ids (read-grouped-schemeids in))) + (cond ((eq? what 'unsetspecialsymbol) + (for-each (function unset-special-symbol) ids)) + ((eq? what 'setspecialsymbol) + (if (not (= (length ids) 1)) + (error "add-to-slatex-db-special: ~ +\\setspecialsymbol takes one arg exactly.")) + (let ((transl (read-grouped-latexexp in))) + (set-special-symbol (car ids) transl))) + (else (error "add-to-slatex-db-special: ~ +Unknown command ~s." what)))))) + + (define slatex::process-slatex-alias + (lambda (in what which) + ;add/remove a slatex control sequence name + (let ((triggerer (read-grouped-latexexp in))) + (case which + ((intext) + (set! *intext-triggerers* + (funcall what triggerer *intext-triggerers* + (function string=?)))) + ((resultintext) + (set! *resultintext-triggerers* + (funcall what triggerer *resultintext-triggerers* + (function string=?)))) + ((display) + (set! *display-triggerers* + (funcall what triggerer *display-triggerers* + (function string=?)))) + ((response) + (set! *response-triggerers* + (funcall what triggerer *response-triggerers* + (function string=?)))) + ((respbox) + (set! *respbox-triggerers* + (funcall what triggerer *respbox-triggerers* + (function string=?)))) + ((box) + (set! *box-triggerers* + (funcall what triggerer *box-triggerers* + (function string=?)))) + ((input) + (set! *input-triggerers* + (funcall what triggerer *input-triggerers* + (function string=?)))) + ((region) + (set! *region-triggerers* + (funcall what triggerer *region-triggerers* + (function string=?)))) + ((mathescape) + (if (not (= (string-length triggerer) 1)) + (error "process-slatex-alias: ~ +Math escape should be character.")) + (set! *math-triggerers* + (funcall what (string-ref triggerer 0) + *math-triggerers* (function char=?)))) + (else (error "process-slatex-alias: +Unknown command ~s." which)))))) + + (define slatex::decide-latex-or-tex + (lambda (latex?) + ;create a junk file if the file is in plain tex rather + ;than latex; this is used afterward to call the right + ;command, i.e., latex or tex + (set! *latex?* latex?) + (let ((pltexchk.jnk "pltexchk.jnk")) + (if (file-exists? pltexchk.jnk) (delete-file pltexchk.jnk)) + (if (not *latex?*) + (call-with-output-file pltexchk.jnk + (lambda (outp) + (display 'junk outp) + (newline outp))))))) + + (define slatex::process-include-only + (lambda (in) + ;remember the files mentioned by \includeonly + (set! *include-onlys* '()) + (for-each + (lambda (filename) + (let ((filename (full-texfile-name filename))) + (if filename + (set! *include-onlys* + (adjoin filename *include-onlys* + (function string=?)))))) + (read-grouped-commaed-filenames in)))) + + (define slatex::process-documentstyle + (lambda (in) + ;process the .sty files corresponding to the documentstyle options + (eat-tex-whitespace in) + (if (char=? (peek-char in) #\[) + (for-each + (lambda (filename) + (fluid-let ((*slatex-in-protected-region?* #f)) + (slatex::process-tex-file + (string-append filename ".sty")))) + (read-bktd-commaed-filenames in))))) + + (define slatex::process-documentclass + (lambda (in) + (eat-bktd-text in) + (eat-grouped-text in))) + + (define slatex::process-case-info + (lambda (in) + ;find out and tell slatex if the scheme tokens that differ + ;only by case should be treated identical or not + (let ((bool (read-grouped-latexexp in))) + (set! *slatex-case-sensitive?* + (cond ((string-ci=? bool "true") #t) + ((string-ci=? bool "false") #f) + (else (error "process-case-info: ~ +\\schemecasesensitive's arg should be true or false."))))))) + + (defvar slatex::seen-first-command? #f) + + (define slatex::process-main-tex-file + (lambda (filename) + ;kick off slatex on the main .tex file filename + (display "SLaTeX v. ") + (display version-number) + (newline) + (set! primary-aux-file-count -1) + (set! *slatex-separate-includes?* #f) + (if (or (not *texinputs-list*) (null? *texinputs-list*)) + (set! *texinputs-list* + (if *texinputs* (path-to-list *texinputs*) + '("")))) + (let ((file-hide-file "xZfilhid.tex")) + (if (file-exists? file-hide-file) (delete-file file-hide-file)) + (if (memq *op-sys* '(dos os2fat)) + (call-with-output-file file-hide-file + (lambda (out) + (display "\\def\\filehider{x}" out) + (newline out)) + 'text))) + (display "typesetting code") + (set! *tex-calling-directory* (directory-namestring filename)) + (set! subjobname (basename filename)) + (set! seen-first-command? #f) + (process-tex-file filename) + (display "done") + (newline))) + + (define slatex::dump-intext + (lambda (in out) + (let* ((write-char (if out (function write-char) (function ignore2))) + (delim-char (begin (eat-whitespace in) (read-char in))) + (delim-char + (cond ((char=? delim-char #\{) #\}) + (else delim-char)))) + (if (eof-object? delim-char) + (error "dump-intext: Expected delimiting character ~ +but found eof.")) + (let loop () + (let ((c (read-char in))) + (if (eof-object? c) + (error "dump-intext: Found eof inside Scheme code.")) + (if (char=? c delim-char) 'done + (begin (funcall write-char c out) (loop)))))))) + + (define slatex::dump-display + (lambda (in out ender) + (eat-tabspace in) + (let ((write-char (if out (function write-char) (function ignore2))) + (ender-lh (string-length ender)) (c (peek-char in))) + (if (eof-object? c) + (error "dump-display: Found eof inside displayed code.")) + (if (char=? c #\newline) (read-char in)) + (let loop ((i 0)) + (if (= i ender-lh) 'done + (let ((c (read-char in))) + (if (eof-object? c) + (error "dump-display: Found eof inside displayed code.")) + (if (char=? c (string-ref ender i)) + (loop (+ i 1)) + (let loop2 ((j 0)) + (if (< j i) + (begin + (funcall write-char (string-ref ender j) out) + (loop2 (+ j 1))) + (begin + (funcall write-char c out) + (loop 0))))))))))) + + ;continued on proctex2.scm + ) diff --git a/collects/slatex/slatex-code/proctex2.scm b/collects/slatex/slatex-code/proctex2.scm new file mode 100644 index 00000000..c80f7338 --- /dev/null +++ b/collects/slatex/slatex-code/proctex2.scm @@ -0,0 +1,451 @@ +;proctex2.scm +;SLaTeX v. 2.4 +;Implements SLaTeX's piggyback to LaTeX +;...continued from proctex.scm +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-within slatex + + (defvar slatex::debug? #f) + + (define slatex::process-tex-file + (lambda (raw-filename) + ;call slatex on the .tex file raw-filename + (if debug? + (begin (display "begin ") + (display raw-filename) + (newline))) + (let ((filename (full-texfile-name raw-filename))) + (if (not filename) ;didn't find it + (begin (display "[") + (display raw-filename) + (display "]") (force-output)) + (call-with-input-file filename + (lambda (in) + (let ((done? #f)) + (let loop () + (if done? 'exit-loop + (begin + (let ((c (read-char in))) + (cond + ((eof-object? c) (set! done? #t)) + ((char=? c #\%) (eat-till-newline in)) + ((char=? c #\\) + (let ((cs (read-ctrl-seq in))) + (if (not seen-first-command?) + (begin + (set! seen-first-command? #t) + (decide-latex-or-tex + (or + (string=? cs "documentstyle") + (string=? cs "documentclass") + (string=? cs "NeedsTeXFormat") + )))) + (cond + ((not *slatex-enabled?*) + (if (string=? cs *slatex-reenabler*) + (enable-slatex-again))) + ((string=? cs "slatexignorecurrentfile") + (set! done? #t)) + ((string=? cs "slatexseparateincludes") + (if *latex?* + (set! *slatex-separate-includes?* #t))) + ((string=? cs "slatexdisable") + (disable-slatex-temply in)) + ((string=? cs "begin") + (eat-tex-whitespace in) + (if (eqv? (peek-char in) #\{) + (let ((cs (read-grouped-latexexp in))) + (cond + ((member cs *display-triggerers*) + (slatex::trigger-scheme2tex + 'envdisplay in cs)) + ((member cs *response-triggerers*) + (trigger-scheme2tex 'envresponse + in cs)) + ((member cs *respbox-triggerers*) + (trigger-scheme2tex 'envrespbox + in cs)) + ((member cs *box-triggerers*) + (trigger-scheme2tex 'envbox + in cs)) + ((member cs *top-box-triggerers*) + (trigger-scheme2tex 'envtopbox + in cs)) + ((member cs *region-triggerers*) + (slatex::trigger-region + 'envregion in cs)))))) + ((member cs *intext-triggerers*) + (trigger-scheme2tex 'intext in #f)) + ((member cs *resultintext-triggerers*) + (trigger-scheme2tex 'resultintext in #f)) + ((member cs *display-triggerers*) + (trigger-scheme2tex 'plaindisplay + in cs)) + ((member cs *response-triggerers*) + (trigger-scheme2tex 'plainresponse + in cs)) + ((member cs *respbox-triggerers*) + (trigger-scheme2tex 'plainrespbox + in cs)) + ((member cs *box-triggerers*) + (trigger-scheme2tex 'plainbox + in cs)) + ((member cs *region-triggerers*) + (trigger-region 'plainregion + in cs)) + ((member cs *input-triggerers*) + (slatex::process-scheme-file + (read-filename in))) + ((string=? cs "input") + (let ((f (read-filename in))) + (if (not (string=? f "")) + (fluid-let + ((*slatex-in-protected-region?* + #f)) + (process-tex-file f))))) + ((string=? cs "usepackage") + (fluid-let ((*slatex-in-protected-region?* + #f)) + (process-tex-file + (string-append (read-filename in) + ".sty")))) + ((string=? cs "include") + (if *latex?* + (let ((f (full-texfile-name + (read-filename in)))) + (if (and f + (or (eq? *include-onlys* 'all) + (member f + *include-onlys*))) + (fluid-let + ((*slatex-in-protected-region?* + #f)) + (if *slatex-separate-includes?* + (fluid-let + ((subjobname + (basename f)) + (primary-aux-file-count + -1)) + (process-tex-file f)) + (process-tex-file f))))))) + ((string=? cs "includeonly") + (if *latex?* (process-include-only in))) + ((string=? cs "documentstyle") + (if *latex?* (process-documentstyle in))) + ((string=? cs "documentclass") + (if *latex?* (process-documentclass in))) + ((string=? cs "schemecasesensitive") + (process-case-info in)) + ((string=? cs "defschemetoken") + (process-slatex-alias + in (function adjoin) + 'intext)) + ((string=? cs "undefschemetoken") + (process-slatex-alias + in (function delete) + 'intext)) + ((string=? cs "defschemeresulttoken") + (process-slatex-alias + in (function adjoin) + 'resultintext)) + ((string=? cs "undefschemeresulttoken") + (process-slatex-alias + in (function delete) + 'resultintext)) + ((string=? cs "defschemeresponsetoken") + (process-slatex-alias + in (function adjoin) + 'response)) + ((string=? cs "undefschemeresponsetoken") + (process-slatex-alias + in (function delete) + 'response)) + ((string=? cs "defschemeresponseboxtoken") + (process-slatex-alias + in (function adjoin) + 'respbox)) + ((string=? cs "undefschemeresponseboxtoken") + (process-slatex-alias + in (function delete) + 'respbox)) + ((string=? cs "defschemedisplaytoken") + (process-slatex-alias + in (function adjoin) + 'display)) + ((string=? cs "undefschemedisplaytoken") + (process-slatex-alias + in (function delete) + 'display)) + ((string=? cs "defschemeboxtoken") + (process-slatex-alias + in (function adjoin) + 'box)) + ((string=? cs "undefschemeboxtoken") + (process-slatex-alias + in (function delete) + 'box)) + ((string=? cs "defschemeinputtoken") + (process-slatex-alias + in (function adjoin) + 'input)) + ((string=? cs "undefschemeinputtoken") + (process-slatex-alias + in (function delete) + 'input)) + ((string=? cs "defschemeregiontoken") + (process-slatex-alias + in (function adjoin) + 'region)) + ((string=? cs "undefschemeregiontoken") + (process-slatex-alias in + (function delete) + 'region)) + ((string=? cs "defschememathescape") + (process-slatex-alias in + (function adjoin) + 'mathescape)) + ((string=? cs "undefschememathescape") + (process-slatex-alias in + (function delete) + 'mathescape)) + ((string=? cs "setkeyword") + (add-to-slatex-db in 'keyword)) + ((string=? cs "setconstant") + (add-to-slatex-db in 'constant)) + ((string=? cs "setvariable") + (add-to-slatex-db in 'variable)) + ((string=? cs "setspecialsymbol") + (add-to-slatex-db in 'setspecialsymbol)) + ((string=? cs "unsetspecialsymbol") + (add-to-slatex-db in 'unsetspecialsymbol)) + ))))) + (loop)))))) + 'text))) + (if debug? + (begin (display "end ") + (display raw-filename) + (newline))) + )) + + (define slatex::process-scheme-file + (lambda (raw-filename) + ;typeset the scheme file raw-filename so that it can + ;be input as a .tex file + (let ((filename (full-scmfile-name raw-filename))) + (if (not filename) + (begin (display "process-scheme-file: ") + (display raw-filename) + (display " doesn't exist") + (newline)) + (let ((aux.tex (new-aux-file ".tex"))) + (display ".") (force-output) + (if (file-exists? aux.tex) (delete-file aux.tex)) + (call-with-input-file filename + (lambda (in) + (call-with-output-file aux.tex + (lambda (out) + (fluid-let ((*intext?* #f) + (*code-env-spec* "ZZZZschemedisplay")) + (scheme2tex in out))) + 'text)) + 'text) + (if *slatex-in-protected-region?* + (set! *protected-files* (cons aux.tex *protected-files*))) + (process-tex-file filename)))))) + + (define slatex::trigger-scheme2tex + (lambda (typ in env) + ;process the slatex command identified by typ; + ;env is the name of the environment + (let* ((aux (new-aux-file)) (aux.scm (string-append aux ".scm")) + (aux.tex (string-append aux ".tex"))) + (if (file-exists? aux.scm) (delete-file aux.scm)) + (if (file-exists? aux.tex) (delete-file aux.tex)) + (display ".") (force-output) + (call-with-output-file aux.scm + (lambda (out) + (cond ((memq typ '(intext resultintext)) (dump-intext in out)) + ((memq typ '(envdisplay envresponse envrespbox envbox envtopbox)) + (dump-display in out (string-append "\\end{" env "}"))) + ((memq typ '(plaindisplay plainresponse + plainrespbox plainbox)) + (dump-display in out (string-append "\\end" env))) + (else (error "trigger-scheme2tex: ~ +Unknown triggerer ~s." typ)))) + 'text) + (call-with-input-file aux.scm + (lambda (in) + (call-with-output-file aux.tex + (lambda (out) + (fluid-let + ((*intext?* (memq typ '(intext resultintext))) + (*code-env-spec* + (cond ((eq? typ 'intext) "ZZZZschemecodeintext") + ((eq? typ 'resultintext) + "ZZZZschemeresultintext") + ((memq typ '(envdisplay plaindisplay)) + "ZZZZschemedisplay") + ((memq typ '(envresponse plainresponse)) + "ZZZZschemeresponse") + ((memq typ '(envrespbox plainrespbox)) + "ZZZZschemeresponsebox") + ((memq typ '(envbox plainbox)) + "ZZZZschemebox") + ((memq typ '(envtopbox)) + "ZZZZschemetopbox") + (else (error "trigger-scheme2tex: ~ +Unknown triggerer ~s." typ))))) + (scheme2tex in out))) + 'text)) + 'text) + (if *slatex-in-protected-region?* + (set! *protected-files* (cons aux.tex *protected-files*))) + (if (memq typ '(envdisplay plaindisplay envbox plainbox envtopbox)) + (process-tex-file aux.tex)) + (delete-file aux.scm) + ))) + + (define slatex::trigger-region + (lambda (typ in env) + ;process a scheme region to create a in-lined file with + ;slatex output + (let ((aux.tex (new-primary-aux-file ".tex")) + (aux2.tex (new-secondary-aux-file ".tex"))) + (if (file-exists? aux2.tex) (delete-file aux2.tex)) + (if (file-exists? aux.tex) (delete-file aux.tex)) + (display ".") (force-output) + (fluid-let ((*slatex-in-protected-region?* #t) + (*protected-files* '())) + (call-with-output-file aux2.tex + (lambda (out) + (cond ((eq? typ 'envregion) + (dump-display in out (string-append "\\end{" env "}"))) + ((eq? typ 'plainregion) + (dump-display in out (string-append "\\end" env))) + (else (error "trigger-region: ~ +Unknown triggerer ~s." typ)))) + 'text) + (process-tex-file aux2.tex) + (set! *protected-files* (reverse! *protected-files*)) + (call-with-input-file aux2.tex + (lambda (in) + (call-with-output-file aux.tex + (lambda (out) + (slatex::inline-protected-files in out)) + 'text)) + 'text) + (delete-file aux2.tex) + )))) + + (define slatex::inline-protected-files + (lambda (in out) + ;inline all the protected files in port in into port out + (let ((done? #f)) + (let loop () + (if done? 'exit-loop + (begin + (let ((c (read-char in))) + (cond ((eof-object? c) + ;(display "{}" out) + (set! done? #t)) + ((or (char=? c *return*) (char=? c #\newline)) + (let ((c2 (peek-char in))) + (if (not (eof-object? c2)) + (write-char c out)))) + ((char=? c #\%) + (write-char c out) (newline out) + (eat-till-newline in)) + ((char=? c #\\) + (let ((cs (read-ctrl-seq in))) + (cond + ((string=? cs "begin") + (let ((cs (read-grouped-latexexp in))) + (cond ((member cs *display-triggerers*) + (slatex::inline-protected + 'envdisplay in out cs)) + ((member cs *response-triggerers*) + (inline-protected + 'envresponse in out cs)) + ((member cs *respbox-triggerers*) + (inline-protected + 'envrespbox in out cs)) + ((member cs *box-triggerers*) + (inline-protected 'envbox in out cs)) + ((member cs *top-box-triggerers*) + (inline-protected 'envtopbox in out cs)) + ((member cs *region-triggerers*) + (inline-protected + 'envregion in out cs)) + (else + (display "\\begin{" out) + (display cs out) + (display "}" out))))) + ((member cs *intext-triggerers*) + (inline-protected 'intext in out #f)) + ((member cs *resultintext-triggerers*) + (inline-protected 'resultintext in out #f)) + ((member cs *display-triggerers*) + (inline-protected 'plaindisplay in out cs)) + ((member cs *response-triggerers*) + (inline-protected 'plainresponse in out cs)) + ((member cs *respbox-triggerers*) + (inline-protected 'plainrespbox in out cs)) + ((member cs *box-triggerers*) + (inline-protected 'plainbox in out cs)) + ((member cs *region-triggerers*) + (inline-protected 'plainregion in out cs)) + ((member cs *input-triggerers*) + (inline-protected 'input in out cs)) + (else + (display "\\" out) + (display cs out))))) + (else (write-char c out)))) + (loop))))))) + + (define slatex::inline-protected + (lambda (typ in out env) + (cond ((eq? typ 'envregion) + (display "\\begin{" out) + (display env out) + (display "}" out) + (dump-display in out (string-append "\\end{" env "}")) + (display "\\end{" out) + (display env out) + (display "}" out)) + ((eq? typ 'plainregion) + (display "\\" out) + (display env out) + (dump-display in out (string-append "\\end" env)) + (display "\\end" out) + (display env out)) + (else (let ((f (car *protected-files*))) + (set! *protected-files* (cdr *protected-files*)) + (call-with-input-file f + (lambda (in) + (inline-protected-files in out)) + 'text) + (delete-file f) + ) + (cond ((memq typ '(intext resultintext)) + (display "{}" out) + (dump-intext in #f)) + ((memq typ '(envrespbox envbox envtopbox)) + (if (not *latex?*) + (display "{}" out)) + (dump-display in #f + (string-append "\\end{" env "}"))) + ((memq typ '(plainrespbox plainbox)) + (display "{}" out) + (dump-display in #f + (string-append "\\end" env))) + ((memq typ '(envdisplay envresponse)) + (dump-display in #f + (string-append "\\end{" env "}"))) + ((memq typ '(plaindisplay plainresponse)) + (dump-display in #f (string-append "\\end" env))) + ((eq? typ 'input) + (read-filename in)) ;and throw it away + (else (error "inline-protected: ~ +Unknown triggerer ~s." typ))))))) + ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/s4.scm b/collects/slatex/slatex-code/s4.scm new file mode 100644 index 00000000..b93e62ff --- /dev/null +++ b/collects/slatex/slatex-code/s4.scm @@ -0,0 +1,102 @@ +;s4.scm +;SLaTeX v. 2.3 +;Making dialect meet R5RS spec +;(includes optimizing for Chez 4.0a+) +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-if (chez) + (eval-when (compile load eval) + (if (not (bound? 'optimize-level)) ;do only for old Chezs + (let ((cwif call-with-input-file) + (cwof call-with-output-file)) + (set! call-with-input-file + (lambda (f p) + (cwif f (lambda (pt) + (p pt) + (close-input-port pt))))) + (set! call-with-output-file + (lambda (f p) + (cwof f (lambda (pt) + (p pt) + (close-output-port pt))))))))) + +(eval-if (chez) + (if (bound? 'optimize-level) (optimize-level 3))) + +(eval-if (cl) + (eval-within slatex + + (defun member (x s) + (declare (list s)) + (global-member x s :test (function equal))) + + (defun assoc (x s) + (declare (list s)) + (global-assoc x s :test (function equal))) + + (defun number->string (n &optional (b 10)) + (declare (number n)) + (write-to-string n :base b)) + + (defun string->number (s &optional (b 10)) + (declare (global-string s)) + (let ((*read-base* b)) + (let ((n (read-from-string s))) + (if (numberp n) n nil)))) + + (defun char-whitespace? (c) + (declare (character c)) + (or (char= c #\space) (char= c #\tab) + (not (graphic-char-p c)))) + + (defun make-string (n &optional (c #\space)) + (declare (number n)) + (global-make-string n :initial-element c)) + + (defun string (&rest z) + (concatenate 'global-string z)) + + (defun string-append (&rest z) + (apply (function concatenate) 'global-string z)) + + (defun string->list (s) + (declare (global-string s)) + (concatenate 'list s)) + + (defun list->string (l) + (declare (list l)) + (concatenate 'global-string l)) + + (defun make-vector (n &optional x) + (declare (number n)) + (make-array (list n) :initial-element x)) + + (defun vector->list (v) + (declare (vector v)) + (concatenate 'vector v)) + + (defun list->vector (l) + (declare (list l)) + (concatenate 'vector l)) + + (defun call-with-input-file (f p) + (with-open-file (i f :direction :input) + (funcall p i))) + + (defun call-with-output-file (f p) + (with-open-file (o f :direction :output) + (funcall p o))) + + (defun read (&optional p) + (global-read p nil :eof-object)) + + (defun read-char (&optional p) + (global-read-char p nil :eof-object)) + + (defun peek-char (&optional p) + (global-peek-char nil p nil :eof-object)) + + (defun eof-object? (v) + (eq v :eof-object)) + + )) diff --git a/collects/slatex/slatex-code/seqprocs.scm b/collects/slatex/slatex-code/seqprocs.scm new file mode 100644 index 00000000..5336fa68 --- /dev/null +++ b/collects/slatex/slatex-code/seqprocs.scm @@ -0,0 +1,193 @@ +;seqprocs.scm +;SLaTeX v. 2.3 +;Sequence routines +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-if (cscheme) + (eval-within slatex + (define slatex::some + (lambda (f l) (there-exists? l f))))) + +(eval-unless (chez cl cscheme mzscheme) + (eval-within slatex + (define slatex::some + (lambda (f l) + ;returns nonfalse iff f is true of at least one element in l; + ;this nonfalse value is that given by the first such element in l; + ;only one argument list supported + (let loop ((l l)) + (if (null? l) #f + (or (f (car l)) (loop (cdr l))))))))) + +(eval-within slatex + + (define slatex::ormapcdr + (lambda (f l) + ;apply f to successive cdrs of l, returning + ;immediately when an application is true. + ;only one argument list supported + (let loop ((l l)) + (if (null? l) #f + (or (funcall f l) (loop (cdr l))))))) + + (define slatex::list-prefix? + (lambda (pfx l) + ;tests if list pfx is a prefix of list l + (cond ((null? pfx) #t) + ((null? l) #f) + ((eqv? (car pfx) (car l)) (list-prefix? (cdr pfx) (cdr l))) + (else #f)))) + + (define slatex::string-suffix? + (lambda (sfx s) + ;tests if string sfx is a suffix of string s + (let ((sfx-len (string-length sfx)) (s-len (string-length s))) + (if (> sfx-len s-len) #f + (let loop ((i (- sfx-len 1)) (j (- s-len 1))) + (if (< i 0) #t + (and (char=? (string-ref sfx i) (string-ref s j)) + (loop (- i 1) (- j 1))))))))) + + ) + + + +(eval-unless (bigloo chez cl cscheme elk guile mzscheme pcsge stk scm) + (eval-within slatex + (define slatex::append! + (lambda (l1 l2) + ;destructively appends lists l1 and l2; + ;only two argument lists supported + (cond ((null? l1) l2) + ((null? l2) l1) + (else (let loop ((l1 l1)) + (if (null? (cdr l1)) + (set-cdr! l1 l2) + (loop (cdr l1)))) + l1)))))) + +(eval-unless (cl cscheme) + (eval-within slatex + (define slatex::mapcan + (lambda (f l) + ;maps f on l but splices (destructively) the results; + ;only one argument list supported + (let loop ((l l)) + (if (null? l) '() + (append! (f (car l)) (loop (cdr l))))))))) + +(eval-unless (bigloo chez cl cscheme elk mzscheme pcsge) + (eval-within slatex + (define slatex::reverse! + (lambda (s) + ;reverses list s inplace (i.e., destructively) + (let loop ((s s) (r '())) + (if (null? s) r + (let ((d (cdr s))) + (set-cdr! s r) + (loop d s)))))))) + +(eval-unless (cl) + (eval-within slatex + + (define slatex::lassoc + (lambda (x al eq) + (let loop ((al al)) + (if (null? al) #f + (let ((c (car al))) + (if (eq (car c) x) c + (loop (cdr al)))))))) + + (define slatex::lmember + (lambda (x l eq) + (let loop ((l l)) + (if (null? l) #f + (if (eq (car l) x) l + (loop (cdr l))))))) + + (define slatex::delete + (lambda (x l eq) + (let loop ((l l)) + (cond ((null? l) l) + ((eq (car l) x) (loop (cdr l))) + (else (set-cdr! l (loop (cdr l))) + l))))) + + (define slatex::adjoin + (lambda (x l eq) + (if (lmember x l eq) l + (cons x l)))) + + (define slatex::delete-if + (lambda (p s) + (let loop ((s s)) + (cond ((null? s) s) + ((p (car s)) (loop (cdr s))) + (else (set-cdr! s (loop (cdr s))) + s))))) + + (define slatex::string-prefix? + (lambda (s1 s2 i) + ;Tests if s1 and s2 have the same first i chars. + ;Both s1 and s2 must be at least i long. + (let loop ((j 0)) + (if (= j i) #t + (and (char=? (string-ref s1 j) (string-ref s2 j)) + (loop (+ j 1))))))) + + (define slatex::sublist + (lambda (l i f) + ;finds the sublist of l from index i inclusive to index f exclusive + (let loop ((l (list-tail l i)) (k i) (r '())) + (cond ((>= k f) (reverse! r)) + ((null? l) + (slatex::error "sublist: List too small.")) + (else (loop (cdr l) (+ k 1) (cons (car l) r))))))) + + (define slatex::position-char + (lambda (c l) + ;finds the leftmost index of character-list l where character c occurs + (let loop ((l l) (i 0)) + (cond ((null? l) #f) + ((char=? (car l) c) i) + (else (loop (cdr l) (+ i 1))))))) + + (define slatex::string-position-right + (lambda (c s) + ;finds the rightmost index of string s where character c occurs + (let ((n (string-length s))) + (let loop ((i (- n 1))) + (cond ((< i 0) #f) + ((char=? (string-ref s i) c) i) + (else (loop (- i 1)))))))) + + )) + +(eval-if (cl) + (eval-within slatex + + (defun lassoc (x l eq) + (declare (list l)) + (global-assoc x l :test eq)) + + (defun lmember (x l eq) + (declare (list l)) + (global-member x l :test eq)) + + (defun delete (x l eq) + (declare (list l)) + (global-delete x l :test eq)) + + (defun adjoin (x l eq) + (declare (list l)) + (global-adjoin x l :test eq)) + + (defun string-prefix? (s1 s2 i) + (declare (global-string s1 s2) (integer i)) + (string= s1 s2 :end1 i :end2 i)) + + (defun string-position-right (c s) + (declare (character c) (global-string s)) + (position c s :test (function char=) :from-end t)) + + )) diff --git a/collects/slatex/slatex-code/slaconfg.lsp b/collects/slatex/slatex-code/slaconfg.lsp new file mode 100644 index 00000000..aaf86417 --- /dev/null +++ b/collects/slatex/slatex-code/slaconfg.lsp @@ -0,0 +1,103 @@ +;slaconfg.lsp +;Configures SLaTeX for Common Lisp on your system +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(set-dispatch-macro-character #\# #\T + #'(lambda (p ig ig2) + (declare (ignore ig ig2)) + t)) + +(set-dispatch-macro-character #\# #\F + #'(lambda (p ig ig2) + (declare (ignore ig ig2)) + nil)) + +(defvar *slatex-directory* (directory-namestring *load-pathname*)) + +(defvar dialect 'cl) +(defvar *op-sys*) + +(with-open-file (inp (concatenate 'string + *slatex-directory* + "config.dat") + :direction :input) + (read inp) ;ignore dialect info + (setq *op-sys* (read inp))) + +(if (not (member *op-sys* '(windows os2 unix dos os2fat mac-os))) + (setq *op-sys* 'other)) + +(load (merge-pathnames "preproc.lsp" *slatex-directory*)) + +(defvar list-of-slatex-files + (mapcar + #'(lambda (f) + (concatenate 'string *slatex-directory* f)) + (list + "s4.scm" + "seqprocs.scm" + "fileproc.scm" + "lerror.scm" + "defaults.scm" + "structs.scm" + "helpers.scm" + "peephole.scm" + "codeset.scm" + "pathproc.scm" + "texread.scm" + "proctex.scm" + "proctex2.scm"))) + +(format t "~&Beginning configuring SLaTeX for Common Lisp on ~a -- ~ + wait..." *op-sys*) + +(defvar outfile (concatenate 'string *slatex-directory* + #+(or mcl clisp) "slatexsrc.scm" + #-(or mcl clisp) "slatex.scm")) + +(if (probe-file outfile) (delete-file outfile)) + +(with-open-file (o outfile :direction :output) + (format o + ";slatex.scm file generated for Common Lisp, ~a~%~ + ;(c) Dorai Sitaram, Rice U., 1991, 1994~%" + *op-sys*) + + #-gcl + (print `(defpackage slatex (:use cl)) o) + (print `(in-package :slatex) o) + (print `(defvar *op-sys* ',*op-sys*) o) + + (dolist (f list-of-slatex-files) + + (format t "~&~a...~%" f) + + (format o "~%~%;~a~%" f) + (with-open-file (i f :direction :input) + (loop + (let ((x (read i nil :eof))) + (if (eq x :eof) (return)) + (let ((xm (expand-macrocalls x))) + (cond ((not xm) nil) + ((and (consp xm) (eq (car xm) 'progn)) + (dolist (y (cdr xm)) + (if y (pprint y o)))) + (t (pprint xm o))))))))) + +#+(or mcl clisp) +(progn + (format t "~&Getting compiled version...~%") + (compile-file outfile :output-file + (concatenate 'string *slatex-directory* + "slatex.scm")) + (format t "~&Finished compilation~%")) + +(format t + "~&Finished configuring SLaTeX for your machine. + +Read install for details on + +1. which paths to place the SLaTeX files in; + +2. how to modify the given batch file or shell script +that invokes SLaTeX.~%~%") diff --git a/collects/slatex/slatex-code/slaconfg.scm b/collects/slatex/slatex-code/slaconfg.scm new file mode 100644 index 00000000..81ea0879 --- /dev/null +++ b/collects/slatex/slatex-code/slaconfg.scm @@ -0,0 +1,155 @@ +;slaconfg.scm +;Configures SLaTeX for your Scheme +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(define dialect 'forward) +(define *op-sys* 'forward) + +(call-with-input-file "config.dat" + (lambda (p) + (set! dialect (read p)) + (set! *op-sys* (read p)))) + +(if (not (memq dialect + '(bigloo chez cscheme elk guile mzscheme pcsge schemetoc scm + stk umbscheme vscm other))) + (set! dialect 'other)) + +(if (not (memq *op-sys* '(windows os2 unix dos os2fat mac-os))) + (set! *op-sys* 'other)) + +(load "preproc.scm") + +(define list-of-slatex-files + (list + "s4.scm" + "seqprocs.scm" + "fileproc.scm" + "lerror.scm" + "defaults.scm" + "structs.scm" + "helpers.scm" + "peephole.scm" + "codeset.scm" + "pathproc.scm" + "texread.scm" + "proctex.scm" + "proctex2.scm")) + +(display "Beginning configuring SLaTeX for ") +(display dialect) +(display " on ") +(display *op-sys*) +(display " -- wait...") +(newline) + +(define outfile + (if (memq dialect '(bigloo chez mzscheme)) "slatexsrc.scm" "slatex.scm")) + +(cond ((memq dialect '(bigloo chez cscheme guile mzscheme pcsge scm)) + (if (file-exists? outfile) + (delete-file outfile))) + (else + (newline) + (display "If configuring fails following this sentence, ") + (newline) + (display "you most likely already have a slatex.scm in the ") + (display "current directory.") + (newline) + (display "Delete it and retry.") + (newline))) + +(define prettyp +;pretty-printer -- not really needed, so use write for dialects +;that don't have it + (case dialect + ((bigloo) pp) + ((chez) pretty-print) +; ((scm) (if (defined? pretty-print) pretty-print write)) + (else write))) + +(call-with-output-file outfile + (lambda (o) + ;;begin banner + (display ";slatex.scm file generated for " o) + (display dialect o) + (display ", " o) + (display *op-sys* o) + (newline o) + (display ";(c) Dorai Sitaram, Rice U., 1991, 1994" o) + (newline o) (newline o) + ;;end banner + + ;(if (eq? dialect 'bigloo) + ;(write `(module slatex (main slatex::process-main-tex-file)) o)) + + (write `(define slatex::*op-sys* ',*op-sys*) o) + (newline o) + + (for-each + (lambda (f) + + (newline) + (display f) (display "...") + + (newline o) + (display ";" o) + (display f o) + (newline o) + (newline o) + (call-with-input-file f + (lambda (i) + (let loop () + (let ((x (read i))) + (if (not (eof-object? x)) + (let ((xm (expand-macrocalls x))) + (cond ((not xm)) + ((and (pair? xm) (eq? (car xm) 'begin)) + (for-each + (lambda (y) + (if y (begin (prettyp y o) + (newline o)))) + (cdr xm))) + (else (prettyp xm o) (newline o))) + (loop)))))))) + list-of-slatex-files))) + +(if (eq? dialect 'mzscheme) + (require-library "compile.ss")) + +(case dialect + ((bigloo) + (newline) + ;can't get bigloo to compile + ;(display "Getting compiled version for Bigloo...") + (display "Couldn't get Bigloo to compile SLaTeX. Using source for now.") + (system "cp -p slatexsrc.scm slatex.scm") + (newline) + ;(system "bigloo -O -v -o SLaTeX slatex.scm") + ;(system "rm slatex.o") + ;(display "Finished compilation (executable is named SLaTeX)") + ;(newline) + ) + ((chez mzscheme) + (newline) + (display "Getting compiled version...") + (newline) + (compile-file "slatexsrc.scm" "slatex.scm") + ;;(delete-file "slatexsrc.scm") + (display "Finished compilation"))) + +(newline) +(newline) +(display "Finished configuring the SLaTeX Scheme file for your machine") +(newline) +(display "Read \"install\" for details on") +(newline) +(newline) +(display "1. which paths to place the SLaTeX files in") +(newline) +(newline) +(display "2. how to use the batch file, shell script, or Scheme script") +(newline) +(display "that invokes SLaTeX") +(newline) +(newline) diff --git a/collects/slatex/slatex-code/slatex.sty b/collects/slatex/slatex-code/slatex.sty new file mode 100644 index 00000000..522640c9 --- /dev/null +++ b/collects/slatex/slatex-code/slatex.sty @@ -0,0 +1,569 @@ +% slatex.sty +% SLaTeX v. 2.4 +% style file to be used in (La)TeX when using SLaTeX +% (c) Dorai Sitaram, Rice U., 1991, 1999 + +\def\slatexversion{2.4w} + +% This file (or a soft link to it) should be in some +% directory in your TEXINPUTS path (i.e., the one +% (La)TeX scours for \input or \documentstyle option +% files). + +% Do not attempt to debug this file, since the results +% are not transparent just to (La)TeX. The Scheme part +% of SLaTeX depends on information laid out here -- so +% (La)TeX-minded debugging of this file will almost +% inevitably sabotage SLaTeX. + +% It's possible you don't find the default style set +% out here appealing: e.g., you may want to change the +% positioning of displayed code; change the fonts for +% keywords, constants, and variables; add new keywords, +% constants, and variables; use your names instead of +% the provided \scheme, [\begin|\end]{schemedisplay}, +% [\begin|\end]{schemebox}, (or \[end]schemedisplay, +% \[end]schemebox for TeX), which might be seem too +% long or unmnemonic, and many other things. The clean +% way to do these things is outlined in the +% accompanying manual, slatxdoc.tex. This way is both +% easier than messing with this .sty file, and safer +% since you will not unwittingly break SLaTeX. + +%%% + +% to prevent loading slatex.sty more than once + +\ifx\slatexignorecurrentfile\UNDEFINED +\else\endinput\fi + +% use \slatexignorecurrentfile to disable slatex for +% the current file. (Unstrangely, the very definition +% disables slatex for the rest of _this_ file, slatex.sty.) + +\def\slatexignorecurrentfile{} + +% checking whether we're using LaTeX or TeX? + +\newif\ifusinglatex +\ifx\newenvironment\UNDEFINED\usinglatexfalse\else\usinglatextrue\fi + +% make @ a letter for TeX +\ifusinglatex\relax\else +\edef\atcatcodebeforeslatex{\the\catcode`\@ } +\catcode`\@11 +\fi + +% identification of TeX/LaTeX style for schemedisplay. +% Do \defslatexenvstyle{tex} to get TeX environment +% style in LaTeX +\def\defslatexenvstyle#1{\gdef\slatexenvstyle{#1}} + +\ifusinglatex\defslatexenvstyle{latex}\else\defslatexenvstyle{tex}\fi + +% TeX doesn't have sans-serif; use roman instead +\ifx\sf\UNDEFINED\let\sf\rm\fi + +% tabbing from plain TeX +% +\newif\ifus@ \newif\if@cr +\newbox\tabs \newbox\tabsyet \newbox\tabsdone +% +\def\cleartabs{\global\setbox\tabsyet\null \setbox\tabs\null} +\def\settabs{\setbox\tabs\null \futurelet\next\sett@b} +\let\+=\relax % in case this file is being read in twice +\def\sett@b{\ifx\next\+\let\next\relax + \def\next{\afterassignment\s@tt@b\let\next}% +\else\let\next\s@tcols\fi\next} +\def\s@tt@b{\let\next\relax\us@false\m@ketabbox} +\def\tabalign{\us@true\m@ketabbox} % non-\outer version of \+ +\outer\def\+{\tabalign} +\def\s@tcols#1\columns{\count@#1 \dimen@\hsize + \loop\ifnum\count@>\z@ \@nother \repeat} +\def\@nother{\dimen@ii\dimen@ \divide\dimen@ii\count@ + \setbox\tabs\hbox{\hbox to\dimen@ii{}\unhbox\tabs}% + \advance\dimen@-\dimen@ii \advance\count@\m@ne} +% +\def\m@ketabbox{\begingroup + \global\setbox\tabsyet\copy\tabs + \global\setbox\tabsdone\null + \def\cr{\@crtrue\crcr\egroup\egroup + \ifus@\unvbox\z@\lastbox\fi\endgroup + \setbox\tabs\hbox{\unhbox\tabsyet\unhbox\tabsdone}}% + \setbox\z@\vbox\bgroup\@crfalse + \ialign\bgroup&\t@bbox##\t@bb@x\crcr} +% +\def\t@bbox{\setbox\z@\hbox\bgroup} +\def\t@bb@x{\if@cr\egroup % now \box\z@ holds the column + \else\hss\egroup \global\setbox\tabsyet\hbox{\unhbox\tabsyet + \global\setbox\@ne\lastbox}% now \box\@ne holds its size + \ifvoid\@ne\global\setbox\@ne\hbox to\wd\z@{}% + \else\setbox\z@\hbox to\wd\@ne{\unhbox\z@}\fi + \global\setbox\tabsdone\hbox{\box\@ne\unhbox\tabsdone}\fi + \box\z@} +% finished (re)defining TeX's tabbing macros + +% above from plain.tex; was disabled in lplain.tex. Do +% not modify above unless you really know what you're +% up to. Make all changes you want to following code. +% The new env is preferable to LaTeX's tabbing env +% since latter accepts only a small number of tabs + +% following retrieves something like LaTeX's tabbing +% env without the above problem (it also creates a box +% for easy manipulation!) + +\def\lat@xtabbing{\begingroup +\def\={\cleartabs&} \def\>{&}% +\def\\{\cr\tabalign\lat@xtabbingleftmost}% +\tabalign\lat@xtabbingleftmost} +\def\endlat@xtabbing{\cr\endgroup} +\let\lat@xtabbingleftmost\relax + +% stuff for formating Scheme code + +\newskip\par@nlen \newskip\brack@tlen \newskip\quot@len +\newskip\h@lflambda + +\newbox\garb@ge +\def\s@ttowidth#1#2{\setbox\garb@ge\hbox{#2}#1\wd\garb@ge\relax} + +\s@ttowidth\par@nlen{$($} % size of paren +\s@ttowidth\brack@tlen{$[$} % size of bracket +\s@ttowidth\quot@len{'} % size of quote indentation +\s@ttowidth\h@lflambda{ii} % size of half of lambda indentation + +\def\PRN{\hskip\par@nlen} % these are used by SLaTeX's codesetter +\def\BKT{\hskip\brack@tlen} +\def\QUO{\hskip\quot@len} +\def\HL{\hskip\h@lflambda} + +\newskip\abovecodeskip \newskip\belowcodeskip +\newskip\leftcodeskip \newskip\rightcodeskip + +% the following default assignments give a flushleft +% display + +\abovecodeskip=\medskipamount \belowcodeskip=\medskipamount +\leftcodeskip=0pt \rightcodeskip=0pt + +% adjust above,below,left,right codeskip's to personal +% taste + +% for centered displays +% +% \leftcodeskip=0pt plus 1fil +% \rightcodeskip=0pt plus 1fil +% +% if \rightcodeskip != 0pt, pagebreaks within Scheme +% blocks in {schemedisplay} are disabled + +\let\checkforfollpar1 +\def\noindentifnofollpar{\ifx\checkforfollpar0\let\next\relax + \else\ifusinglatex\let\next\@endparenv + \else\let\next\noindentifnofollparI\fi\fi\next} +\def\noindentifnofollparI{\futurelet\next\noindentifnofollparII} +\def\noindentifnofollparII{\ifx\next\par\else\noindent\ignorespaces\fi} + +% the following are the default font assignments for +% words in code. Change them to suit personal taste + +\def\keywordfont#1{{\bf #1}} +\def\variablefont#1{{\it #1\/}} +\def\constantfont#1{{\sf #1}} +\def\datafont#1{\constantfont{#1}} + +\let\schemecodehook\relax +\let\ZZZZschemecodehook\relax + +%program listings that allow page breaks but +%can't be centered + +\def\ZZZZschemedisplay{\edef\thez@skip{\the\z@skip}% + \edef\@tempa{\the\rightcodeskip}% + \ifx\@tempa\thez@skip\let\next\ZZZZschemeprogram + \else\let\next\ZZZZschemeprogramII\fi\next} + +\def\endZZZZschemedisplay{\edef\thez@skip{\the\z@skip}% + \edef\@tempa{\the\rightcodeskip}% + \ifx\@tempa\thez@skip\let\next\endZZZZschemeprogram + \else\let\next\endZZZZschemeprogramII\fi\next} + +\def\ZZZZschemeprogram{\vskip\abovecodeskip + \begingroup + \schemecodehook\ZZZZschemecodehook + \frenchspacing + \let\sy=\keywordfont \let\cn=\constantfont + \let\va=\variablefont \let\dt=\datafont + \def\lat@xtabbingleftmost{\hskip\leftskip\hskip\leftcodeskip\relax}% + \lat@xtabbing} + +\def\endZZZZschemeprogram{\endlat@xtabbing + \endgroup + \vskip\belowcodeskip + \noindentifnofollpar} + +\def\ZZZZschemeprogramII{\vskip\abovecodeskip + \begingroup + \noindent + %\ZZZZschemecodehook\schemecodehook %\ZZZZschemebox already has it + \hskip\leftcodeskip + \ZZZZschemebox} + +\def\endZZZZschemeprogramII{\endZZZZschemebox + \hskip\rightcodeskip + \endgroup + \vskip\belowcodeskip + \noindentifnofollpar} + +\def\ZZZZschemeresponse{\ZZZZschemecodehookforresult + \ZZZZschemedisplay} +\let\endZZZZschemeresponse\endZZZZschemedisplay + +% + +\def\ZZZZschemebox{% + \leavevmode\hbox\bgroup\vbox\bgroup + \schemecodehook\ZZZZschemecodehook + \frenchspacing + \let\sy=\keywordfont \let\cn=\constantfont + \let\va=\variablefont \let\dt=\datafont + \lat@xtabbing} +\def\endZZZZschemebox{\endlat@xtabbing +\egroup\egroup\ignorespaces} + +\def\ZZZZschemeresponsebox{\ZZZZschemecodehookforresult + \ZZZZschemebox} +\let\endZZZZschemeresponsebox\endZZZZschemebox + +% schemetopbox : added by robby/jbc 2000 + +\def\ZZZZschemetopbox{% + \leavevmode\hbox\bgroup\vtop\bgroup + \schemecodehook\ZZZZschemecodehook + \frenchspacing + \let\sy=\keywordfont \let\cn=\constantfont + \let\va=\variablefont \let\dt=\datafont + \lat@xtabbing} +\def\endZZZZschemetopbox{\endlat@xtabbing +\egroup\egroup\ignorespaces} + +%in-text + +\def\ZZZZschemecodeintext{\begingroup + \schemecodehook\ZZZZschemecodehook + \frenchspacing + \let\sy\keywordfont \let\cn\constantfont + \let\va\variablefont \let\dt\datafont} + +\def\endZZZZschemecodeintext{\endgroup\ignorespaces} + +\def\ZZZZschemeresultintext{\ZZZZschemecodehookforresult + \ZZZZschemecodeintext} + +\let\endZZZZschemeresultintext\endZZZZschemecodeintext + +% + +\def\ZZZZschemecodehookforresult{% + \gdef\ZZZZschemecodehook{\let\keywordfont\constantfont + \let\variablefont\constantfont + \global\let\ZZZZschemecodehook\relax}} + +% \comm@nt...text... comments out +% TeX source analogous to +% \verb...text.... Sp. case: +% \comm@nt{...text...} == \comm@nt}...text...} + +\def\@makeother#1{\catcode`#112\relax} + +\def\comm@nt{% + \begingroup + \let\do\@makeother \dospecials + \@comm} + +\begingroup\catcode`\<1 \catcode`\>2 +\catcode`\{12 \catcode`\}12 +\long\gdef\@comm#1<% + \if#1{\long\def\@tempa ##1}<\endgroup>\else + \long\def\@tempa ##1#1<\endgroup>\fi + \@tempa> +\endgroup + +% like LaTeX2e's \InputIfFileExists + +\ifx\InputIfFileExists\UNDEFINED + \def\InputIfFileExists#1#2#3{% + \immediate\openin0=#1\relax + \ifeof0\relax\immediate\closein0\relax#3% + \else\immediate\closein0\relax#2\input#1\relax\fi}% +\fi + +\def\ZZZZinput#1{\input#1\relax} + +% you may replace the above by +% +% \def\ZZZZinput#1{\InputIfFileExists{#1}{}{}} +% +% if you just want to call (La)TeX on your text +% ignoring the portions that need to be SLaTeX'ed + +%use \subjobname rather than \jobname to generate +%slatex's temp files --- this allows us to change +%\subjobname for more control, if necessary. + +\let\subjobname\jobname + +% counter for generating temp file names + +\newcount\sch@mefilenamecount +\sch@mefilenamecount=-1 + +% To produce displayed Scheme code: +% in LaTeX: +% \begin{schemedisplay} +% ... indented program (with sev'l lines) ... +% \end{schemedisplay} +% +% in TeX: +% \schemedisplay +% ... indented program (with sev'l lines) ... +% \endschemedisplay + +\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2 +\catcode`\{=12 \catcode`\}=12 \catcode`\\=12 +|gdef|defschemedisplaytoken#1[% + |long|expandafter|gdef|csname ZZZZcomment#1|endcsname[% + |begingroup + |let|do|@makeother |dospecials + |csname ZZZZcomment|slatexenvstyle II#1|endcsname]% + |long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[% + |endgroup|end[#1]]% + |long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[% + |endgroup|csname end#1|endcsname]% + |long|expandafter|gdef|csname #1|endcsname[% + |csname ZZZZcomment#1|endcsname]% + |long|expandafter|gdef|csname end#1|endcsname[% + |global|advance|sch@mefilenamecount by 1 + |let|checkforfollpar0% + |ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]% + |let|checkforfollpar1% + |noindentifnofollpar]]% +|endgroup + +\def\undefschemedisplaytoken#1{% + \expandafter\gdef\csname#1\endcsname{\UNDEFINED}} + +% like {schemedisplay}, but displays output from a +% Scheme evaluation. I.e., keywords and variables +% appear in the data font + +\let\defschemeresponsetoken\defschemedisplaytoken +\let\undefschemeresponsetoken\undefschemedisplaytoken + +% \scheme|...program fragment...| produces Scheme code +% in-text. Sp. case: \scheme{...} == \scheme}...} + +\def\defschemetoken#1{% + \long\expandafter\def\csname#1\endcsname{% + \global\advance\sch@mefilenamecount by 1 + \ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}% + \comm@nt}} + +\let\undefschemetoken\undefschemedisplaytoken + +% \schemeresult|...program fragment...| produces a +% Scheme code result in-text: i.e. keyword or variable +% fonts are replaced by the data font. Sp. case: +% \schemeresult{...} == \schemeresult}...} + +\let\defschemeresulttoken\defschemetoken +\let\undefschemeresulttoken\undefschemetoken + +% To produce a box of Scheme code: +% in LaTeX: +% \begin{schemebox} +% ... indented program (with sev'l lines) ... +% \end{schemebox} +% +% in TeX: +% \schemebox +% ... indented program (with sev'l lines) ... +% \endschemebox + +\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2 +\catcode`\{=12 \catcode`\}=12 \catcode`\\=12 +|gdef|defschemeboxtoken#1[% + |long|expandafter|gdef|csname ZZZZcomment#1|endcsname[% + |begingroup + |let|do|@makeother |dospecials + |csname ZZZZcomment|slatexenvstyle II#1|endcsname]% + |long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[% + |endgroup|end[#1]]% + |long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[% + |endgroup|csname end#1|endcsname]% + |long|expandafter|gdef|csname #1|endcsname[% + |global|advance|sch@mefilenamecount by 1 + |ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]% + |csname ZZZZcomment#1|endcsname]% + |long|expandafter|gdef|csname end#1|endcsname[]]% +|endgroup + +\let\undefschemeboxtoken\undefschemedisplaytoken + +% like {schemeresponse}, but in a box + +\let\defschemeresponseboxtoken\defschemeboxtoken +\let\undefschemeresponseboxtoken\undefschemeboxtoken + +% for wholesale dumping of all-Scheme files into TeX (converting +% .scm files to .tex), +% use +% \schemeinput{} +% .scm, .ss, .s extensions optional + +\def\defschemeinputtoken#1{% + \long\expandafter\gdef\csname#1\endcsname##1{% + \global\advance\sch@mefilenamecount by 1 + \ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}} + +\def\undefschemeinputtoken#1{% + \expandafter\gdef\csname#1\endcsname{\UNDEFINED}} + +% delineating a region that features typeset code +% not usually needed, except when using \scheme and schemedisplay +% inside macro-args and macro-definition-bodies +% in LaTeX: +% \begin{schemeregion} +% ... +% \end{schemeregion} +% +% in TeX: +% \schemeregion +% ... +% \endschemeregion + +\let\defschemeregiontoken\defschemeboxtoken +\let\undefschemeregiontoken\undefschemeboxtoken + +% the SLaTeX tokens + +\defschemedisplaytoken{schemedisplay} +\defschemetoken{scheme} +\defschemeboxtoken{schemebox} +\defschemeresulttoken{schemeresult} +\defschemeresponsetoken{schemeresponse} +\defschemeresponseboxtoken{schemeresponsebox} +\defschemeinputtoken{schemeinput} +\defschemeregiontoken{schemeregion} + +% introducing new code-tokens to the keyword, variable and constant +% categories + +\def\comm@ntII{% + \begingroup + \let\do\@makeother \dospecials + \@commII} + +\begingroup\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\long\gdef\@commII{[% + \long\def\@tempa ##1}[\endgroup]\@tempa]% +\endgroup + +\let\setkeyword\comm@ntII +\let\setvariable\comm@ntII +\let\setconstant\comm@ntII +\let\setdata\comm@ntII + +% \defschememathescape makes the succeeding grouped character an +% escape into latex math from within Scheme code; +% this character can't be } + +\let\defschememathescape\comm@ntII +\let\undefschememathescape\comm@ntII + +% telling SLaTeX that a certain Scheme identifier is to +% be replaced by the specified LaTeX expression. +% Useful for generating ``mathematical''-looking +% typeset code even though the corresponding Scheme +% code is ascii as usual and doesn't violate +% identifier-naming rules + +\def\setspecialsymbol{% + \begingroup + \let\do\@makeother \dospecials + \@commIII} + +\begingroup\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\long\gdef\@commIII{[% + \long\def\@tempa ##1}[\endgroup\@gobbleI]\@tempa]% +\endgroup + +\def\@gobbleI#1{} + +% \unsetspecialsymbol strips Scheme identifier(s) of +% any ``mathematical'' look lent by the above + +\let\unsetspecialsymbol\comm@ntII + +% enabling/disabling slatex + +\def\slatexdisable#1{\expandafter\gdef\csname#1\endcsname{}} + +% \schemecasesensitive takes either true or false as +% argument + +\def\schemecasesensitive#1{} + +%for latex only: use \slatexseparateincludes before the +%occurrence of any Scheme code in your file, if you +%want the various \include'd files to have their own +%pool of temporary slatex files. This lets you juggle +%your \include's in successive runs of LaTeX without +%having to worry that the temp. files may interfere. +%By default, only a single pool of temp files is used. +%Warning: On DOS, if your \include'd files have fairly +%similar names, avoid \slatexseparateincludes since the +%short filenames on DOS will likely confuse the temp +%file pools of different \include files. + +\def\slatexseparateincludes{% +\gdef\include##1{{\def\subjobname{##1}% +\sch@mefilenamecount=-1 +\@include##1 }}} + +% convenient abbreviations for characters + +\begingroup +\catcode`\|=0 +|catcode`|\=12 +|gdef|ttbackslash{{|tt|catcode`|\=12 \}} +|endgroup +\mathchardef\lt="313C +\mathchardef\gt="313E +\begingroup + \catcode`\@12 + \global\let\atsign@% +\endgroup +\chardef\dq=`\" + +% leading character of slatex filenames: . for unix to +% keep them out of the way + +\def\filehider{.} + +% since the above doesn't work of dos, slatex on dos +% will use a different character, and make the +% redefinition available through the following + +\InputIfFileExists{xZfilhid.tex}{}{} + +% @ is no longer a letter for TeX + +\ifusinglatex\relax\else +\catcode`\@\atcatcodebeforeslatex +\fi + +\message{*** Check: Are you sure you called SLaTeX \slatexversion? ***} diff --git a/collects/slatex/slatex-code/slatxdoc.dvi b/collects/slatex/slatex-code/slatxdoc.dvi new file mode 100644 index 0000000000000000000000000000000000000000..24f066045fea3aab095ef357c3a9ddd40f1183cc GIT binary patch literal 62944 zcmdSCd6-;Pwf-NfsyhJ!NTQ;s3}HwIk`4(VlL!b15dml z4s@M!_OSNaYk1e%YyTy+!&|QT(uORX4IpmP;Lk{a+ ze)!SL4qbl8J9%RVz4p)kd76LLZ~Wt|SsQLhoi^~I_3PK)@Z_D>J+i)b^zNU3eAa1y zxM*V5PPC!_cH~CN%MNLtTDto7hsUGzIpZru`pVO@J+-F~`dI$l4IB5In_6Ex z<>rG=DwVT^8t<$uRI}ym$cCHd&YDG|`|SSsOMd*Tm#v8#?aYl-tIH0V>emOy=PKRh zLN4E(?;qRnf%UbQ+>vdblpoEOt0Va$y;jw0X`p^$X@oiF%k`DHLcW;G>)n$N+ITjf zs?T$Zh1J*I{&2orDOBqddU(hwb5AXeRjQ@pVl~loZvBWOmLI-s$+9DlTF#)~onBvi z?yOm@iPSPL+PzSTGA}wQOCQ(Y{_s$KBwrsbmj;(}cNh4#eW8b6r z5VAJ%=jx9N51~qJ$L~G3qFOJg0THE;8yn7+hbN+rn}0r-&zAH3bw*Gfiu)fa6bI|W z+2RsD7#zzE<||S9&U04g=*}jTE%w(-yiZ?+%4h}JJa}!sd$4=4C_GXs@|hlV*E+xT zj-H`>l-WBPD3wRD)v6k1A=Fo{boD7O>CZEd-0)a`zEaOt)L*4ASmdoJeb7zWQ7AWB zE@Yw1K*<)8x9B@p8ZMP9VbH5pj)dDu|meRz#&_XI-lr`HAsH zsoY;#Tjem$5^H#_EQ6j-kVh12A(# zE6(*Vyf2 z^-;|a4=2P*Eq(9FBDQ)ldK!P_t5It3#$3Lv#j|%~)7N>!Hy_h#X%hyM; zY|?6p&%L;bQs4evmnbkc!nT>Hm&c0Q1dC#c)!Ny}G4>>jjM&QeGnF?E zqV)%|g<(@H{e_AsJ65Q`4BFQAwTaVw9x)WnR=Yucpmx|Is~DJc4kYQHrg*w*9f$tt zOesb_i&EGA)Tz%QNWQq1x?@Sggh*ZcDe<`H%Ox@e@)E{Q>uDH%jn{8{a>>z;ryr`{ zaQ3X(*jf5-23zZho0n~%Q_Gwh<;! z!5AD3_C-D4xT`-ux9G^*xNA5&a`nweiR}H^CKkzE-+z4m$bMfqJGnBI%CbZ5tYnLr zM`jIM2k6VfK$JdZ55G+H!7_YllE#}bl4_MYeKONK_p8?RV*Sp;mN#YQSR4Ehr5`(c zE2j2vAy=tozFY~d^$m~7<|@Y=ZU&MTM*>01vvo~qM&Cr~1K+ZBqL$flR+IhP)i$qs zvuo>`$;|8So2bqD>AL2kde_!m^z^!gh`d_*uQ#n}@H|)df4Mdmb}ix`?Qt7ua(8_8 z*C;gRCPSzar9L-L>+Q@HYaAjbpZi)Fiu{V=?tKXsJ>S!Fenh$eKZpkA zO8?PfrCO3GHJ`!ymn9hMjLFn>ug7pOtsBe)jb&j4?xwB&e8YPk^=hR--(eOEx)`M% zeGz&NF&W&B)T6WD6z_KE4`jWc9XiCE5q{OsLOXadxKrbjmyX!Hj~+=(rI43C+~tBA z}MuTj{_xht`c;EmcxZ&{^(lg$3Ie$fm$j? znex5M5YN&gWt;6-4x(l2l@VrD&#%djj1J3Ib#z08Os4<*8uq&xTV`x#jj&g8<$@_P6zzLVc_rr1 zQLhB^$+6H>#YWOysmjqXO4v5fEa{ob4OfTtph;JMyE}AssLVfTYWvcJu*g`A3F$^K zYAcYs^m*)0QCrkVj3YJiBWUSXX1E?xGZq9rVv{JHImSDUY<=e)n5=>!3No6UmpN9A zHy=)alSLaxS#EzAx0aci%V)ip^SjV3pC9yL2S1cC%VN1; zgsWyNRa}G4KYTXyez+uT+`Zf;cxa!GCj}=Ppw#ERVRO-W2d$zx1^!9QYs03!+1QS) z?plT^(ecHnRuoZ$+K{Niu^i%SqLzN(sIVK+uN$BLf=_u)bk=B;`rcthse*A$w_?Jd zT|87OWAx?M$nwMdWAEXJmDyJ&Bf@C31*6OvYn`D#kk6tjc*E1*;VIqq(@o#4Dhy9F zFk9Yr56fSPIXV^zQF`rFVvLv>ouh;TfWvLmv*;4mVzT4_pz<}p>XA_#Wp>_KdsxbB zjD4el;H@E6`wKhsTrwqmX}j2Y_A*6NZ~B%xA4fiA>l3KNH+@T__K;BOP1hqT>Dw&Q zAfw-OeL}z>T{?C;!^BMN>2~b+!>&H`P$h4J#>uozIU%#Q;)TnhVL<55D81Y9Q@!|0 zPHyCjs}T@PqglZ4;!{koahcMnrfGDrewT#dLdhVApsMo-H9J3W9y?`?jrO+vpiY9I z@wSm_35~Q`aPxCtV_AGSX1{LFfR1Q8HS_02Fdi@ZPBq|i1qMuV;E9+k?7ni8`A4tD zXPSq3j%yP$5{JyxGEY3#wG~p=Ix~+n)d3LAqChqjqEN>vEP~vsZprkcH`pfKxcl?g zC#>!79J_uq{u4GZIOb{)qB^pim4^oZd8-!5_{`h1()~DvkX|zYc5F;k(AL_A8)ZzR z|56W}J8`wlZ=BNX=+!SPV|6=6wcBR-0ua}0W_{=B-!+$Qc$Wa-6#w0xe-4@v5XLoV zUbbP={2g9luIdxq!J0)EEV9?cq4{F}+UbMwBh{nU0)5yh!KQFeUs)(us;HNK%{R()Z<3&J z7GW*ZeTm#fvsq#=I|w)D4kAXP)bQsL78|Y}s${qXa3`schD0jJ{WX#1TTTsM&X=;R zdIUvgu03ZYivXK&XomwO^N<_buPy+{BsO5ZY5Y6om@-P;_(1bAJX{Q_uUy%Z_mcCi ziKK4)sJ7JNhCC};gBr3ZY{T2yN)$FrW*>HM*c61q3gB>5d6fRzcRgrH7$Y{`8(0cV zu>~WyC`a2EEt)!Zd6XG^Uoa-=+bxoFh-qz?Y!QdeKy`xzMze)-)bZzUqk>~p91&Uv zmmnl%Sd}v^L}kN}hBcMZp=_T}a8SUg^MJjveT8ZXzUiG>+g#9HoBO{9oM3(iP@wST zU{zVnsfhDhuST7>ye|h%zqmI0%FV6G)H*+TXLh(!vfz=lOmKI~BXk@lw6?pudtFni zO&hHTUh4edt;t4id}t=)+7t!b$L27cm7iD#o@Y4%#WhcD#S#Oza7PmCz&V@hopC4L zwEO!XOt=m-s77+brAn|0?c15Q4WIF>sX1g0`zCya6$1yl8&(8v!u?))jz^%~~91_Kx{^H--V1LKLVY~r5X$3n2dT&j%Y^12;E$f*x zn*f=XzzZDofyVhq5w5}e84!{eh@SX9b5_*M4wo>~;@HYI&B&b&pN?XTupK%c%hDn8 zEVu?;uOy0yBytv|z$5;1@mRlwXl&3qMI(u_c7FeL<@}hKe%k@F(Qo^28QE-N>>KSt z`&Rx+2#hwn7u7nKJ*3T${?#Y(QV2ATVjl5SIw`Dzm?@3n!0oFPS-xQ>{C}A>KBiIb-OD~em zfcuNIBjD$uL|G2C^jkjYj0boeZdVgvT0eR8RG}>6;N5^z@qA=5m^5mc46gqs5?UjR zO$6z$*h<(W@gpmrJ=^6#SD6FyGO-9~P^un-_XGCQKmKrglWB$L-ZtQ^CdPq(X@}0- zo6eW)yJm+S5Bg6d!X;`5I%KZ8E?b**Pp;W|*IB+7^Jlz6dpjI< zQqydU4T$r^`Y@L>N>!xds!O!1>T2u~faA<3|B@Z94q5Ctv4wr5Kll%A)Fvi+iq0%VY0zg{qBk(`qZO3iwK{9TC%FV=UgwHZq`--K z89Dxmeu1d@iVLhTVm5D$_q>hA=GoZtD3?2rGQB$kSsDtO3$%1y^z4kl5YjGYb$8WDK2l^2br0ouu1 z;y@ghRVGaTYnaT$WajU`#|%wGY`qm#K}hgnf;&@RSc8(BOnu=$37ctvB?L;p&pH7h zcWE%P78_H&8cHpF|G|QgX-4bC9`cqTw8sS0E6t?snttuA?Q}`M_EVN!;&KI$EG?y8 zZ~9z;3au0IVzQWQj^LMVxM}`re>9VLI`rUPn9;TVuzU8bKD7V*pZL)3t$*f2ySJna zpVfzUul-XW+Q0T}KD3{p_l3Oo>`C?v&NHn(gY(RjZJlR+d?x3aN3rwFzkBDo&3E=g z>Ft{k=j#>xW%q6m?9+MomH)&mV7sqwSQduc@!mF#QlHqniP*P|Yg_xW1ma#x-TY_t zN^UssSPi{mD%H|o<_-c8N2!PIQh*L43pO?YQV|o=VP@+%q*)*x+IU#(u1Jcx6;4koJ=O*pT;pL?d-NvQi&($yz8f<@O}DcE>@l93x+%JSe41jJ4ySFIGq?L;f}T zK~!AIi6D2(ehEaNX&JXsCZ+u?PYucx3Cht3wx<(cAf>6Mn{t3QQkOF}zV}$iqV6d5 z_*Uks**QZ_!;O6kNpuUHJI^6&>WU$_1i>hC^?wFoh17MkY!M=J^{Zn-Xvplx&I=ET z?H5z#EfOq=%~o=N$VCc?Z4xicD(X1$NBwym_~1c|)Dx+SA^UBo7x&@rqe?_0#hmi} zlbO$6=t8`XCjt zn=vtPSCLL)i>Upr)aJ*VU6*vP?k1xzbJRZsFvGE>v4vO)&e3zucNnmeVWZUl{W|IM zBpj^tj^EHq#(`C$CQvV*jYGgfL%Uv+WCBR}tFIEBi`rgreVlmdcqNct zQpm*wTdBK7W0$|1x#%x(>fM4zMzR=GxD-O72C|hQIlT^6RN%Qj<*Y6fNq(h>Ho$vg zPS<~aSbPOnpnEP9AHlHW29QvEo zjyk@Q$`0c;^kdB{DMtNkb6ZyQy;-$~00tN2alFDVa37^=^I;1E%^g6fkEa<-1bgRC zd8jx3J^;|oZp+KMdHIIgE+6`hL^2WU%rAak8QV4If->MLBs6F11Nm{hj<^Bs7er~) z(fJc-B7$NCz^Xk&Jgh!+vB~NZ$%ezDbr(Qp3iAAL<0^&fn5EIQ zg55%5qRf)7q7xL^bQuATK8J3o&H32Nnj|3N{UxK`wak)ho^6TD_BPqzgTqP`nRn|7 z&qW*4Z=ChkS=jiqQVU;P+u>t3yFbWXTfgxiZ{#dN$E;al@xq#kn>Oxt>#1;)!H!Zt zmeGs|pu6kdoo1SDF7Ie=Z3 zh(wB-`Jpm9Lh`)rK*F-@omfnms%H%@x$k6U+G7jZV1pCTW<0G!LbI(L^x+~QGAp$J z%)l7s$)_JZ#&VGPU8|!#y{cGZ8>3D3f5racr7kkm`uejL{TQeZ8XCC6oXa2fzgzTV zjr(=p(?9G&59(aOaZe7^y9VoPl*Q!$MCdwWfW!?FV3BV`<%=%zqg=SKJ}_3aj2*cJ zMv|uEMmcX4zvh0D4&O0U#pRZbjMg>P4Ng~yH-zxGDMQx8lv!*y>&H8HzM=2s$;`VE z@`P`B1&t&zqGZaRIwX5-fW7$Wpv!IxZwoAH&x7+XdvGUyZ?^|tMU2?!mO0|v))Y-b zJO=_91vmJ>@GhtSB@q~IPs3d9(l9q8aiY}DYe9i*GuF4Pef+@v?jN|iEoHKBRhoi0Sfp`Gstn58b4X`|F{Z&E2*1 zZAYC`AsuUYVv?j!Jo8URWn4Bem2!&fARO<0o9g z@atxp+G`DaO=fnnjv!Z3snCo73A>CL%3!P<@CN8%4FhyuL%$yEs z#=2bF{!Ej)Z=Y8vd+334h0<=>HpO8x(r2eLk4+}T9_m-(1Pj^o=`ac282o@!SIbG{J{D%d0r;{1TU(0m&@wzxJLSdJM2u3p%2r# z<{JnynSRY|%j=*uFzNnAAIp}lHf%K;*z=7(&RVP@t(SkjjI7fEu=ydrjfWDYm%j~; zN3)la@(AyNB`XUf1v`8tiv=Ze)MeB5hyYt_h~(ZE$1TaL^38aX5kzf`TAG`UHnA?s zd}cmjF2Fqku{O0f#eik0WHGWN{havDqNiGX*wQg7Q>)w5Ol1X7=0voULthcre*zE+ z@Tespj=7!B26ZSKhdvaWjneOV!i8shr;ceZsHH#sO@inn1tn1zv7S2)`D_o12jR>L z&_arw49gh9hDH38PmKcPkc(XLQhTd13~{B-{NZgA%|3W*-*Bl$mT_(sA^ySB6)Onw zO!*oHQ2m5ik%t&Pq)V?a{4KJ-$Nw}4w;!~w=SnHm}< zxo8-0a$#EwWgqjAndRxv98~cm4ngd!P2b6@tebc({qt*SO{AGiq5vO5ys;4yJ?HMZ z&|-2OKi%S}JA0AXP56IXsLc}c1a8|r5iz7Pe(RdHlqI}KZw%V56t_*IHT?!^*JgKL za3T&~J~!r1d_|d;|3DwQq-Q_w%&j-fH0~(#qvL@NNtgxL_qLCcTMU=Z#u;dtAO4RP zQ$x0G&0bmj5=osXz3(?&!ZaR_6I7Lg&LQDAlGTqf#StEKh(G6=4;8TN33;KDNU|r5`rgKm8i9 z!6A2k&aFyEWki|em{>CUB_r5fW>v#ltIYVtdP}}MW!~QZ z!!GTd@JPJ|b2iE>`b^Vjb0B^fPi8LsCTxjZX9MT*i;-P{|0Qi&lSK&dUNW*9whRNd zoY+;}i#!VFtk9e0zjMlAt25^SIK<8aiZT|-1u7n=CV&!;L6#$?2gC31PsKkz1d)dCyYS}>jb$dlk^G3ZdKU^Abdk5Yv<-}e7*=65 zc{Q%f#LU%#ew{XPe*RbIJ)mZi^S1Fn%fx54yxXkl7AhoLxfL=sliDrXHny~1J-Eif zrJOQj0Tb5pjP`GFTAbAEWK08#t3LNX2*VyLvA?xg%e?URI}ahYd?zdITiwB4V7pao znNycwC!36ivbD^H-!;1)pS$mZ#n&fI_{zkxLvEX8vv3VAYkG@1w&~#y?5TN&cDaee zAW`a`cf%u!NqRQfY9y$2tOY#oYj{jkuZclggV1wSiZ-J;EF1;Ib}%g_Hfc=flLm~k zaoz$QpWlY)VP;|K-hpWm-Gqf>p8pp#XGNF>1KWn?juuAn?IZ0;hr8*u5LOI?D5aCEy(uUz+3|@IKC~QIem!<+& z9Eda@!76(}-wHdyn|i}n`GtitCF(M_6)aUdf&{`SyeU&Y*i;@3G^^6Xlj)&%JKK|R zo$|RjL`N{aT54o-lD)QGsJzfj?Ak}^rF}xp6jY%1M8co+WU#C>^q8?^kFUVa$!|3{o#~B25$xS}SO*x0BPMcVn!%~)Vo=op|gjd`3RTv{njwP1fDDa<3Lub~t&U7TenIJts zV&}$79n$9|32gqo<-*`lHAgyeWmRFcX$k2j0VI7gzgt?7kArtuHd{tBbCX~&%Fe6t zO6$z8akkggQRk268J3P=8zbqCNdk>Tx2@_n0jQg{i-)r~+Uc{q2w6hcwSL5(7|sv0 zF!9zC6L1K^srG4c@Xvwd=qsDt8Ndoh3&Mgl63KxL%B0AYippJd!q6u4uK;-%RiiRU z*CDe&@)qpr`g193>63S1L;JAsHmpY|Absi?mjB>f^uYCyDM~&4L=4t(P~UQl{SxSz z54^bKc^PsE(XRf6IHwS*>2$jbcz7SB z+}e4LqM%ZS#Qbl$xL|`GR7yvKZQU`a7?Of22vLW)22x@Wcg&uj zE%y~T&%E6LXwCyTFaklAs#e#(bT%;LVV;Me=y{X?N<29;uDuy z#^%yoZgQtvev`y$*DMn9dYPTzwgrf>qQe|i1O&c4{~Z3mGeJf1)Z^~wyzjl+cE7IC z)GEN!4)ke3x0CFAe*`!?T$}ag2ZxvD>N(upok@;MqN_R>ye6_#xW?8sbqqHtw98*( z4#$dWH0ReJ*;=U7cKpIr(}mtg3glc{KA6i8&6h{W@OAmB7Ud2C$L(a`5{BaAeQrxA z4e^rudWK-BF~S%(&3^-RiAX+p2AF*tBVWp?MA&iITl(AK$9QA@7{6oIc3qk;myVN9 zR9s{p36}mb(pvfn{9ev(-hZ^r{Go$zc)Hqp9y#tCT}$-LdqU0y!i749z%f6EzLYG~ zMaJ7Q9H!v?Y=^V3Y2H&G7vKqDd}gH?*sUSNu0ri4mwa{Fs_Io1w%rY=9r*AyU3WPz zpmx~(d~H!BTg*Q=>pfN4MWQNgse`A`3i=0sld zGta*h&x1j1od4vxM!A2k3`qgmE+yC|&TYf*#`;*!OwYe7aQ|&t>&0yPl!X8Cv7Q> zD7f{&BUhSW&}oawRQV%q);SS7iStHR*40!Aa;>>YInm)SH#&c`q7{AH)DjF%a9q}v z6oJ$@psz}Op^Kg&0lm~(sGo5_FVkk8DCCFxWrS&|+7|J$L}T4(B)+*!>b%Wmci(lj z%giW!+s8>+R*ePQA=FsNT=k9S!aFq*p-b61f2c+I!F4|b%Zco2y<>8*yYAnUS*8uY zUCik12$>DjSW))Wv0Xs~>jj~x(wD7}4KJWbD-I-gnMvV;mdyTiS2JO+88Vu%(!9QP zsy1y#8c3??A~wUC1@%y`>7bi{e&`J_q2B9SZ;*u3uhMEPitNAi(w{3V-=8fLLt><4 z=_utR|LPS)HLPmP5q*jx=tY^;Aq~iw5F9#v-`+B`4Y3~KFg)jhWT9b+vmGA3X8P11 zSbG%_tfTxeWj<=BZ5_!@tXG85O0FD6@cj43G?g{diUT-`;z)5i6!(xPHfeUp8mEHI z1R<9s-7^{JrI?gxAhfr%v&Wq|Y~mnP=Y_CoV|U1ri6&i%FVyj|_j})7$sw!dSZA(0 zZTg^uhJ!h-8Kuq$M7MD@;v+Hg#vtxE9(3iamJWq4HA1N+s-@^pSMLa`j8qCXtpb#| zn9d4}jbqMeD_3c{(fcgE#-@2|ZxrrA-u1u2*}>OnaX8JGd*j`Whc`gb>F$Q!R_fO5 zmrP?_IL(H@mV^dXrK@m;`>vzBB~QSBpY24JeoT~Psyo*qbNrnviA+l4g{InNSIfqU zO?>YxHASp{fdF1aS$3M++wC*&xcM{Yddi%QgUR-G;;c|IJqQcR4t1SV3{>noJ-f)K2@*k7f?T}rL=NP_?Yk_@+B$41b?CWW*|K>SaAsBL8$qV* zu+@k037~;ugYdhJpr5lg9k+bGM|=N^|A-M9OYsbDwL6-i6D|2x!iQY9D1GC@&edk$ z5<1oCe}d$U?lY%&oJ6UkdWfSz6auF=KINinJ}v<3kF&r;WK`uwl+M;&sp!z9{>53S z9(|wp*@|Pmw#ly*KnJd@uh%8E=m9eQB&PI0yWSnQ%nt7x=+Nvk2rA0FxIC3;#KMO9 zP}7<2=eCaAv9wXg?Rd=QkrB2PZlTYDv=Q{-k<`vVzQ+vj7(0!JV5cZO!n!Ehaq#&F zbUWzjGS{s9VqR6deBNXDaJn!xJF}HB{x1lIjsLD-Fcf3j&Nvb2R*80br)P7PQhvH5E0u}9pI2AKK{&t+{VaIZiv*z$Is*NL(* zvQzg`0KN~Qjku2IqaQU6iLj$dU6 zQsVKUCs%9I#^R6fWtM(cYRriPXD_lIBiS6O7eY?`Sv!#_be8Z9|s{ za@CIH{V%W?>b=z2O-Qn9L#((+ml~!{3->Ircxmk|;7jbPVl^2(}a)38^e7Wjy z46je1@JeGs2~>@df?V{E*4IemO>FW{0@F{*bAXEi_++WMXO2E&veaQdMThKGQi-6? z>`PyJKPFaf)~$zaKDxH^;cq>Im}2L<-ofrAgQ_iwV%=teMM^cYLoY5jD!ilZNy1X* z#UEj*qxAnQvk--gi=cAs3(_Vg1YbkPE$uKWSx6l(>ILse zzw*ln?JSIFB@tjr=m&9B$0MNFeC}Xur7Tf``0foMvaE7-W_`-sYEb6P&V|B^-6pYO zjHr3I1Bp7f2O^p^>(se3fkcLxfG%Kop8Y!WZ+cLvs2_pG1i`JOakaibY1X6%DcZom z_0ihiAxOB^3%0cZW74N97Oh*iZhz@5HSAuuF6RAZ*Y!=nzyv=y?}yVg#1NaFE8G|D zNRDUc)-YR5|Gyis8%P3Y38UC(Gcm>y^D|Q`?b3qIn6*)<1u}R#*wGKRL#$~Xg(d0M zuMY+HrlD;sYCF7VBbY>eW9EhL(N4+FT5`wi4Yk7tZYfmO*W3EAUSnjV)hU)0I9aXp zp>Ft)vIj2>YAPWo$dhq7GL5S9Lq@W8LJQGw|CjIvB}WMoPD!anB}nlhLA=KN+;I7mN|PQ zD~5B67NuU1nsMFS*$|oGmO`cRqP;~q*Q#2;g?!t}z#%c2>z6SIUPJ>?4=_7wQ)OfW zf(tm?#g|qlP_B0WWct=?vVGzF7CPu%m!D8e-+Jk^9o``FLGGii5LK&lqFb@Fq%<0( z*IkLtHNdj*egvQg>-H(Py}I`QYwG#l&iN5nYVjaYK-)O?G=S`l+9qICYZ z3NaO3gq+mEF-P$wVUgt*e(-8GDeVuFmxozr(hDpN1N7)x`tM7X@D`;84xmP&E1%^ox^L`=fu95XLdu<(6l*3g6xl1%YNCSll7VD1DlQ|~*;{0GLaS5(R0mwq>S28~V_18LF0b91aawAho}(NeYw&oAF_9wKO`J zne|(LjB|JaVb_Dd?ZU21OL~K(xx=&%j#yBa;%Oe|@VQuK2 zkP>A06hcobXGpr1!tC2Dnk-D!HfBjkavqY+Wfk1OwZvLc`p-W%Ga{~6NIlb^Ua-{=)+UoQ2*9}C>+oWlVa%jXGTWKQNt$vu4eUo`W?Qm0@32aaD7b}N`@MfDhM zECHF?2;-)rLkl6r90InQK%O%%Dm$e2G@zy63B&LbddZUS(8Czvx`YeXxzM zbLI5;bZ98*xMH8C75s5laRM%lg}D)j9U8`&9ZQzE=vaA5p@@wQKWOrfO2B&qFpfA# z+Ht2QJpqfEss!01pk(A{ca5YC38v_+g|AHp8yCd#og=QIaAVH^fSgzvy2kvE~RyBRvD2fNC`QOgOl zD0L38r21W}uD$svUsk2kRDs#JE&ql^R5V8(Qw~2ic&stT-MQpVTf>}rrPlfIJEdau zCfmdcZ{MkDvCeb^GJg32Xbs{GehgW{a}{+cS_&InN34uw>HHw^ZO&EHI=*mik2&ToELMjKqs&M42({Lv z_SxW8iY!~VT9z2+^Qy~)1!l*x=f%*Z%dlz@M&GYMd9T|D2` zzR4<)r^_N8oNX5_16sBSvH=zcjU>CXk2oeNdc?0NVeYCXAz%}`J^k_PNsps!VwC>) zCvDzFGgEDZh;n(Hd#XJL^CC>#nRv2qA%Hd>eeq!&N|I^j$?gIitsvx0&-wgeZU@-x z!}eJVgM+$zQPl=bBpW_^Ck^NqRFzc~ zjECP+GHquKGy`^m9}6i-u`p*zqK-#?he|2C)JjCIq69)kImH5C*{b=A4X) zYdfIGsaZJMU*aRvQoGU}JAsOJfFrcfr_jk{>cJoQT)Bl-%)D`;k}->o(@E#z7YZZQ zU0EbH``lPAxSESm>VvzI51{IwFg=B@tO9}RNU_tYBh_50no)ee##M}Jp}4#`U&s~Q2_qQrg0qgt5?5%yN@)d@iSeMML$G5Aa%&nZ}^>_EE0MfW~h$`V*+YS$3 zksVvZn3W`zh@Z3Q4_{#uP&Hz2{IdW9t-R7O(|FaSO1^tT;>w*rl`k11jjx}6*-9#7 z$VQHb6pIqc;C=StESZUPN#6yWLpb}}l4g`+rt`|;h9X{E-Xa59XT&&QRjQZRM0VcG zi9}V)KI>}lS(;br7QEG?SfE!se}RQBvF`#c*hUn(ZaS+IqdTOE4cMJSBlf!EzOZ$| zmtuW!ax7KkLV12{zvO7c#uv9#U+T!8y>-^}Z~s|K_2~~&eSf&`#Vys>R!x9DP1{+) zf%Ye;IiteH9iMm0GeVh%dni-;D}BWYEXqi|*Bf(M8*MYLe<3xWdI%^2wwy%+ppGjE zEMvkQa3q6L)btW4K4{5O7diDQAc0r_hXXmVSgw+c#XpI2h%a@xp{^m>j(=Xa?3r*w ze`bF6!vfEpPo^!-xCyCAej1MK3pv4rQF`dXXTE~R$=8OYYrPc>QffJb4+<~y%IiFG zh70%RM=kVR*2M=_zMUWkn2W*Cq*>OLXpAOw+1OSXSn-XHdv_7oBUnIXPq?8gBqw** zcK*`usru-G1X95Qd3jki6LtMt0PVC`szZ)*qoX9+CZx_7*kjw3udTtWHdd^%Fh zBQFKzjC@l27w>YIxP_@Hi*njESpp=G2}1@W$g09gi#k%T)fdhbrN#zBw%|W!p&$Ur zV4#(^@FjPg)AI2V+G8kXc+!U~#L1zQfye#f28sT>T{A^te3;=Y$5_z9y`WQ1(h6t@ zvyZWYe_E9_rFsQcphwqN(FXnUMwB__1x8}}0l}*{8v7Gsvrl=>3Zl2LjulTsM~A`* z(2nn0+!bX${cBqioehH`CZ~Ogs_xpHtKacTL#2dg$>8Nk7N3W(#|v*CAvc`1alK(S zyDrJ%Yq)Bz5WGCcDVJHK(Dwm1O+jPRJX5+}Wc6{VoQ{v)FlG7M{868>^ltZWqzo>r znQEWPE?1?IaEl;A2sz}LHUBL=4+kW74|BQYdD3QI{`_qh(&}xy>wo6yf9CT)w`A9E z+~M-4b@|YoKfhW%&|>(JY8Z2_J+w`T!V1`>DwGcTddHledMV1h;7i^#WE-xSbY87n zC6mMkP^k(v_@JxTlD=(1WpZS1IFzU*<#mxAv*0P?AkV&l-6xsuIjv4M3W`P{cnY3f zN=1cD^MCSQLzt|uHc7nJQG4Cm{d?WN?XMCGH!Qc;Wxlk(&D`Cq#eQD&aQ`-MxwX=Z z_HWPfrdvq8NirercDjbD7b_S zQRrd0_P9z&*7B229D{SS*6%7N=BTOYPFHqWJ-b{skZOr_K|=f0O}*ZFc;a!7bh#<& zx%-_=wm@Y7+-cD|jT%|wZA0ot%s)QAZSv}EyQ9p^rX|8+NvpR!&oT(Q0t>^}v+th@ zf5Fh1%gCYQE6V^?{_1TPS{CVH_bnh@be<)Hw)Vuce9H%2x6S|O?`xVHn9doh0Gcj; z(L_ufp-mQ+(o>dRnhK~ped(TFTv)C@1D3#;>>S*K(3pU1@~kLrQk8})l(B;C*1JZl zLMTG2s&r^%q`T_yhU<8h5}+5J8^Dvg!#0Dw=&vX562n`a{VsQZjmiya8>8D?Wt1p& z`QNmI@hS%k9FoO4RANV$6oM)5>!nys($#fp z->!}ciH)cYIJoHT1>nZ+{x!I<^x?ypRCkDxY|fb6a8i3*rQ;1d3ZjWRcDvkL;fiJW$cS8sn8Kx~gQOrk z;I8#ZP@!Y&JQGm@>uox5;7C5WUv6YFMs=cko6*P3YnMcsbN<7hx>VMlGl+YAl9TWQFBKa|#RZ;m197pzSKFP= zoj3lB$}b$&-Su_Va5|?pdo|F!@wq31%{uOUYrIiwndj~mwg&33XTB`>D82G-n=~73 zNjsSsQQV4iSE9^w|AU3&l$xLnjKesSopIh$tzi{-v~y zQ^cp~p5YnxVGtHGE(stB(@P-UVeBx*;nDX4=x@kJcM|!~ABKE96eAyPhfEol!5(dg zOv8^lXBv)|hTqyw%u4k7L!}-rNFDjG!Sk?joLuKiTDd4o2&cqr6KvEdv+rAVU#Cw* zvAb4SgZAT|HD2UM@#wVtY`mZXthJ7m-WUwYO?tMD)sQFH$FjUP%F#ccRp#wtT<(ob79 zkLA{+(S^N{J5~W{vniGBQun#v!8(yK?UIk8uV-;9+4MJr)$Nk2Sx#Z=b zp)Evt4!6%}YYAh5b5#b!X6cR`2Uh51WvyslRqLOCo{n(PlkT0}j(>`UnV_d;2(pk} z`vk=;2fV0?rx4#8Vq_A)!^U;Cou zOF{vJ#3Wgwx&%+OTV=ps@e;|1z`=}2Ol-A;COe*fV)`i>s&I2)F&1K5QavnHE>2#SZJT{x#fSsh)bfdHJ# ztkE}C@<N8Vu{@cq`%F!#4ViGUJ)Mc0_)e>#0Iq zg#p9nB*pdb(~g}hBZcqS4^bxbe_g;jfqCnzC!fCLK3!f#3T@{bHw73*65K<ASgn z8iq)ug=y^yYuR`@v3u;gp~>{sZ}L$Ea#Llys~i}a2@q|Su2j&GnZ$zGVo{F&=gQ*X zes=CC7kPEbdTiwgTQnj&cG~M!N5#zRYb&PLx#-8Iujg67OI>+)#L!cbA@E%29ww-t8Q#UBTGBbP+S3?N6QOPy4KuLDv zLS+|Ca@k{j*+4<&S<|#9=4sE~mSrlaO`%jqsIAL7 zjAM!eb+Vr zlkk)AJJwi~S-m@-xm<@;b+BrnMW4rc=keB>=S6o4$mc!S{PMznDXFIWSV0IgXB--? zRKg`0DxdI7a7?mS$x4kue>r=a2BVfLog{L4L zE3M|+AC`;?#DljQ+C`MV!IWpe=~i^IPuROmOZ0LgnvZ23M;aM;d~t9x{rBgt=77@} zw=c{n6dN=ljE65{t7XgEbllw6EIwjGZKqdnX`ZM!cA#JS7x#zI>oXC#JUV@XWXXdnF(10fyn7+V7lDfHugVTZHo%rV@Ki$wAS*Ge--iX!ga zPgI2FjXZp#f@RxM+m~vQH0DdQRK9u_ly}4QXq5yLZ?r@c7w4KrL@qEOJ|u$bt)Q+m zPY^zGjfR4^p>ptBWpMB}(W9u@HlgJ)sviBS^Kb&;x)Wl9Jn*qB8CeupVo>kI; z*AC`T#dTUH)3^W7)0(rJiyJY@!GiLqlyLf{Ka0vF&0O?R=8iq0MYd)PYt^=~6lMcP z7T47wK9tvf~(Ov|KJmp@d1=drZjgZ$(*L|^l?UOqPQ4- zVI2g&{c00^aW^2&JcO-6jdh$+Z*hb?6N&{QkSEy4SiLZ`Uq%9?rHU1%P2W1N^~E@O zgKP}wM|GPhz2!~W%3_VX##?dlFVW1(6(^o0nDYFoN+CDeg!4DW>w1R4{!d+H3Lvb8 zj7VS;SvEciqILA;uHRS*7Rh@f5?fLb^%zN_I=h~_^2~5&7};sNI4{{Nh9r!a>iN3Y zU7;Zf`phE_6056}zz+92tH)s07A}WbwBoNJGqer_#LMu1oTuJOzjDdbF6n~=k@sH| zazdmml@p@n^d%(7qP$lV_4y;_Wc#VHGEwS}PXW<5DjZWw&;N=cVf-{h!V2%>qJ{Y+ ziMc?!%6v~YDkY>Jgz-e=cGjCpZbLZ+`~2a+95F;c9O;|P@$YtMkI%S)s}xZ+yWg`9 ziX0AvBiCL4Nx40+;#_z(790ajtCOim*H$n=p@KQjul}z0Sx_B5bX-e4y$eo|otsBk zHO}VJn_PWWVPQNyZU`Ke&i%~-XO2ecZ~ToBO0;RO^1lhtHvJ9mBMdvNm5il=y=Br_ z&7yBvwtyxskD;=!^3teoO#OE?%#E1|xnc5xNOGV=)+`8Y@_gf7yI%2(#u}D` z0-jrXD|i^cc*kZCmN=oSmj1;_a4LJhULgm9yw@@S4H?~v3o=A$xxWkBa%-}}G>XHGedFv89A{+UiM^ywQEpOn!S zcfk=u!k$05zNK|%pN_ij@h#AfV#!*xYY7Hqj3d6XA4t4OGn*~Z`{IYT0EJfR{@C8~ z2o21+;->R7SQ`TqQYw`jBTiI24DGJ$fUGd|GcMT65YLFjP{2j*3-nL{f5GFHv{ff* zsDuj!fxhr{**(gOQwz$NPyNperBk*jRB40BjZ`Yj4q-g$2XkkJOeU1>53ZVEPz=uD z9)4^_m8A5NRlB+14iPal5xT52ZrtxKt(z(_EOJ!uhI^A>=#dT#-EljRP+ocC&!&N) zPwoD~NANlf(Z4W>=<5$d^f$$bKGM7GXf#nH+-XarFmOM9?jCr^KmL`IzB507y{Jt1 zjL)prdbJ=3>32IZbX(oMVld4a)E!B41t+3}I+&s)O5IBjVTg3#cW5_J@) zmZI5veTqbf!9h$w7nnp>pl@BRQuwM>bC9eHE`i>C4mO%tik&Bu3b1o>_6r~I03$E# z^f);KNaZ!4pjHUSev4sK)*ox(**Bv9qb1#{N>7dI0Awjb>T)or5Le|;*%0?E4wFX>3U{`9eE zm;a&lRhrtwbHZz^xvSxs_%!^cPFyp!%#}Y3E%|B}r=9Q8+2Zmx{xF;G$l~s~IBVA> zoMq1c#d%Z~!oK^jgeAlnW8OR{@QALVV5#kFL;BGplg1I5sIuUYAi(R!6TqBUTA5v! zxug@zP~q+e>S646E)vHI^oDdw_Of{?|ARYB2RcWcdCfxzVxQb%`2#@0QRaKEox(%~ zY*U$BTLTaDDU*JDTh|C`A!?)atF(J(JhzD>`P44=DAkQtIp>K)}KJ2Fmvy3 zf_-V3IIjDHIUIj5DMY$j+uJ($XjTJ9eruFo_9bTyDUW43Z>Nv^;aJfnEx_4I!zdRp zT#7Zm;$jUtRy0W|*8*$3Sh2BLz5=3_6QCRCURtv)c_yx5W|yf-Z3Y6bfre z5`fs3FUU;ED>>P{47~>i9^GDDkXSZ^nBpB_2l@2&_En{q>Az2x*@+fsPzdc$w^a!< zJb#uBwp9yl-?u3S2hV%0kb3CrTgP1dy-hnHq+{)1Oy=}}Rz!AB<_EWm?Y2iNbiDkX zj-Xy6&_YlMlN}2uVueu4Y&p*91TI{pdke$xo7V|;ftbNjT3|cuIhnqY^6Q$L0<-U0 zwyhhVzUVcqVx5_&sCPp&0hN&>!vX!w7tZo$x{@+9=35_98yzdVgTn?BE1UwCX{VzZ zN0mTY9~-qT*wUY*gs^)?;J>|E{P)k!RmALNN$3^Q#AItu=dr{?nN5jQKjB?7w6S*o zb+tn;{vlV7Cc!_5KmfIVs@5=hIHf+dKLQf9=~Cf+8oWDgFGPb8nd$DLr?>d2dTxM(~9rd^vCioDSF#=pk^%JG=HzqlY+_XpA_XMs; z&nu!TENUflcWQr5Bh@nd-(prS(uQ+}=mA6&g|_5m zauVGf6LodBBh7PbmfDc_fFwd))bXO@Qj?a{@l^uZjU3n_ zXG4kA?(!LF9uzxbA0p}8moXtka7X7K{JP(d`g0Ms$lo?eeEak0kkxrKOh9%9ilO5l z2d|LbWQ3$^^1e?y&`>Y>!^kk<&7~+@f52D}AFfV@G==3-wXOq|O?uT`G{M_w3hf1=B%z@j+elzugT8T>hL8RtdST==MMMs zd20*`xB}M3Q=z<(g_&=C9qocvyz_xGodqg_#7+`6uhv8h2$91K3RuYRdRf+=?d~I+ zXav=qsILTBuKPa|`!Lb8)C?mepts(fXeU8}?ldpeFLH1K=%pH$&g(rOc`Y0sUqrYmNiK4P9pR#8) z4yJJN7-3_jlD6v1QR&Ev!%*euj&XW~_z9cO`G2wRp+>^&RU?UUm8g(J*7;=SAA{J_ zKE`Xy-6CM(CUG_?j$LviQK2vO(S2+qbWdiE-1%fn^3{G~%vyiv>TyYCkz;n<2`=-; zLU*2Z-!tNWNBIcp$t1-Cz3B)7l*?3}tE2+c<#eL(lq@jPG)^r6ON}$j_4U?GleOKZ zs+$)$1P~95ns;Dblc{f?MpXe0jcA}$F<>#=b%;6`TJ;NgKRi-Pzwh|XXn2{Y_1LKN!^u8uL){}Q$_sDu34Rfetlv(x_?Mdfx zIp{OwwF4(0O!I4y`{7V2dZ&rGwRn*XpeXg$iE7s19%lskvI6*MBoI*LP*Ci5b+S9^F#-2ifD8cuE^%mF}Q({$_K-jOpt#rdEbN$V|<)Mwz&Y_U)o@pEO^eC14gs|gfkZbI~-hTP6fXs}x5CSWzEVgkad zE}?pqIq@BCGr7<=3JPwZ!(ufey8Rg;-OiuHBPg2PL-b=smh zp+!DJ)Z|FIV@0C$UOVxDX*t&V_2>1_uRGcqvO-LbsWlHJakT?m_Cr5U?r&Tp9R?|w zCuhROn!zpbb&j}aPII*$eVRR6Q8H=T6q*Ek=a${=7K|mzoOh8$sk9d2AQpkVd|fk* zV&?cFC$WhaIfBhVkl72eO(S;JoDERF2Y&@Hu6xpbzMd$}hbDk1qx$ZEt2xi%84vVv zW>l6JSvRdZZqw?z68)S1+HiA5yt}kcYu#V2BuISagfr+vbKz%^Ie)ID^_5FHD%`$r zJ)Ve-r$C2P5&=dnwcRQ_vy;&FZlVGsd&V*}wJg<%QDL;cU5}udZO=aUFS31HS_8X? z>&aZRLMurkglp@QD7C6pf zK?ziV10PkCEWc|`m$Z4XkD6n|oqWC~R;i`Qng9?>2{3a;obBV&4{FIQ?LdOKq{Q+@ zd$HuxyRh-NZ@`AahpZ)yMVah9vb~*Hvz$dca4%B_nP5m%lYuLyP^d0)b{wA~uNl00 znM{uyid33NNdH=Tgy_60mw**mIhc+>3Q#emlo`AVf8#x*o?d1Og~pI8ZCMRcEEp-6 zZb_A6MS|$vo$#WlM=C+?%-$5q{Ig=mk%r{1}lt2T87Xq3-%|a8KKsu0{Q~ z>J`~+7`XZSx&k>)BVrtJw$5^f`>P5GC~enkU-5p`)nB*4OLtd^?1X{(gG-SI+}2$t0F#J;r-vb^zr zCQ~mPGxrn`fir5?PjdA}Wymb{&{Cn|%2?r#*&4Xcl!0TtS~)}*#P|X9tT$JYr9g%t zSeE;Do4g(=0MD=bFZnR}2%*iiXLNHw{JCpQ`9U-=V+Z_h<5{<1qhlQ99?A=eC5ow_*B$Z9BjEOCRKnI=6gXF&IRvkD~+^VSEUb zG<-NXT$vnSbo$0E4MFWVmWd&nT&sXrqp`wumEZH<}U)XsgDVoCE}+4pZCaur{f&Fl1vlle4dTd(;Fbj#@b z8FiMRGJ*ojHjH$ict>cdyb;z0>XMF#{H2ES`p zFgVj4$ch*w|DlDRNvB9tgE-M53zE3Ijty2Ug-OMya-|<9Q;qX|ZZD2##X&=;Wfj$w zl%qT1UgSxR#0wMGvw7h~U4Dxo#JwFQSR%^2@FF_rM`EGCX-2#{C*I`K34in)k3F*} z%Dn3ByeP7@FBu}}if?PO(o4cy?Ie|fr_3`nk-SACv%?Pzt&B3MIc_nnGH8E+MdBg^ zM2QS2^;8;;1we8cxCiqInUJ{WSKTgKm`R1AP56j_oJ%UcvInIh{Um4<12A*iLK%5b zl7Vu zgoBuT4kMG%>o{G&?oSsobM4A|pNt90CyKFyM~ijhJyc8I`;!t`Tz-aBkciS}9O0`r zap2(MvB5!`nP{2l1=?b@3Vc>h*AkN_4tl!(^4~2x#6eFxZy)sZ(c5N(o9m!-&*YiPPwtZu-E zwz%TKgoGxujw|K0qYP-Zqzr7e!*4Jj(BucF`(F4w3SPU7D=Gu-zayjZs3Am3t>XnZ z1U1fCd8XxouFh*!AHr<3>H4MKbjQ2kI#E$+uwxah>*Zf@8Qo$;Df@zmur;F0 ztJek$%Pu;Q^A?W&wMGL&z4L9fGr^9w(-bDqqSQZrXAr2#Ghd<^FVVY2c0?{fzvyLp zY_*6ZMHN(-%3TvtBn@ERs^hoULG%SrKxKwXrB%*S;A@W>FsnK=`V*Ht!xu!-vGJJ`)I!d3R`~Z9TH!8n9x_$z zBaIc3g97;EF6@OAKD2EaZ&(knyTX+>$?WrYc{6`K-kW#+6ysDc7(V4$o#9KjU09kT zq0ji$(k{|g!#Gi5mhyZhfh*MTTPzkJV{_gOKXEXV%cXTiV>}J5d74!soT&}W$;xEr zwC@OAC@}+n*lq6(1`Qd-mq&wbjPq+1Vv$1$@u0B9twPoPGX$7PDiip3IZjNAT8G4 zbr?mxI==YS*-~T*cyJTPQBKh8)U+!pd>_uT6fv47)H*&mhlAK)tWn1YZ-{MVS7wC^ zN$f1YZAER2HnBAheWj11^gn*p{6et^Xxz@ey1YzijJB~@a^##YltxB%B+Q)rQ&vcqDHL&N*{V)!aZejh_YH;0%P9CWYcwnp3^Htprs5-?J%!6!Bkt)L+S1q8wz-k`oFoy}TW-gXsc}Ad9(v@Q{NhETFN*sTY ztPPp4ovsU!EJv1|Z>48kvg>5W+`l88e4gun%>{XH<>+{+MIG_b zij-TBCA7~B!xJ?ZP<vKp4OXLj+bU#->F!fGmf_vQIFJ3n znM`T2WA&SpRgNUm(6qz?#{j8{jVS@?8k0K&M?Lh+bKWCTq<_7yUt!51t2axmD_gYW zG}B3ez4W!Qm_~#k2}R|a#~|2S=ofzQ;lwvSRhq&nie^7=y-Ns&%w=Xhy%y7)j_apX zS}6g3nMa$saM6_2hO%#xBSgpDaN!g(f;(O8AtCt024Ii|&2)uxzGSva$aHl6GRUs> zLF`M~MMvfIsaMuII@d5jy{U6RtuVJXnz$~?)K2Z18mPPKLAn;l0|fTE+m4LxCnxuh z;qfYf?`#|!58Togo!WQNF^VvG-0h{r*S`6~DIDD>Q|)yW>no9TKVoUdCXJ;g82W85 zcg%C!abc=WOimf97VZ$!1Xx0rILjgXP;2Jh5`(r8Z1ONTc1LjNcK6;4m2q@X*S7)? zHC!6kcG0Fv*0G_BwgNZ`&+s7tU8w&MnrN#eF~e)&y+r7reZZ+Pw@(y{a!F^27eXFs zLQl{1n%|4b=EC-z>Gf6$s&ChRU;tqRFq0dUYtd4+CF3^Zq!b!umZokj``70C4!Z+>pB-v6bzsmnv%~Z!e z+q~uWnqGAOrUXYPM_hC(_4J|Uc!5SDG($3o%w*k=roz4aEZ@%^)5Ax@jy9jsHovnG zNx0&)UhDSUHlIW05z@eQde`C3Mmn?4-;*I5Njh6P2MY~>#`t7KwG1b-u3xm`azE^r z)~$8kya@r&`H3s+R%nxz;PMy?-2I1u(a6u{C{_KOqQH_?Jvwj~41tNs^qcc%oi4AW zrSd&hWD82E^a<;mSh%NA8nFAk) zNNmqPpI<&B_|Vm(Fyq3f#XwVNR=cgH-qfWQ&RJK_tgMX*aX>1z#~Uc~1MnrTxlDN; z679fR03|-ohl|Zru((OI!!Q}NTMK0Acz4|Nv@uL@zyGPAR%EoqYsZ>s0L*WwyF*4cD0@!4ZonFcs%pUsSrY{?zyA#@@&@51h zsO_FTfplK=-?eqPq{vW~x<42EXlj9OotZnRTc4*E_%z^bwYKwnR9YeG*s`FN!PkY^ zeuH9Zs-A$g zPij|{%z6O3(6YI7f40n5e`AP)e$!pWOwQn3JIxkl=Ir2s7tafJJ2pIY)t0U}bPrQA z0*dSDenhjU{G#H)yv@}e+IDnVjZ92^;!yrlhH>Tn5QepcFQSguKb`2#io3}68W|-g zp+9k>K;6|q;VX6uL7DfD#^a|-!WaM>DfM$+wMUP!5X(WGe{D5USkw{B6?K04+h*fA z+(r35lxiSZNN4Y`Zo2$PIN&3s2jRH}qx%0=h5_bAfcb9x9Z&0Lu3Wm@+0)@6*gN0w zESi1cmrgo!<)Yf`3qHffB6b&CAVGL!dID%9)|9s-v-#HV;%N5xLo+O&Z450fs)EGU z=RCAhcVfjvSnAj+O22exahBh6C>Er$-AAt2ohHvm9(IZ{&p%ohit&I!hElkO6eb6l zdH$TBRA%h($4^*?o|9{xyF0{O-36Ol>8SZ4*&y}mWcr?+!jZm$Dr4i-m~f#|k1a;S zEk?r=MO!E{`h_Gxxa0*lZ6pxH(PQ@APpvQ>^K;a9=~MT#gtJzECU3QcfQAXOJE@jf zjP$8{*wSYePJcBQ)0l!O>DD(VdhpH=9Vf3rxbenx>f5FcuZGyrIp<)T$TA-#yB?yj zgdQ#6qLd{6CFFMIMTeirm0$>;DD@xzDXB5SZ4M3K<<#4*<}c>FYEh8cetD6ZT3jw% z`qr3kj4*Qm$cXC?qSUYF*fEfxDfG@%9}3E@IUg?c0dEDRV5uB5q-=60l0CiKK4^w% z$_4+|Mq33;V=IKw-m!9<(f;>uo%q#N83D# zZHl;zWY24T0gotk<`-I~m6Rk&BP>55%z^=wUMSLr(I`s2=7LyZ2la@EE zUh`sUdA{#r&!CSl9DTFQ6>0L#J&1`N{&cYu0k0BBzr&xFne|3TGN0EhsZ=RbK-Q2D zHMLAsFn!s9nixn7({kzCCQ69rY?5XWQBeVl5&W%U4GsX4t)-@MJEo`Vrmp#{??M8C z`@{?Wjt%HWJ8o_^Ht9#=mEeD+u|>S%t-Z$6m` zP6n^(FXg)7{d$w)5mYRcy9;?(t9=(mvtNECq@T>3bbKoyWl}}vNp~GzLO1-PnJHXX zwm=(y#%*LL)6ajYg*oz69U`=dkCs$e&p*&wwLm~W!9cFHDRKKGz_S^|VJOHR`oy`A znUpEaK0D8CK2iFZ=faLQ9h(A`bb!KQZ+KvgB7J@?6vXF%xX;ESYc0Lvu3+f-)nHZn z?MMnn2eC3_lIlcqfJQ;s(2VK3D81^lPRnBqUUD{@g;-f=4QUKe!6jQ}K$s3jRaA!J zI6HEK@YiqKaf(8%%8`xBb6^+b$84&i}&O^RZD1W+$6eDIv-PkqA%N zqJdseB1&EJJ07aKs<7fhaC_)_l1CgIAj?e$2b9Q|;0>3$2ODYt9ba4Mja&+y50?ta zZDv*XS!|O$Zug&BO#J^fb}q1W)pZ=dyXUl>!Zc_Mk(bgb>)7sGR|cacA`Bb_i(>_h zVUYE;wbIAj?HFT3h#LU{X}DfExzdr$2`3ur9Eq!4w0VNMe@alzmyM8p{U ze1HG{|J-v+M_jTn+H?M|^Lu`OkH7N?7AN&D{ll3MF2;y4ecDdSR5(bryS0)c!lcyr z_w;S_4W^lUvahFqWMToi<2SrnEHF2~rY;5Iu0Ihe1j_N$GCKz-XgH1}y9cE_bwFS@oGriJSD4m;ImRa70{~3N)NLW`Z;NifZ8t5T*u=kaF3j z%7nSpp|t5iJ_bsmdjBVk(R{DhaF&!5u9Bq-t9ss<@=>o|Cm@l2TX2e=rLlI#pMkM@ zNzi5BjO=uUCMjQwa8ka;mOG*ODbY*AeXDDRN~w-o>k_~8nLu9%D{$Ti9eU@>86a=w zNOSvonw;!B*e}!`gh?$a7MoBajds3rLws6b7=mPox<$X8)uc9~*#Y8aJ(D;F80R<7 z(IwFxw^&CCn2gzQddr(fREwrx062)$XAT@**Lss^YMt|6yqn1z4i}uwkq&RVHwX`W z{HNh^u_MEF7d7z><~5W@ZD0nH=xalDrYA>fJx=v#|o-TK9rr8#@&WYvOiWj)4jBsvPk1 zCeg#K=2R)O$GSDu^=`>rlv|3P9z_f=4Y3p&uTq+522WUt6c}BpR`bk|GN^HZR3?cg zCD0FVhj^iyvq?uOEEv>!7$YS{uh***94pr}s3pP4dXpt4i!41#Hk?FTmWi(?CEC1u zEI{#=J)uRt{ML%h{-SFd7}!h=Grw`bBI+Kie>QDiTBkGgU=OFj5#S^xEG;da%6J>?G0JM%05{LvOx2 zhmx%(Gd~)`%eV7a0@gBzfzJDX5YSxi#m8pFK-1itfIP$_H;I?vhsPs`*^ZEF?cqMx zvUFsl$3TOTTK9>EoRJzlc@J%TWcL%Hkjj$?2DAJI27wVR}9YAB-Wqt28ZG8(kgu?J5`79A53tkPB$6jaG(O`5(M z1UN)-Hqwdj{O%L|@~H}t>k|VWT9kd3M3+A7{5Z^eD3AS%m<_h^d7sgx--oG0P8Od~ z9=?H$43$JZch?Mzc-eWq?9i%pft=T4dcVqErKsl)*b?dskebYs2QFcvnd6-`EDwqE z1)D?mI-t_Bzi}AN*W`<;FiSPk#zaZ{@_tDNb^`TiH=2BeyEAKGOkVRQ0BuhnmP1Cc zxBcl^d9VJ{M>3IJ;%L3WD`pfsh`V0l=t8P&bk_@ri%hEQ%=LRyTUIUugw9Cg@txl) zT8VX6T9_`W04E&0eb#l=J@cHctK#Ze7>k3zR4_c+f7kFy{o*9Z+{(fhvWU3oyYBL{ zF?V$!@_=-9SuW7~Ch+v-ywFRcIlmMD#N)oL6Ojsx(G6S8ya>hvW~D>Qc(Y0i(pld3 z4mmiQv!?N<8a`p`Wq_@@a~$p--)3OHiD4%w9g5ZDl@lrm-N1y5nQ-^aOp)lV=YMDV64HAAD$}d5mR%(&)teEu|_HD%J1VlZG2P2#c_3wbJ&N|7Il|kmTR! z(V;r(@VX}Tt$o2uxd&b?7D54?7Z;`YQ~Lx)OWrWTq;pSo-W--ovt-nYG>UWVG&5dq z!`|C$=6K+IpVG~3TISk{fZRWvSg|3sGX|A<)c{^@C-sYV4++Upi%K&<4W+OY%2b;h zk9$05JpOFQhwUqDD!2a{lxf^~9BaqWv-@qmqe~tsPKd+_T=cUmeQ*skB#o|l?cfMa zq6mw_ZYOa0lVGd=x*}afEtr+$55FX|E5&R$5&)Q~ZYg|A!qErSzkxEIR5^GO{qR~7 zV)8%S5mNPJ=O>NN$Cbfgz1~Xk&yVO8&QL!OXDQGviMr_LflN#tWN#MfE8-HecT{bl zeFkuLc#_{*6#auEnW=2jKn5~ktyinMc{aK zcYUmBm6aR0;uKxbh9kzjW&tZ!ZncTy`CZ$ce~kMzoL)%7bQyoUl;1@@4g_DZ{6w5S z#*tK4(sELF>ixbypO^0f0c*sNOIPHhZc@+={Bp;RW8;^|6!DwzOBL>&u#2NJC+~)P zZa;-|ZU-}X13)7?oxoFg9M6y4pm_90TiR$;rnE#gj7ajYKN?;pkpPhMP@`GU2r~hr zmIsePUOo^+9>DwSkL)!N64#l&vz^>45bb*j>lQI%IH*1dKxir2S8@J6t#Kc{*t*0* zDWDl0s^ctzQubM1o}X*sH~{AQF8X2MM{TmwlNAMGRD^CT>GYMoH*@1gg;|$i-Udw5 z{9%;qXnzvFcFEe5pG&!W-hWzO2Lgh@_lUiQSdo5z`QvJGhscj@ooOoc-y57@v;24X^u7H!aO=jlg zny_2NJZ?&Y9mpo-l;bO0^P=~E%|EtOaC_VK0KTDmPbYPDpGK8tihV6}*w;l4X~h=I zX7uV(Z}sZn+({k}#hnuwX3Vb`CqV_pZGMS&E|GXht2N8lbgGt`ib-X=mam!Iw0x7U zD)9SC&26r(eXq#{O{|tghbkG+*UR-%@tM1!eLM%5P1fW{Y@2Sa{=Cl*6Q52|v#bUs zWPvjd@GP^sInF1vMVALI^UeQxataZz3RBc=0Yi%{p;GRx zS5Zg#cmG0K2hel6a&8E-Hhf_;4qMG=Dm}H!utplnIpjFAk}O|o0Y^4JFkMg@&`$E} z_F5{sL-0P(2qi01MAl&qKHvV2-|O8xq(GQ;utNXKQpKr^b8i>1<1ENPfwg>Ej=N{m z=5z&Waie>^*8H7=Poj4ocZn@7qeU(pV%LO0_$IJa*I@d(^#a96oOmQgC?HZKg7s$k- zzYr|xAfB+Dtfefs(8K7}s$nHbpY(^X5?owuxd^SL=*^xB1_%2nxy_yv3FtrAcHsbZ zv+%-5TNq!kD&WB1QmSklkJdf9@+<9~tJ}&K4_@C^S=BX!hU*>}<)0vCB_8JZtLHT` zJRTRnEJLD=wrJBWprX zET6l)wbF4@`d<2Y%MyxFc$_POu97lpExWx}vSVWL&b{?0W5$m?+0j`*SGATezy#q_ zU1nb&@^mB_7U+(HG5tvj7S>i_Dcfo}J3MLA^*g#Xe0>X{43uIkDzBPWko}Bdf|eyq z(>*BAa%kgBH`FT_q$-#78ek_YpbRI5F{TEJrMkkBi5gkU3Mt=>cWxt+N?Iw`eathL zm_QAtrZgZzCyc;tg8hoS?T^tPlf6`@4t$9uz>xf>au|V%#EUn~WRvtPCfryzcw#N)@C5T=C)-Lm61w#t^^Z4QqXb|!xpb2}lPtAv>) zEvPak48c~C_`v)czmZ|BipuAB_YDK`A^^2>ch{MTek7U8&%nkH?vsisJb$L&=EBVc z6^}j#93r-(X2+zaS==%J`vw`PkGeBE_4SV0AIW+-?RSYIgh-5DA$miH+{zZm)GBu zy})U7V8!(3{+nCSno}<@{jKjA8Xag}I{lf$D-RTF9vxjVed^&O=iONI=qQh#c+y*q zS7(3PeIq~p}{\va{$\langle$tex-file$\rangle$}} +\schemedisplay +(call-slatex ) +\endschemedisplay +when you need to call SLaTeX on the (La)TeX file +\scheme{}. This invokes the SLaTeX preprocessor on +\scheme{}. If your Scheme has a +\scheme{system} procedure +that can call the operating system command line, +\scheme{call-slatex} will also send your file to TeX or +LaTeX. If your Scheme does not have such a procedure, +\scheme{call-slatex} will simply prod you to call TeX +or LaTeX yourself. +\slatexdisable{enableslatex} + +The outline of the shell script or +\p{callsla.scm} or of any strategy you devise for +using SLaTeX should include the following actions: + +1. Load the file \p{slatex.scm} (created by the +configuration process) into Scheme/Common Lisp. + +2. \enableslatex +Set the variable \scheme{slatex::*texinputs*} to the +path \p{TEXINPUTS} or \p{TEXINPUT} used by +TeX\f{There is some variation on the name of +this environment variable. Unix TeXs prefer +\p{TEXINPUTS} with an \p{S}, while OS/2 and DOS (e.g., +Eberhard Mattes's emTeX) favor the 8-letter \p{TEXINPUT} --- +no \p{S}.} +to look for +\slatexdisable{enableslatex} +\p{\input} +files. + +3. \enableslatex +Call the procedure +\scheme{slatex::process-main-tex-file} on the \p{.tex} +file to be processed. +\slatexdisable{enableslatex} + +4. Call either \p{latex} or \p{tex} on the \p{.tex} file. + +\enableslatex +You may devise your own way of calling +\scheme{slatex::process-main-tex-file}, provided your +method makes sure that \p{slatex.scm} has been +loaded, \scheme{slatex::*texinputs*} set appropriately +{\it before\/} the call and \p{latex}/\p{tex} is called +{\it after\/} the call. + +Note that if you prefer to stay in Scheme/\allowbreak +Common Lisp most of the time, it is a good idea to +pre-load the procedure \scheme{call-slatex}, perhaps +through an ``init'' file. \scheme{call-slatex} is just +a small ``call-by-need'' hook to SLaTeX and +does not take up much resources. (Global name clashes +between your own code and SLaTeX code won't occur +unless you use variable names starting with +``\scheme{slatex::}'') If you made no calls to +\scheme{call-slatex}, the bigger file \p{slatex.scm} +is not loaded at all. If you make several calls to +\scheme{call-slatex}, +\p{slatex.scm} is loaded only once, at the time of +the first call. +\slatexdisable{enableslatex} + +\subsection{Dialects SLaTeX runs on} + +\index{dialects SLaTeX runs on} +SLaTeX is implemented +\enableslatex +in R5RS-compliant~\cite{r5rs} Scheme (macros are not +needed). The code uses the non-standard procedures +\scheme{delete-file}, +\scheme{file-exists?} and \scheme{force-output}, but +a Scheme without these procedures can also run SLaTeX +(the configuration defines the corresponding +variables to be dummy procedures, since they are not +crucial). The distribution comes with code to allow +SLaTeX to run also on Common Lisp. The files \p{readme} and +\p{install} contain all the information +necessary to configure SLaTeX for your system. +\slatexdisable{enableslatex} + +SLaTeX has been tested successfully in the following +dialects: + +1. On Unix: Allegro Common Lisp; Bigloo; Chez Scheme; +CLISP; Elk; Gambit; +Gnu Common +Lisp; Guile; +Ibuki Common Lisp (1987); MIT C Scheme; Scheme-to-C; SCM; +STk; UMB Scheme; VSCM. + +2. On Windows 95: MzScheme. + +3. On OS/2: CLISP; SCM. + +4. On MS-DOS: Austin Kyoto Common Lisp; CLISP; MIT C +Scheme; SCM. +%PCScheme/Geneva + +5. On Mac OS: Macintosh Common Lisp 3.0. + +If your Scheme is not mentioned here but {\it is\/} +R5RS-compliant, please send a note to the author at +\p{dorai@cs.rice.edu} describing your Scheme's +procedures for deleting files, testing file existence, +and forcing output, if any, and the configuration file +will be enhanced to accommodate the new dialect. + +Bug reports are most welcome --- send to +\p{dorai@cs.rice.edu}. +\index{bug reports} + +\section{References} + +\bibliographystyle{plain} + +\iffileexists{slatxdoc.bib} +{\bibliography{slatxdoc}} +{\bibliography{bigbib}} + +\section{Index} + +%\begincolumns2 +\inputindex +%\endcolumns + +\bye diff --git a/collects/slatex/slatex-code/structs.scm b/collects/slatex/slatex-code/structs.scm new file mode 100644 index 00000000..d947a69c --- /dev/null +++ b/collects/slatex/slatex-code/structs.scm @@ -0,0 +1,107 @@ +;structs.scm +;SLaTeX v. 2.3 +;Structures used by SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-within slatex + + (defvar slatex::*max-line-length* 200) + + (defenum + ;possible values of =space + slatex::&void-space + slatex::&plain-space + slatex::&init-space + slatex::&init-plain-space + slatex::&paren-space + slatex::&bracket-space + slatex::"e-space + slatex::&inner-space) + + (defenum + ;possible values of =tab + slatex::&void-tab + slatex::&set-tab + slatex::&move-tab + slatex::&tabbed-crg-ret + slatex::&plain-crg-ret) + + (defenum + ;possible values of =notab + slatex::&void-notab + slatex::&begin-comment + slatex::&mid-comment + slatex::&begin-string + slatex::&mid-string + slatex::&end-string + slatex::&begin-math + slatex::&mid-math + slatex::&end-math) + + (defrecord slatex::make-raw-line + slatex::=rtedge + slatex::=char + slatex::=space + slatex::=tab + slatex::=notab) + + (define slatex::make-line + (lambda () + ;makes a "line" record + (let ((l (make-raw-line))) + (setf (of l =rtedge) 0) + (setf (of l =char) (make-string *max-line-length* #\space)) + (setf (of l =space) (make-string *max-line-length* &void-space)) + (setf (of l =tab) (make-string *max-line-length* &void-tab)) + (setf (of l =notab) (make-string *max-line-length* &void-notab)) + l))) + + (defvar slatex::*line1* (make-line)) + (defvar slatex::*line2* (make-line)) + + (defrecord slatex::make-case-frame + slatex::=in-ctag-tkn + slatex::=in-bktd-ctag-exp + slatex::=in-case-exp) + + (defrecord slatex::make-bq-frame + slatex::=in-comma slatex::=in-bq-tkn slatex::=in-bktd-bq-exp) + + (defvar slatex::*latex-paragraph-mode?* 'fwd1) + + (defvar slatex::*intext?* 'fwd2) + (defvar slatex::*code-env-spec* "UNDEFINED") + + (defvar slatex::*in* 'fwd3) + (defvar slatex::*out* 'fwd4) + + (defvar slatex::*in-qtd-tkn* 'fwd5) + (defvar slatex::*in-bktd-qtd-exp* 'fwd6) + + (defvar slatex::*in-mac-tkn* 'fwd7) + (defvar slatex::*in-bktd-mac-exp* 'fwd8) + + (defvar slatex::*case-stack* 'fwd9) + + (defvar slatex::*bq-stack* 'fwd10) + + (define slatex::display-space + (lambda (s p) + (cond ((eq? s &plain-space) (display #\space p)) + ((eq? s &init-plain-space) (display #\space p)) + ((eq? s &init-space) (display "\\HL " p)) + ((eq? s &paren-space) (display "\\PRN " p)) + ((eq? s &bracket-space) (display "\\BKT " p)) + ((eq? s "e-space) (display "\\QUO " p)) + ((eq? s &inner-space) (display "\\ " p))))) + + (define slatex::display-tab + (lambda (tab p) + (cond ((eq? tab &set-tab) (display "\\=" p)) + ((eq? tab &move-tab) (display "\\>" p))))) + + (define slatex::display-notab + (lambda (notab p) + (cond ((eq? notab &begin-string) (display "\\dt{" p)) + ((eq? notab &end-string) (display "}" p))))) + ) diff --git a/collects/slatex/slatex-code/tex2html.css b/collects/slatex/slatex-code/tex2html.css new file mode 100644 index 00000000..c78da2ae --- /dev/null +++ b/collects/slatex/slatex-code/tex2html.css @@ -0,0 +1,68 @@ +body { + color: black; + background-color: white; + margin-top: 2em; + margin-left: 8%; +} + +.chapterheading { +/*color: #cc0000;*/ +color: purple; +/*font-family: verdana, serif;*/ +font-size: 70%} + +.subject { +/*margin-left: 0%;*/ +color: #cc0000; +/*font-family: verdana, serif;*/ +/*color: purple;*/ +/* text-align: center;*/ +} + +h1,h2,h3,h4,h5,h6 { + color: navy; +/* font-family: verdana, serif;*/ + margin-left: -4%; + margin-top: .5em +} + +.bibitem {color: purple} + +.verbatim {color: darkgreen} + +/*code { +font-weight: bold +}*/ + +.scheme .punctuation {color: brown} + +/*.scheme .punctuation code {color: brown; +font-weight: normal}*/ + +.scheme .keyword {color: #cc0000; + font-weight: bold; +} + +.scheme .variable {color: navy; +/* font-style: italic; */ +} + +.scheme .global {color: purple} +.scheme .selfeval {color: green} +.scheme .comment { +/*font-family: serif;*/ +color: teal} + +.takenotice {color: red} + +.smallprint { + color: gray; + font-size: 50%; +} + +.smallprint hr { + text-align: left; + width: 40%; +} + +.footnote {font-weight: bold} diff --git a/collects/slatex/slatex-code/tex2html.tex b/collects/slatex/slatex-code/tex2html.tex new file mode 100644 index 00000000..56471fe0 --- /dev/null +++ b/collects/slatex/slatex-code/tex2html.tex @@ -0,0 +1,810 @@ +% tex2html.tex +% Dorai Sitaram, Apr 1997 + +\message{version 3p} + +% TeX files using these macros +% can be converted by the program +% tex2html into HTML + +\let\texonly\relax +\let\endtexonly\relax + +\texonly + +\ifx\slatexignorecurrentfile\UNDEFINED\relax\fi + +\def\defcsactive#1{\defnumactive{`#1}} + +\def\defnumactive#1#2{\catcode#1\active + \begingroup\lccode`\~#1% + \lowercase{\endgroup\def~{#2}}} + +% gobblegobblegobble + +\def\gobblegroup{\bgroup + \def\do##1{\catcode`##1=9 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \gobblegroupI} + +\def\gobblegroupI#1{\egroup} + +\def\gobbleencl{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \futurelet\gobbleenclnext\gobbleenclI} + +\def\gobbleenclI{\ifx\gobbleenclnext\bgroup + \let\gobbleenclnext\gobblegroupI + \else\let\gobbleenclnext\gobbleenclII\fi + \gobbleenclnext} + +\def\gobbleenclII#1{% + \def\gobbleenclIII##1#1{\egroup}% + \gobbleenclIII} + +% \verb +% Usage: \verb{...lines...} or \verb|...lines...| +% In the former case, | can be used as escape char within +% the verbatim text + +\let\verbhook\relax + +\def\verbfont{\tt} +%\hyphenchar\tentt-1 + +\def\verbsetup{\frenchspacing + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\|=12 % needed? + \verbfont} + +% The current font is cmtt iff fontdimen3 = 0 _and_ +% fontdimen7 != 0 + +\def\checkifusingcmtt{\let\usingcmtt n% + \ifdim\the\fontdimen3\the\font=0.0pt + \ifdim\the\fontdimen7\the\font=0.0pt + \else\let\usingcmtt y\fi\fi} + +% In a nonmonospaced font, - followed by a letter +% is a regular hyphen. Followed by anything else, it is a +% typewriter hyphen. + +\def\variablelengthhyphen{\futurelet\variablelengthhyphenI + \variablelengthhyphenII} + +\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI + a-\else{\tt\char`\-}\fi} + +\def\verbavoidligs{% avoid ligatures + \defcsactive\`{\relax\lq}% + \defcsactive\ {\leavevmode\ }% + \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% + \defcsactive\^^M{\leavevmode\endgraf}% + \checkifusingcmtt + \ifx\usingcmtt n% + \defcsactive\<{\relax\char`\<}% + \defcsactive\>{\relax\char`\>}% + \defcsactive\-{\variablelengthhyphen}% + \fi} + +\def\verbinsertskip{% + \let\firstpar y% + \defcsactive\^^M{\ifx\firstpar y% + \let\firstpar n% + \verbdisplayskip + \aftergroup\verbdisplayskip + \else\leavevmode\fi\endgraf}% + \verbhook} + +\def\verb{\begingroup + \verbsetup\verbI} + +\newcount\verbbracebalancecount + +\def\verblbrace{\char`\{} +\def\verbrbrace{\char`\}} + +\def\verbescapechar#1{% + \def\escapifyverbescapechar{\catcode`#1=0 }} + +\verbescapechar\| + +{\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\gdef\verbI#1[\verbavoidligs + \verbinsertskip\verbhook + \if#1{\escapifyverbescapechar + \def\{[\char`\{]% + \def\}[\char`\}]% + \def\|[\char`\|]% + \verbbracebalancecount0 + \defcsactive\{[\advance\verbbracebalancecount by 1 + \verblbrace]% + \defcsactive\}[\ifnum\verbbracebalancecount=0 + \let\verbrbracenext\endgroup\else + \advance\verbbracebalancecount by -1 + \let\verbrbracenext\verbrbrace\fi + \verbrbracenext]\else + \defcsactive#1[\endgroup]\fi + \verbII +]] + +\def\verbII{\futurelet\verbIInext\verbIII} + +{\catcode`\^^M\active% +\gdef\verbIII{\ifx\verbIInext^^M\else% + \defcsactive\^^M{\leavevmode\ }\fi}} + +\let\verbdisplayskip\medbreak + +% \verbinput FILENAME +% displays contents of file FILENAME verbatim. + +\def\verbinput#1 {{\verbsetup\verbavoidligs\verbhook + \input #1 }} + +\def\verbfilename#1 {\relax} +\let\verbwrite\gobbleencl + +% \path is like \verb except that its argument +% can break across lines at `.' and `/'. + +\def\path{\begingroup\verbsetup + \pathfont + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \verbI} + +\let\pathfont\relax + +% \url{URL} becomes +% URL in HTML, and +% URL in DVI. + +% A-VERY-VERY-LONG-URL in a .bib file +% could be split by BibTeX +% across a linebreak, with % before the newline. +% To accommodate this, %-followed-by-newline will +% be ignored in the URL argument of \url and related +% macros. + +\def\url{\bgroup\urlsetup\let\dummy=} + +\def\urlsetup{\verbsetup\urlfont\verbavoidligs + \catcode`\{1 \catcode`\}2 + \defcsactive\%{\urlpacifybibtex}% + \defcsactive\ {\relax}% + \defcsactive\^^M{\relax}% + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \defcsactive\`{\relax\lq}} + +\let\urlfont\relax + +\def\urlpacifybibtex{\futurelet\urlpacifybibtexnext\urlpacifybibtexI} + +\def\urlpacifybibtexI{\ifx\urlpacifybibtexnext^^M% + \else\%\fi} + +% \mailto{ADDRESS} becomes +% ADDRESS in HTML, and +% ADDRESS in DVI. + +\let\mailto\url + +% \urlh{URL}{TEXT} becomes +% TEXT in HTML, and +% TEXT in DVI. + +% If TEXT contains \\, the part after \\ appears in +% the DVI only. If, further, this part contains \1, +% the latter is replaced by a fixed-width representation +% of URL. + +\def\urlh{\bgroup\urlsetup + \afterassignment\urlhI + \gdef\urlII} + +\def\urlhI{\egroup + \bgroup + \let\\\relax + \def\1{{\urlsetup\urlII}}% + \let\dummy=} + +% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes +% HTML-TEXT in HTML, and +% DVI-TEXT in DVI + +\def\urlhd{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 + \urlhdI} + +\def\urlhdI#1#2{\egroup} + +% + +\let\ignorenextinputtimestamp\relax + +% + +\let\htmlonly\iffalse +\let\endhtmlonly\fi + +\def\rawhtml{\errmessage{Can't occur except inside + \string\htmlonly}} +\def\endrawhtml{\errmessage{Can't occur except inside + \string\htmlonly}} + +\let\htmlheadonly\iffalse +\let\endhtmlheadonly\fi + +\let\htmlstylesheet\gobblegroup + +% color (deprecated) + +\let\rgb\gobblegroup +\let\color\gobblegroup + +% Scheme + +\let\scm\verb +\let\scminput\verbatiminput + +\def\scmfilename#1 {\relax} +\let\scmdribble\scm +\let\scmwrite\gobbleencl + +\let\scmkeyword\gobblegroup +\let\setkeyword\gobblegroup % SLaTeX compat + +\ifx\slatexversion\UNDEFINED +\def\schemedisplay{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemedisplayI}% +\fi + +{\catcode`\|0 |catcode`|\12 + |long|gdef|schemedisplayI#1\endschemedisplay{% + #1|endgroup}} + +% GIFs + +\let\gifdef\def + +\def\gifpreamble{\let\magnificationoutsidegifpreamble\magnification + \def\magnification{\count255=}} + +\def\endgifpreamble{\let\magnification\magnificationoutsidegifpreamble} + +\let\htmlgif\relax +\let\endhtmlgif\relax + +% Cheap count registers: doesn't use up TeX's limited +% number of real count registers. + +% A cheap count register is simply a macro that expands to the +% contents of the count register. Thus \def\kount{0} defines a +% count register \kount that currently contains 0. + +% \advancecheapcount\kount num increments \kount by n. +% \globaladvancecheapcount increments the global \kount. +% If \kount is not defined, the \[global]advancecheapcount +% macros define it to be 0 before proceeding with the +% incrementation. + +\def\newcheapcount#1{\edef#1{0}} + +\def\advancecheapcounthelper#1#2#3{% + \ifx#2\UNDEFINED + #1\edef#2{0}\fi + \edef\setcountCCLV{\count255=#2 }% + \setcountCCLV + \advance\count255 by #3 + #1\edef#2{\the\count255 }} + +\def\advancecheapcount{\advancecheapcounthelper\relax} +\def\globaladvancecheapcount{\advancecheapcounthelper\global} + +% title + +\let\title\gobblegroup + +\def\subject#1{\centerline{\bf#1}\medskip} + +% plain's \beginsection splits pages too easily + +%\def\beginsection#1\par{\sectionwithnumber{1}{}{#1}} + +\def\beginsection{\vskip-\lastskip + \bigbreak\noindent + \bgroup\bf + \let\par\sectionafterskip} + +\def\beginsectionstar*{\beginsection} + +% plain's \{left,center,right}line can't handle catcode change +% within their argument + +\def\leftline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \let\dummy=} + +\def\leftlinefinish{\hss\egroup} + +\def\centerline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \hss\let\dummy=} + +\def\rightline{\line\bgroup\hss\let\dummy=} + +% + +\let\strike\fiverm % can be much better! + +% + +\let\htmlpagebreak\relax + +\let\htmlpagelabel\gobblegroup + +\def\htmlpageref{\errmessage{Can't occur except inside + \string\htmlonly}} + +% Miscellaneous stuff + +\def\hr{$$\hbox{---}$$} +\def\hr{\medbreak\centerline{---}\medbreak} +%\def\hr{\par\centerline{$*$}\par} +%\def\hr{\smallskip\line{\leaders\hbox{~.~}\hfill}\smallskip} + +%Commonplace math that doesn't require GIF. (Avoiding $ +%here because $ triggers GIF generation.) + +\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} +\def\closemathg{$} + +\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} +\def\closemathdg{$$} + +\def\frac#1/#2{{#1\over#2}} + +% + +% Backward compatible stuff + +\let\p\verb +\let\verbatim\verb +\let\verbatimfile\verbinput +\let\setverbatimescapechar\verbescapechar +\let\scmp\scm +\let\scmverbatim\scm +\let\scmverbatimfile\scminput +\let\scmfile\scmdribble +\let\scmfileonly\scmwrite +\let\href\urlhd + +\endtexonly + +\ifx\newenvironment\UNDEFINED\else +% we're in LaTeX and so won't load rest of file +\endinput\fi + +\texonly + +\input btxmac + +% Sections + +\def\tracksectionchangeatlevel#1{% + \expandafter\let\expandafter\thiscount\csname + sectionnumber#1\endcsname + \ifx\thiscount\relax + \expandafter\edef\csname sectionnumber#1\endcsname{0}% + \fi + \expandafter\advancecheapcount + \csname sectionnumber#1\endcsname 1% + \ifx\doingappendix0% + \edef\recentlabel{\csname sectionnumber1\endcsname}% + \else + %\count255=\expandafter\csname sectionnumber1\endcsname + \edef\recentlabel{\char\csname sectionnumber1\endcsname}% + \fi + \count255=0 + \loop + \advance\count255 by 1 + \ifnum\count255=1 + \else\edef\recentlabel{\recentlabel.\csname + sectionnumber\the\count255\endcsname}\fi + \ifnum\count255<#1% + \repeat + \loop + \advance\count255 by 1 + \expandafter\let\expandafter\nextcount\csname + sectionnumber\the\count255\endcsname + \ifx\nextcount\relax + \let\continue0% + \else + \expandafter\edef\csname + sectionnumber\the\count255\endcsname{0}% + \let\continue1\fi + \ifx\continue1% + \repeat} + +% Vanilla section-header look -- change this macro for new look + +\def\sectionstar#1*#2{\vskip-\lastskip + % #1=depth #2=heading-text + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{#1}{}{#2}{\folio}}}% + \temp}% + \goodbreak + \vskip1.5\bigskipamount + \noindent + \hbox{\bf\vtop{\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright#2}}% + \bgroup\let\par\sectionafterskip} + +\def\sectionwithnumber#1#2#3{\vskip-\lastskip + % #1=depth #2=dotted-number #3=heading-text + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{#1}{#2}{#3}{\folio}}}% + \temp} + \goodbreak + \vskip1.5\bigskipamount + \noindent + \hbox{\bf#2\vtop{\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright#3}}% + \bgroup\let\par\sectionafterskip} + +% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% +% \string\vtop{\string\hsize=.7\string\hsize +% \string\noindent\string\raggedright\space #3}\string\par}}\temp + +\def\sectionafterskip{\egroup\nobreak\medskip\noindent} + +\def\sectiond#1{\count255=#1% + \ifx\usingchapters1\advance\count255 by 1 \fi + \edef\sectiondlvl{\the\count255 }% + \futurelet\sectionnextchar\sectiondispatch} + +\def\sectiondispatch{\ifx\sectionnextchar*% + \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else + \tracksectionchangeatlevel{\sectiondlvl} + \def\sectioncontinue{\sectionwithnumber{\sectiondlvl}% + {\recentlabel\enspace}}\fi + \sectioncontinue} + +\def\section{\sectiond1} +\def\subsection{\sectiond2} +\def\subsubsection{\sectiond3} +\def\paragraph{\sectiond4} +\def\subparagraph{\sectiond5} + +\let\usingchapters0 + +\def\chapter{\global\let\usingchapters1% +\futurelet\chapternextchar\chapterdispatch} + +\def\chapterdispatch{\ifx\chapternextchar*% + \let\chaptercontinue\chapterstar\else + \tracksectionchangeatlevel{1}% + \def\chaptercontinue{\chapterhelp{\recentlabel}}\fi + \chaptercontinue} + +\def\chapterstar*#1{% + % #1=heading-text + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{1}{}{#1}{\folio}}}% + \temp}% + \vfill\eject + \null\vskip3em + \noindent + \hbox{\bf\vtop{\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright#1}}% + \bgroup\let\par\chapterafterskip} + +\def\chapterhelp#1#2{% + % #1=number #2=heading-text + \tocactivate + {\let\folio0% + \edef\temp{\write\tocout{\string\tocentry{1}{#1\enspace}{#2}{\folio}}}% + \temp}% + \vfill\eject + \null\vskip3em + \noindent + \ifx\doingappendix0% + \hbox{\bf Chapter #1}\else + \hbox{\bf Appendix #1}\fi + \vskip 1em + \noindent + \hbox{\bf\vtop{\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright#2}}% + \bgroup\let\par\chapterafterskip} + +\def\chapterafterskip{\egroup\nobreak\vskip3em \noindent} + +\let\doingappendix=0 +\def\appendix{\let\doingappendix=1% + \count255=`\A% + \advance\count255 by -1 + \expandafter\edef\csname + sectionnumber1\endcsname{\the\count255 }} + +% toc + +\let\tocactive0 + +\def\tocoutensure{\ifx\tocout\UNDEFINED + \csname newwrite\endcsname\tocout\fi} + +\def\tocactivate{\ifx\tocactive0% + \tocoutensure + \tocsave + \openout\tocout \jobname.toc + \global\let\tocactive1\fi} + +\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} + +\def\tocsave{\openin0=\jobname.toc + \ifeof0 \closein0 \else + \openout\tocout Z-T-\jobname.tex + \let\tocsaved 0% + \loop + \ifeof0 \closeout\tocout + \let\tocsaved1% + \else{\tocspecials + \read0 to \tocsaveline + \edef\temp{\write\tocout{\tocsaveline}}\temp}% + \fi + \ifx\tocsaved0% + \repeat + \fi + \closein0 } + +\def\tocentry#1#2#3#4{% + %#1=depth #2=secnum #3=sectitle #4=secpage + \ifnum#1=1\medbreak\begingroup\bf + \else\begingroup\fi + \noindent\hskip #1 em + #2% + \vtop{\hsize=.7\hsize + \raggedright + \noindent {#3}, + #4\strut}\endgroup\par} + +\def\tableofcontents{% + \ifx\tocactive0% + \openin0 \jobname.toc + \ifeof0 \closein0 \else + \closein0 \input \jobname.toc + \fi + \tocoutensure + \openout\tocout \jobname.toc + \global\let\tocactive1% + \else + \input Z-T-\jobname.tex + \fi} + +% Cross-references + +% \openxrefout loads all the TAG-VALUE associations in +% \jobname.xrf and then opens \jobname.xrf as an +% output channel that \tag can use + +\def\openxrefout{\openin0=\jobname.xrf + \ifeof0 \closein0 \else + {\catcode`\\0 \input \jobname.xrf }\fi + \csname newwrite\endcsname\xrefout + \openout\xrefout=\jobname.xrf } + +% \tag{TAG}{VALUE} associates TAG with VALUE. +% Hereafter, \ref{TAG} will output VALUE. +% \tag stores its associations in \xrefout. +% \tag calls \openxrefout if \jobname.xrf hasn't +% already been opened + +\def\tag#1#2{\ifx\xrefout\UNDEFINED\openxrefout\fi + {\let\folio0% + \edef\temp{% + \write\xrefout{\string\expandafter\string\gdef + \string\csname\space XREF#1\string\endcsname + {#2}\string\relax}}% + \temp}} + +% \ref{TAG} outputs VALUE, assuming \tag put such +% an association into \xrefout. \ref calls +% \openxrefout if \jobname.xrf hasn't already +% been opened + +\def\ref#1{\ifx\xrefout\UNDEFINED\openxrefout\fi + \expandafter\ifx\csname XREF#1\endcsname\relax + %\message or \write16 ? + \message{\the\inputlineno: Unresolved label `#1'.}?\else + \csname XREF#1\endcsname\fi} + +% \label, as in LaTeX + +\let\recentlabel\relax + +% The sectioning commands +% define \recentlabel so a subsequent call to \label will pick up the +% right label. + +\def\label#1{\tag{#1}{\recentlabel}% + \tag{PAGE#1}{\folio}} + +% \pageref, as in LaTeX + +\def\pageref#1{\ref{PAGE#1}} + +% Numbered footnotes + +\newcheapcount\footnotenumber + +\ifx\plainfootnote\UNDEFINED + \let\plainfootnote\footnote +\fi + +\def\numfootnote{\globaladvancecheapcount\footnotenumber 1% + \bgroup\csname footnotehook\endcsname + \plainfootnote{$^{\footnotenumber}$}\bgroup + \edef\recentlabel{\footnotenumber}% + \aftergroup\egroup + \let\dummy=} + +% + +\def\iffileexists#1#2#3{% + \openin0 #1 + \ifeof0 \closein0 + #3% + \else \closein0 + #2\fi} + +% \ifx\bibitem\UNDEFINED +% \newcheapcount\bibitemnumber + +% \def\bibitem{\par\globaladvancecheapcount\bibitemnumber 1% +% \edef\recentlabel{\bibitemnumber}% +% [\bibitemnumber]\label} +% \fi + +% + +% \def\begin#1{\begingroup +% \def\end##1{\csname end#1\endcsname\endgroup}% +% \def\envname{#1}% +% \def\envnameI{thebibliography}% +% \csname #1\endcsname +% \ifx\envname\envnameI\let\next\gobblegroup +% \else\let\next\relax\fi\next} + +% \def\begin#1{\begingroup +% \let\end\endbegin +% \csname #1\endcsname} + +% \def\endbegin#1{\csname end#1\endcsname\endgroup} + +% Index generation +% +% Your TeX source contains \index{NAME} to +% signal that NAME should be included in the index. +% Check the makeindex documentation to see the various +% ways NAME can be specified, e.g., for subitems, for +% explicitly specifying the alphabetization for a name +% involving TeX control sequences, etc. +% +% The first run of TeX will create \jobname.idx. +% makeindex on \jobname[.idx] will create the sorted +% index \jobname.ind. +% +% Use \inputindex (without arguments) to include this +% sorted index, typically somewhere to the end of your +% document. This will produce the items and subitems. +% It won't produce a section heading however -- you +% will have to typeset one yourself. +% +% Use \printindex instead of \inputindex if you want +% the section heading ``Index'' automatically generated. + +\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% + \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% + \do\@\do\"\do\!\do\|\do\-\do\ \do\'} + +\def\index{%\unskip + \ifx\indexout\UNDEFINED + \csname newwrite\endcsname\indexout + \openout\indexout \jobname.idx\fi + \begingroup + \sanitizeidxletters + \indexI} + +\def\indexI#1{\endgroup + \write\indexout{\string\indexentry{#1}{\folio}}% + \ignorespaces} + +% The following index style indents subitems on a +% separate lines + +\def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\indexitem##1{\par\hangindent30pt \hangafter1 + \hskip ##1 }% + \def\item{\indexitem{0em}}% + \def\subitem{\indexitem{2em}}% + \def\subsubitem{\indexitem{4em}}% + \let\indexspace\medskip} + +\def\endtheindex{\endgroup} + +% \packindex declares that subitems be bundled into one +% semicolon-separated paragraph + +\def\packindex{% + \def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\item{\par\hangindent20pt \hangafter1 }% + \def\subitem{\unskip; }% + \def\subsubitem{\unskip; }% + \let\indexspace\medskip}} + +\def\inputindex{% + \openin0 \jobname.ind + \ifeof0 \closein0 + \message{\jobname.ind missing.}% + \else\closein0 + \begingroup + \def\begin##1{\csname##1\endcsname}% + \def\end##1{\csname end##1\endcsname}% + \input\jobname.ind + \endgroup\fi} + +\def\printindex{\csname beginsection\endcsname Index\par + \inputindex} + +% + +\def\italiccorrection{\futurelet\italiccorrectionI + \italiccorrectionII} + +\def\italiccorrectionII{% + \if\noexpand\italiccorrectionI,\else + \if\noexpand\italiccorrectionI.\else + \/\fi\fi} + +\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} + +%\def\emph{\bgroup\it +% \ifmmode\else\aftergroup\italiccorrection\fi +% \let\dummy=} + +\def\itemize{\par\begingroup + \advance\leftskip 1.5em + \smallbreak + \def\item{\smallbreak$\bullet$\enspace\ignorespaces}} + +\def\enditemize{\smallbreak\smallbreak\endgroup\par} + +\def\enumerate{\par\begingroup + \newcheapcount\enumeratenumber + \advance\leftskip 1.5em + \smallbreak + \def\item{\smallbreak + \advancecheapcount\enumeratenumber1% + {\bf \enumeratenumber.}\enspace\ignorespaces}} + +\def\endenumerate{\smallbreak\smallbreak\endgroup\par} + +\endtexonly + +% end of file diff --git a/collects/slatex/slatex-code/texread.scm b/collects/slatex/slatex-code/texread.scm new file mode 100644 index 00000000..c46d3fcb --- /dev/null +++ b/collects/slatex/slatex-code/texread.scm @@ -0,0 +1,229 @@ +;texread.scm +;SLaTeX v. 2.3 +;Various token-readers used on TeX files by SLaTeX +;(c) Dorai Sitaram, Rice U., 1991, 1994 + +(eval-within slatex + + (define slatex::eat-till-newline + (lambda (in) + ;skip all characters from port in till newline inclusive or eof + (let loop () + (let ((c (read-char in))) + (cond ((eof-object? c) 'done) + ((char=? c #\newline) 'done) + (else (loop))))))) + + (define slatex::read-ctrl-seq + (lambda (in) + ;assuming we've just read a backslash, read the remaining + ;part of a latex control sequence from port in + (let ((c (read-char in))) + (if (eof-object? c) + (error "read-ctrl-exp: \\ followed by eof.")) + (if (char-alphabetic? c) + (list->string + (reverse! + (let loop ((s (list c))) + (let ((c (peek-char in))) + (cond ((eof-object? c) s) + ((char-alphabetic? c) (read-char in) + (loop (cons c s))) + ((char=? c #\%) (eat-till-newline in) + (loop s)) + (else s)))))) + (string c))))) + + (define slatex::eat-tabspace + (lambda (in) + ;skip to the next non-space and non-tab character from port in + (let loop () + (let ((c (peek-char in))) + (cond ((eof-object? c) 'done) + ((or (char=? c #\space) (char=? c *tab*)) + (read-char in) (loop)) + (else 'done)))))) + + (define slatex::eat-whitespace + (lambda (in) + ;skip to the next whitespace character from port in + (let loop () + (let ((c (peek-char in))) + (cond ((eof-object? c) 'done) + ((char-whitespace? c) + (read-char in) (loop)) + (else 'done)))))) + + (define slatex::eat-tex-whitespace + (lambda (in) + ;skip to the next whitespace character from port in; + ;skips past latex comments too + (let loop () + (let ((c (peek-char in))) + (cond ((eof-object? c) 'done) + ((char-whitespace? c) (read-char in) (loop)) + ((char=? c #\%) (eat-till-newline in)) + (else 'done)))))) + + (define slatex::chop-off-whitespace + (lambda (l) + ;removes leading whitespace from character-list l + (ormapcdr (lambda (d) (if (char-whitespace? (car d)) #f d)) l))) + + (define slatex::read-grouped-latexexp + (lambda (in) + ;reads a latex grouped expression from port in + ;(removes the groups) + (eat-tex-whitespace in) + (let ((c (read-char in))) + (if (eof-object? c) (error "read-grouped-latexexp: ~ +Expected { but found eof.")) + (if (not (char=? c #\{)) + (error "read-grouped-latexexp: ~ +Expected { but found ~a." c)) + (eat-tex-whitespace in) + (list->string + (reverse! + (chop-off-whitespace + (let loop ((s '()) (nesting 0) (escape? #f)) + (let ((c (read-char in))) + (if (eof-object? c) (error "read-groupted-latexexp: ~ +Found eof inside {...}.")) + (cond (escape? (loop (cons c s) nesting #f)) + ((char=? c #\\) + (loop (cons c s) nesting #t)) + ((char=? c #\%) (eat-till-newline in) + (loop s nesting #f)) + ((char=? c #\{) + (loop (cons c s) (+ nesting 1) #f)) + ((char=? c #\}) + (if (= nesting 0) s + (loop (cons c s) (- nesting 1) #f))) + (else + (loop (cons c s) nesting #f))))))))))) + + (define slatex::read-filename + (let ((filename-delims (list #\{ #\} #\[ #\] #\( #\) #\# #\% #\\ #\, + #\space *return* #\newline *tab* #\\))) + (lambda (in) + ;reads a filename as allowed in latex syntax from port in + (eat-tex-whitespace in) + (let ((c (peek-char in))) + (if (eof-object? c) (error "read-filename: ~ +Expected filename but found eof.")) + (if (char=? c #\{) (read-grouped-latexexp in) + (list->string + (reverse! + (let loop ((s '()) (escape? #f)) + (let ((c (peek-char in))) + (cond ((eof-object? c) + (if escape? (error "read-filename: ~ +\\ followed by eof.") + s)) + (escape? (read-char in) + (loop (cons c s) #f)) + ((char=? c #\\) (read-char in) + (loop (cons c s) #t)) + ((memv c filename-delims) s) + (else (read-char in) + (loop (cons c s) #f)))))))))))) + + (define slatex::read-schemeid + (let ((schemeid-delims (list #\{ #\} #\[ #\] #\( #\) + #\space *return* #\newline *tab*))) + (lambda (in) + ;reads a scheme identifier from port in + (eat-whitespace in) + (list->string + (reverse! + (let loop ((s '()) (escape? #f)) + (let ((c (peek-char in))) + (cond ((eof-object? c) s) + (escape? (read-char in) (loop (cons c s) #f)) + ((char=? c #\\) (read-char in) + (loop (cons c s) #t)) + ((memv c schemeid-delims) s) + (else (read-char in) (loop (cons c s) #f)))))))))) + + (define slatex::read-delimed-commaed-filenames + (lambda (in lft-delim rt-delim) + ;reads a filename from port in, assuming it's delimited by + ;lft- and rt-delims + (eat-tex-whitespace in) + (let ((c (read-char in))) + (if (eof-object? c) (error "read-delimed-commaed-filenames: ~ +Expected filename(s) but found eof.")) + (if (not (char=? c lft-delim)) + (error "read-delimed-commaed-filenames: ~ +Left delimiter ~a not found." lft-delim)) + (let loop ((s '())) + (eat-tex-whitespace in) + (let ((c (peek-char in))) + (if (eof-object? c) (error "read-delimed-commaed-filenames: ~ +Found eof inside filename(s).")) + (if (char=? c rt-delim) + (begin (read-char in) (reverse! s)) + (let ((s (cons (read-filename in) s))) + (eat-tex-whitespace in) + (let ((c (peek-char in))) + (if (eof-object? c) + (error "read-delimed-commaed-filenames: ~ +Found eof inside filename(s).")) + (cond + ((char=? c #\,) (read-char in)) + ((char=? c rt-delim) (void)) + (else (error "read-delimed-commaed-filenames: ~ +Bad filename(s) syntax."))) + (loop s))))))))) + + (define slatex::read-grouped-commaed-filenames + (lambda (in) + ;read a filename from port in, assuming it's grouped + (read-delimed-commaed-filenames in #\{ #\}))) + + (define slatex::read-bktd-commaed-filenames + (lambda (in) + ;read a filename from port in, assuming it's bracketed + (read-delimed-commaed-filenames in #\[ #\]))) + + (define slatex::read-grouped-schemeids + (lambda (in) + ;read a list of scheme identifiers from port in, + ;assuming they're all grouped + (eat-tex-whitespace in) + (let ((c (read-char in))) + (if (eof-object? c) (error "read-grouped-schemeids: ~ +Expected Scheme identifiers but found eof.")) + (if (not (char=? c #\{)) (error "read-grouped-schemeids: ~ +Expected { but found ~a." c)) + (let loop ((s '())) + (eat-whitespace in) + (let ((c (peek-char in))) + (if (eof-object? c) (error "read-grouped-schemeids: +Found eof inside Scheme identifiers.")) + (if (char=? c #\}) + (begin (read-char in) (reverse! s)) + (loop (cons (read-schemeid in) s)))))))) + + (define slatex::eat-delimed-text + (lambda (in lft-delim rt-delim) + (eat-tex-whitespace in) + (let ((c (peek-char in))) + (if (eof-object? c) 'exit + (if (char=? c lft-delim) + (let loop () + (let ((c (read-char in))) + (if (eof-object? c) 'exit + (if (char=? c rt-delim) 'exit + (loop)))))))))) + + (define slatex::eat-bktd-text + (lambda (in) + (eat-delimed-text in #\[ #\]))) + + (define slatex::eat-grouped-text + (lambda (in) + (eat-delimed-text in #\{ #\}))) + + ;(trace read-filename) + ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/version b/collects/slatex/slatex-code/version new file mode 100644 index 00000000..a403bb62 --- /dev/null +++ b/collects/slatex/slatex-code/version @@ -0,0 +1 @@ +2.4w \ No newline at end of file diff --git a/collects/slatex/slatex-launcher.scm b/collects/slatex/slatex-launcher.scm new file mode 100644 index 00000000..c8433d16 --- /dev/null +++ b/collects/slatex/slatex-launcher.scm @@ -0,0 +1,15 @@ +(require-library "slatex.ss" "slatex") + +(case (system-type) + [(macos) + + ;; set up drag and drop + (current-load slatex) + + (for-each slatex (vector->list argv))] + [(windows unix) + (when (eq? (vector) argv) + (error 'slatex "expected a file on the command line~n")) + (parameterize ([error-escape-handler exit]) + (slatex (vector-ref argv 0))) + (exit)]) diff --git a/collects/slatex/slatex.ss b/collects/slatex/slatex.ss new file mode 100644 index 00000000..b89a387b --- /dev/null +++ b/collects/slatex/slatex.ss @@ -0,0 +1,51 @@ +(require-library "file.ss") + +(define (filename->latex-filename input-file) + (cond + [(file-exists? input-file) input-file] + [(file-exists? (string-append input-file ".tex")) + (string-append input-file ".tex")] + [else + (error 'filename->latex-filename "~e does not exist" input-file)])) + +(define (latex input-file) + (let ([file (filename->latex-filename (normalize-path input-file))]) + (case (system-type) + [(macos) + (system "OTEX") + + ;; boy, wouldn't it be great if the "actv" appleevent worked for OTEX? + ;(send-event "OTEX" "misc" "acvt") + (let ([oztex-location (build-path (car (filesystem-root-list)) + "Applications" + "OzTeX" + "OzTeX")]) + (when (file-exists? oztex-location) + (with-handlers ([void void]) ;; mzscheme cannot handle result + (send-event "MACS" "aevt" "odoc" (vector 'file oztex-location))))) + (send-event "OTEX" "aevt" "odoc" (vector 'file file))] + [(windows unix) ;; is this also okay for beos? + (system (format "latex ~a" file))] + [else + (error 'latex "do not know how to run latex on ~s" (system-type))]))) + +(define (slatex filename) + (slatex/no-latex filename) + (latex filename)) + +(define slatex/no-latex + (let ([ns (make-namespace)]) + (parameterize ([current-namespace ns]) + (require-library "slatexsrc.ss" "slatex") + (global-defined-value 'slatex::*texinputs* #f) + (global-defined-value 'slatex::*texinputs-list* #f)) + (lambda (input-file) + (let* ([fixed-file (filename->latex-filename input-file)] + [file (normalize-path fixed-file)]) + (let-values ([(base name dir?) (split-path file)]) + (parameterize ([current-namespace ns] + [current-directory + (if (string? base) + base + (current-directory))]) + (eval `(slatex::process-main-tex-file ,name)))))))) diff --git a/collects/slatex/slatexsrc.ss b/collects/slatex/slatexsrc.ss new file mode 100644 index 00000000..f85d662b --- /dev/null +++ b/collects/slatex/slatexsrc.ss @@ -0,0 +1 @@ +(error 'slatexsrc.ss "should only load the compiled version of this file. Run `setup-plt -cl slatex' to generate slatexsrc.zo") diff --git a/collects/slibinit/doc.txt b/collects/slibinit/doc.txt new file mode 100644 index 00000000..a65b39c5 --- /dev/null +++ b/collects/slibinit/doc.txt @@ -0,0 +1,23 @@ + +_Slib_ Initialization File +-------------------------- + +The "init.ss" file in the _slibinit_ collection is an slib2c5 +initialization file. To configure MzScheme for slib, load: + + (require-library "init.ss" "slibinit") + +That's enough if the SCHEME_LIBRARY_PATH environment variable is +defined. Otherwise, the initialization file assumes that slib is +installed as an "slib" collection (i.e., in an "slib" directory in the +same location as the "mzlib" directory). + + +The initialization file contains one system-dependent setting: +`most-positive-fixnum' is bound to a value that is precisely correct +for 32-bit architectures. The precise value for a 64-bit architcture +is in the file, but commented out. The only danger in using the 32-bit +value for a 64-bit architecture is a decrease in performance. + +No other changes should be necessary. Send patches to +scheme@cs.rice.edu. diff --git a/collects/slibinit/init.ss b/collects/slibinit/init.ss new file mode 100644 index 00000000..c86bb658 --- /dev/null +++ b/collects/slibinit/init.ss @@ -0,0 +1,315 @@ +; Derived from: -*-scheme-*- +; "Template.scm" configuration template of *features* for Scheme +; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. + +; Compatibility file for MzScheme -- +; http://www.cs.rice.edu/CS/PLT/packages/mzscheme/ +; -- and DrScheme -- +; http://www.cs.rice.edu/CS/PLT/packages/drscheme/ +; -- produced by Shriram Krishnamurthi , +; Mon Feb 10 12:03:53 CST 1997 + +(require-library "pretty.ss") +(unless (memq (system-type) '(unix beos)) + (require-library "date.ss")) + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) + (case (system-type) + [(unix beos) 'UNIX] + [(windows) 'MS-DOS] + [(macos) 'MACOS] + [else (system-type)])) + +;;; (scheme-implementation-type) should return the name of the scheme +;;; implementation loading this file. + +(define (scheme-implementation-type) '|MzScheme|) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define scheme-implementation-version version) + +;;; (implementation-vicinity) should be defined to be the pathname of +;;; the directory where any auxillary files to your Scheme +;;; implementation reside. + +(define implementation-vicinity + (let ([path + (or (getenv "PLTHOME") + (with-handlers ([void (lambda (x) #f)]) + (let ([p (collection-path "mzlib")]) + (let*-values ([(base name dir?) (split-path p)] + [(base name dir?) (split-path base)]) + (and (string? base) base)))) + (case (system-type) + ((unix) "/usr/local/lib/plt") + ((windows) "C:\\Program Files\\PLT") + ((macos) "My Disk:plt:")))]) + (lambda () path))) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. + +(define library-vicinity + (let ((library-path + (or + ;; Use this getenv if your implementation supports it. + (getenv "SCHEME_LIBRARY_PATH") + ;; Use this path if your scheme does not support GETENV + (with-handlers ([void + (lambda (x) + (error 'slib-init + "can't find SCHEME_LIBRARY_PATH environment variable or \"slib\" collection"))]) + (collection-path "slib"))))) + (lambda () library-path))) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. + +(define (home-vicinity) + (find-system-path 'home-dir)) + +;;; *FEATURES* should be set to a list of symbols describing features +;;; of this implementation. Suggestions for features are: + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + rev4-report ;conforms to +; rev3-report ;conforms to +; ieee-p1178 ;conforms to +; sicp ;runs code from Structure and + ;Interpretation of Computer + ;Programs by Abelson and Sussman. + rev4-optional-procedures ;LIST-TAIL, STRING->LIST, + ;LIST->STRING, STRING-COPY, + ;STRING-FILL!, LIST->VECTOR, + ;VECTOR->LIST, and VECTOR-FILL! +; rev2-procedures ;SUBSTRING-MOVE-LEFT!, + ;SUBSTRING-MOVE-RIGHT!, + ;SUBSTRING-FILL!, + ;STRING-NULL?, APPEND!, 1+, + ;-1+, ?, >=? + multiarg/and- ;/ and - can take more than 2 args. + multiarg-apply ;APPLY can take more than 2 args. + rationalize + delay ;has DELAY and FORCE + with-file ;has WITH-INPUT-FROM-FILE and + ;WITH-OUTPUT-FROM-FILE + string-port ;has CALL-WITH-INPUT-STRING and + ;CALL-WITH-OUTPUT-STRING +; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF + char-ready? +; macro ;has R4RS high level macros + defmacro ;has Common Lisp DEFMACRO + eval ;SLIB:EVAL is single argument eval +; record ;has user defined data structures + values ;proposed multiple values + dynamic-wind ;proposed dynamic-wind + ieee-floating-point ;conforms to + full-continuation ;can return multiple times +; object-hash ;has OBJECT-HASH + +; sort +; queue ;queues + pretty-print +; object->string +; format +; trace ;has macros: TRACE and UNTRACE +; compiler ;has (COMPILER) +; ed ;(ED) is editor + system ;posix (system ) + getenv ;posix (getenv ) + program-arguments ;returns list of strings (argv) +; Xwindows ;X support +; curses ;screen management package +; termcap ;terminal description package +; terminfo ;sysV terminal description + current-time ;returns time in seconds since 1/1/1970 + )) + +;;; Compatibility code added by Shriram. + +(define-macro defmacro + (lambda (name params . body) + `(define-macro ,name + (lambda ,params + ,@body)))) + +(define program-arguments + (lambda () + (vector->list argv))) + +(define current-time + ;; Gives time since 1/1/1970 ... + ;; ... GMT for Unix, Windows, and BeOS. + ;; ... local time for MacOS. + (if (memq (system-type) '(unix beos windows)) + current-seconds + (let ([zero (find-seconds 0 0 0 1 1 1970)]) + (lambda () + (- (current-seconds) zero))))) + +;;; Remainder is modifications of existing code in Template.scm. + +;;; (OUTPUT-PORT-WIDTH ) +(define (output-port-width . arg) 79) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +;; Already in MzScheme + +;;; (TMPNAM) makes a temporary file name. +(define tmpnam (let ((cntr 100)) + (lambda () (set! cntr (+ 1 cntr)) + (string-append "slib_" (number->string cntr))))) + +;;; (FILE-EXISTS? ) +;; Already in MzScheme + +;;; (DELETE-FILE ) +;; Already in MzScheme + +;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;; use this definition if your system doesn't have such a procedure. +(define force-output flush-output) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. + +(define call-with-input-string + (lambda (string thunk) + (parameterize ((current-input-port (open-input-string string))) + (thunk)))) + +(define call-with-output-string + (lambda (receiver) + (let ((sp (open-output-string))) + (receiver sp) + (get-output-string sp)))) + +;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;; be returned by CHAR->INTEGER. +(define char-code-limit 256) + +;;; MOST-POSITIVE-FIXNUM is used in modular.scm +(define most-positive-fixnum #x3FFFFFFF) ; 30 bits on 32-bit machines +; (define most-positive-fixnum #x3FFFFFFFFFFFFFFF) ; 62 bits on 64-bit machines + +;;; Return argument +(define (identity x) x) + +;;; If your implementation provides eval SLIB:EVAL is single argument +;;; eval using the top-level (user) environment. +(define slib:eval eval) + +;;; If your implementation provides R4RS macros: +;(define macro:eval slib:eval) +;(define macro:load load) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "slib:G" (number->string *gensym-counter*)))))) + +(define defmacro? macro?) + +(define (macroexpand-1 x) + ;; Slib expects macroexpand-1 to return an `eq?' value if there's nothing + ;; to expand. MzScheme returns an `equal?' value, instead. + ;; Of course, using will equal? is bad if the input contains cycles. + ;; We assume that slib-based code won't try to use MzScheme's graph input + ;; syntax, since it isn't standard. + (let ([xx (expand-defmacro-once x)]) + (if (equal? xx x) + x + xx))) + +(define macroexpand expand-defmacro) + +(define base:eval slib:eval) +(define (defmacro:expand* x) (macroexpand x)) +(define (defmacro:eval x) (base:eval (defmacro:expand* x))) + +(define (defmacro:load ) + (slib:eval-load defmacro:eval)) + +(define (slib:eval-load evl) + (if (not (file-exists? )) + (set! (string-append (scheme-file-suffix)))) + (call-with-input-file + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* ) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; define an error procedure for the library +(define slib:error error) + +;;; define these as appropriate for your system. +(define slib:tab (integer->char 9)) +(define slib:form-feed (integer->char 12)) + +;;; Support for older versions of Scheme. Not enough code for its own file. +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) +(define t #t) +(define nil #f) + +;;; Define these if your implementation's syntax can support it and if +;;; they are not already defined. + +(define 1+ add1) +(define -1+ sub1) +(define 1- -1+) + +(define in-vicinity + (lambda args + (let loop ([args args]) + (cond + [(null? (cdr args)) (car args)] + [(string=? "" (car args)) (loop (cdr args))] + [else (let ([v (loop (cdr args))]) + (build-path (car args) v))])))) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:exit exit) + +;;; Here for backward compatability +(define scheme-file-suffix + (let ((suffix (case (software-type) + ((NOSVE) "_scm") + (else ".scm")))) + (lambda () suffix))) + +;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;; suffix all the module files in SLIB have. See feature 'SOURCE. + +(define (slib:load-source f) (load (string-append f ".scm"))) + +;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;; by compiling "foo.scm" if this implementation can compile files. +;;; See feature 'COMPILED. + +(define (slib:load-compiled f) (load (string-append f ".zo"))) + +;;; At this point SLIB:LOAD must be able to load SLIB files. + +(define slib:load slib:load-source) + +(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/collects/srpersist/doc.txt b/collects/srpersist/doc.txt new file mode 100644 index 00000000..50ebeda9 --- /dev/null +++ b/collects/srpersist/doc.txt @@ -0,0 +1,2507 @@ + _SrPersist_ + =========== + + _ODBC_ + ====== + + SrPersist is an ODBC library for MzScheme and DrScheme. + Any database management system with an ODBC driver should + be usable with SrPersist. + + SrPersist provides a one-to-one mapping of ODBC procedures to + Scheme procedures, with some additional utility procedures in Scheme. + Procedures from ODBC versions 1.0 through 3.51 are supported. + Where ODBC expects symbolic constants created through C #define's, + SrPersist uses Scheme constants, which are checked for validity. + In many cases, redundant arguments are eliminated. In many cases, + the SrPersist version of an ODBC procedure returns a handle, allowing + procedures to be composed. + + ODBC procedure names are mapped to Scheme names straightforwardly. + The initial "SQL" in the name is removed, the characters + are made all lowercase, and hyphens are inserted before the location + of formerly uppercase letters, other than the first following "SQL". + For example, the hypothetical ODBC name SQLProcedureName would be + mapped to the Scheme name procedure-name. The exception is SQLError, + which is mapped to sql-error, to avoid confusion with the MzScheme + procedure error. + + The documentation here may be sufficient to get started with + SrPersist, but you will certainly want to consult an ODBC reference for + more information. The file tutorial.txt in the SrPersist collection + provides some simple examples of how to use SrPersist. + + SrPersist is not + ---------------- + + SrPersist makes the ODBC API available in Scheme, but does not + support any abstractions beyond it. Some useful error-checking is + performed that is not done when using the C version of the API. + Serious run-time errors are still possible, such as when a too-small + buffer is bound to a column. + + We are considering ways in which to build a higher-level layer + on top of SrPersist, to avoid some of the low-level details + of ODBC. We would welcome ideas and contributions from users + of SrPersist in this area. Please contact us via email at + scheme@cs.rice.edu. + + Loading + ------- + + Before actually loading SrPersist, you need to define the global variable + odbc-version. For example: + + (define odbc-version 3.5) + + Valid values of odbc-version are 1.0, 2.0, 3.0, 3.5, and 3.51. + The version here should be less than or equal to the ODBC version + used when compiling the SrPersist files. See README in + the SrPersist source directory for more details on compilation. + For the precompiled Windows binary, use 3.51 for odbc-version. + + For Windows, if you get errors when loading, your Windows installation + may be missing certain ODBC libraries. Look for ODBC Data Sources + in Windows Control Panel. If that application is missing, download + and install the Microsoft Data Access Components from + http://www.microsoft.com/data/. The download is about 6.5 Mb. + + There are two ways to load SrPersist. The first is to treat + it as a library: + + (require-library "srpersist.ss" "srpersist") + + makes available the procedures listed here. The other way + to load SrPersist uses a signed unit: + + (require-library "srpersistu.ss" "srpersist") + + binds `srpersist@' to the unit, with signature `srpersist^', + which is defined in the file `sigs.ss' in the srpersist collection. + The contents of that signature depend on the value of + odbc-version. This unit can be invoked or imported into other + units as needed. + + Overview of ODBC + ---------------- + + ODBC is a standard for allowing application programs to retrieve from + and send data to relational databases. The application program + communicates with a Driver Manager using ODBC procedures. Database + queries use SQL (Structured Query Language). The Driver Manager + communicates with databases using drivers specific to them. Therefore, + ODBC is a "middleware" standard. + + How to use this documentation + ----------------------------- + + Because ODBC is very complex, this documentation cannot hope to + cover all its aspects. Instead, this documentation describes + a Scheme interface to ODBC. Each ODBC API procedure has a Scheme + counterpart. In this documentation, we describe the parameters + and return values for each procedure, as well as give some indication + of the purpose of the procedure. To use ODBC effectively, you will + need access to an ODBC reference, such as that provided with the + Microsoft ODBC SDK. + + Overview of ODBC procedures + --------------------------- + + In the documentation below, we group SrPersist ODBC procedures + by topics. The topics are Exceptions, Handles, Connections, Environments, + Statements and Parameters, Descriptors, Cursors, Columns and Data + Retrieval, Metadata, and Errors and Diagnostics. SrPersist also has + its own utility procedures, listed under the heading Utilities below. + + For each procedure, we indicate the ODBC version in which it was + introduced. Therefore, some SrPersist procedures may not be available + to your program. If the variable odbc-version is greater than or + equal to the ODBC version in which a procedure was introduced, the + procedure will be available; otherwise, the procedure will not be + available. + + Exceptions + ---------- + + Any SrPersist ODBC procedure may raise an exception. + SrPersist exceptions correspond to the ODBC SQLRESULT codes, + as follows: + + exn-invalid-handle SQL_INVALID_HANDLE + exn-error SQL_ERROR + exn-still-executing SQL_STILL_EXECUTING + exn-need-data SQL_NEED_DATA + exn-with-info SQL_SUCCESS_WITH_INFO + exn-no-data SQL_NO_DATA_FOUND (before ODBC 3.0) + exn-no-data SQL_NO_DATA (ODBC 3.0 or greater) + + Each of these exceptions is an ordinary Scheme structure + derived from `struct:exn'. Only `exn-need-data` and `exn-with-info' + contain an extra field, `val' in both cases. The names of the + exception indicate the nature of the problem that has occurred. + Each of these exceptions, other than `exn-with-info', indicate an error. + The exception `exn-error' is a catchall, indicating an unspecified error. + The exception `exn-with-info' does not indicate an error, rather it + indicates that additional information is available about the procedure + that generated the exception. The `val' field of `exn-need-data` or + `exn-with-info' instances contains the value returned by the procedure + that generated the exception. In the case of `exn-need-data', depending + on the ODBC procedure, the contained value may not be meaningful. + + `with-handlers' can be used to handle SrPersist exceptions: + + (with-handlers ([(lambda (exn) + (exn-with-info? exn)) + (lambda (exn) + (printf "Got exn-with-info exception~n") + (printf "Value: ~a~n" (exn-with-info-val exn)))]) + ...) + + Applications can call sql-error, get-diag-rec, or get-diag-field + to obtain additional information about an exception that + has occurred (see the heading "Diagnostics", below). No additional + information is available when the exception is `exn-invalid-handle'. + + Besides these SrPersist-particular exceptions, other kinds of errors + may raise exceptions. For example, passing a value of the + wrong type to a SrPersist procedure will raise an exception. + + Handles + ------- + + ODBC and SrPersist support four kinds of handles. + In ODBC itself, all handles are represented as integers, + making it possible for handle types to be confused. + In SrPersist, each handle type has a distinct Scheme + type. An "environment handle" has type `sql-henv'; a + "connection handle" has type `sql-hdbc'; a "statement handle" has + type `sql-hstmt'; a "descriptor handle" has type `sql-hdesc'. + + Further, descriptor handles have an attribute which divides + them into subtypes, though this does not show up in their + Scheme type. Ordinarily, a descriptor handle is either an + Application Parameter Descriptor (attribute APD), an Application + Row Descriptor (ARD), an Implementation Parameter Descriptor (IPD), + or an Implementation Row Descriptor (IRD). Most descriptor + handles are created by an ODBC driver. When a descriptor + handle is explicitly allocated, it receives the attribute + EXPLICIT, rather than one of the four attribute values just + mentioned. + + There are several procedures to allocate fresh handles. + +> (alloc-env) + + ODBC 1.0. + + Returns a fresh environment handle. + +> (alloc-connect henv) + + ODBC 1.0, deprecated in favor of `alloc-handle'. + + Returns a fresh connection handle, given `henv', an + environment handle. + +> (alloc-stmt hdbc) + + ODBC 1.0, deprecated in favor of `alloc-handle'. + + Returns a fresh statement handle, given `hdbc', a + connection handle + +> (alloc-handle htype [handle]) + + ODBC 3.0. + + Returns a fresh handle whose type depends on `htype', + a Scheme symbol. If `htype' is 'sql-handle-env, + then `handle' must be omitted, and a fresh `environment + handle' is returned. If `htype' is 'sql-handle-dbc, + then `handle' must be an environment handle, and a fresh + `connection handle' is returned. If `htype' is 'sql-handle-stmt, + then `handle' must be a connection handle, and a fresh + `statement handle' is returned. If `htype' is 'sql-handle-desc, + then `handle' must be a connection handle, and a fresh + `descriptor handle' with attribute EXPLICIT is returned. + Any other value of `htype' causes an error. + +> (free-connect hdbc) + + ODBC 1.0, deprecated in favor of free-handle. + + Frees a connection handle `hdbc', whose value is returned by the + procedure. + +> (free-env henv) + + ODBC 1.0, deprecated in favor of free-handle. + + Frees an environment handle `henv', whose value is returned by the + procedure. + +> (free-handle handle) + + ODBC 3.0. + + Frees `handle', which may be an environment, connection, statment, + or descriptor handle. Returns the value of `handle'. + +> (free-stmt hstmt option) + + ODBC 1.0. + + Frees or releases resources for the statement handle `hstmt'. + The `option' argument may be any of the following symbols, with + the indicated effects: + + 'sql-close closes the statement cursors, discards pending results + (does not actually free `hstmt') + 'sql-drop deprecated, effectively (free-handle hstmt) + 'sql-unbind releases all column buffers for the statement + 'sql-reset-parms releases all parameter buffers for the statement + + free-stmt returns the value of `hstmt'. + + Environments + ------------ + +> (data-sources henv direction) + + OCBC 1.0. + + For the environment handle `henv', returns a pair of strings + indicating a data source name and its description. The + symbol `direction' is either 'sql-fetch-first, 'sql-fetch-next, + 'sql-fetch-first-user, or 'sql-fetch-first-system. User data + sources are visible only to a particular user, while system + data sources are visible to all users. + +> (drivers henv fetch) + + ODBC 2.0. + + For the environment handle `henv', returns a two-element list + of strings describing an available driver. The first string + identifies the driver and the second string describes attributes + of the driver. `fetch' is either 'sql-fetch-first or + 'sql-fetch-next. By using repeated calls to drivers with + 'sql-fetch-next, a program can obtain information about all + available drivers. Providing 'sql-fetch-next on the first + call to drivers has the same effect as 'sql-fetch-first. + + Please consult an ODBC reference for an information about the + keyword/value pairs that appear in the attributes string. + +> (get-env-attr henv attr) + + Given an environment handle `henv', returns the value of the + attribute `attr'. The possible values for `attr' and the + resulting return values are: + + attr returns + ---- ------- + 'sql-attr-connection-pooling 'sql-cp-off, or + 'sql-cp-one-per-driver, or + 'sql-cp-one-per-henv + + 'sql-attr-cp-match 'sql-cp-strict-match, or + 'sql-cp-relaxed-match + + 'sql-attr-odbc-version 'sql-ov-odbc3, or + 'sql-ov-odbc2 + + 'sql-attr-output-nts boolean + + Please see an ODBC reference for more information about the + significance of these attributes. + +> (set-env-attr henv attr val) + + Given an environment handle `henv', sets the value of its associated + attribute `attr' to the value `val'. See `get-env-attr' for the + available attributes and their valid values. Returns the value of + `henv'. + + Connections + ----------- + + Before an ODBC database may be used, a `connection' between + the ODBC driver and database management system needs to be + established. Here are the procedures for establishing and + managing connections. + +> (connect hdbc dbms name password) + + ODBC 1.0. + + Establishes a connection, given a connection handle `hdbc', and + strings for a database server `dbms', a `name' and `password'. + Returns the value of `hdbc'. + +> (browse-connect hdbc connect-string) + + Connects to a data source, given a connection handle `hdbc' + and connection string `connect-string'. The connection string + consists of keyword and value pairs. See `driver-connect' + for the format of such pairs. The first time `browse-connect' + is called, the connection string must contain either the + DSN or DRIVER keywords. `browse-connect' returns a connection string + with a sequence of keywords and value pairs. Those pairs not + preceded by an asterisk are mandatory in the next call to + browse-connect. If the supplied connection string does not + contain all needed attributes to make a connection, a `exn-need-data' + exception is raised, which contains a connection string indicating + which attributes are missing. + +> (driver-connect hdbc connect-string prompt) + + Connects to an ODBC driver, given a connection handle `hdbc', + the string `connect-string', and the symbol `prompt'. + The connect-string is a possibly-empty sequence of + keyword, attribute pairs: + + keyword=attribute;... + + where `keyword' is any of + + DSN data source + UID user id + PWD password + FILEDSN name of a .dsn file containing a connection string + DRIVER driver description + SAVEFILE a .dsn file for saving the connection attributes + + or a driver-specific keyword. DSN and DRIVER are mutually-exclusive. + DRIVER is ODBC 2.0, while FILEDSN and SAVEFILE are ODBC 3.0. + For DRIVER only, the attribute may be surrounded by + curly braces {}, useful if the attribute contains a semicolon. + `prompt' is one of the symbols + + 'sql-driver-prompt prompt for required information + 'sql-driver-complete prompt if DSN not in connect-string + 'sql-driver-complete-required prompt if DSN not in connect-string + 'sql-driver-noprompt do not prompt for information + + driver-connect returns a connection string indicating all the + keywords and values that were passed to the data source. + +> (disconnect hdbc) + + ODBC 1.0. + + Closes the data source connection associated with the connection + handle `hdbc'. Frees any statement and descriptor handles associated + with the connection handle. Returns the value of `hdbc'. + +> (get-info hdbc infotype [handle]) + + ODBC 1.0. + + Returns information about the data source associated with the + connection handle `hdbc'. The type of the return value depends + on the symbol `infotype', which indicates the information requested. + The optional argument `handle' is either a statement handle + or a descript handle, and may be used only with certain + values of `infotype', as described below. + + The significance of the values returned by get-info is beyond the + scope of this documentation. Please consult an ODBC reference + for further information. + + The permissible values of `infotype' vary by ODBC version. + Valid values of `infotype' and their return types are: + + infotype returns + -------- ------- + + [ODBC 1.0 or greater] + 'sql-accessible-procedures boolean + 'sql-accessible-tables boolean + 'sql-active-connections unsigned integer + 'sql-active-statements unsigned integer + 'sql-alter-table a list with elements chosen from + '(sql-at-add-column-collation + sql-at-add-column-default + sql-at-add-column-single + sql-at-add-constraint + sql-at-add-table-constraint + sql-at-constraint-name-definition + sql-at-drop-column-cascade + sql-at-drop-column-default + sql-at-drop-column-restrict + sql-at-drop-table-constraint-cascade + sql-at-drop-table-constraint-restrict + sql-at-set-column-default + sql-at-constraint-initially-deferred + sql-at-constraint-initially-immediate + sql-at-constraint-deferrable + sql-at-constraint-non-deferrable) + 'sql-correlation-name 'sql-cn-none, or + 'sql-cn-different, or + 'sql-cn-any + 'sql-convert-functions a list with elements chosen from + '(sql-fn-cvt-cast sql-fn-cvt-convert) + 'sql-column-alias boolean + 'sql-concat-null-behavior 'sql-cb-null or + sql-cb-non-null + 'sql-convert-bigint a list with elements chosen from + '(sql-cvt-bigint + sql-cvt-binary + sql-cvt-bit + sql-cvt-char + sql-cvt-date + sql-cvt-decimal + sql-cvt-double + sql-cvt-float + sql-cvt-integer + sql-cvt-interval-year-month + sql-cvt-interval-day-time + sql-cvt-longvarbinary + sql-cvt-longvarchar + sql-cvt-numeric + sql-cvt-real + sql-cvt-smallint + sql-cvt-time + sql-cvt-timestamp + sql-cvt-tinyint + sql-cvt-varbinary + sql-cvt-varchar) + 'sql-convert-binary same as for 'sql-convert-bigint + 'sql-convert-bit same as for 'sql-convert-bigint + 'sql-convert-char same as for 'sql-convert-bigint + 'sql-convert-date same as for 'sql-convert-bigint + 'sql-convert-decimal same as for 'sql-convert-bigint + 'sql-convert-double same as for 'sql-convert-bigint + 'sql-convert-float same as for 'sql-convert-bigint + 'sql-convert-integer same as for 'sql-convert-bigint + 'sql-convert-longvarbinary same as for 'sql-convert-bigint + 'sql-convert-longvarchar same as for 'sql-convert-bigint + 'sql-convert-real same as for 'sql-convert-bigint + 'sql-convert-numeric same as for 'sql-convert-bigint + 'sql-convert-smallint same as for 'sql-convert-bigint + 'sql-convert-time same as for 'sql-convert-bigint + 'sql-convert-timestamp same as for 'sql-convert-bigint + 'sql-convert-tinyint same as for 'sql-convert-bigint + 'sql-convert-varbinary same as for 'sql-convert-bigint + 'sql-convert-varchar same as for 'sql-convert-bigint + 'sql-cursor-commit-behavior 'sql-cb-delete, or + 'sql-cb-close, or + 'sql-cb-preserve + 'sql-cursor-rollback-behavior same as for 'sql-cursor-commit-behavior + 'sql-data-source-name string + 'sql-data-source-read-only boolean + 'sql-database-name string + 'sql-dbms-name string + 'sql-dbms-ver string + 'sql-default-txn-isolation 'sql-txn-read-uncommitted, or + 'sql-txn-read-committed, or + 'sql-txn-repeatable-read, or + 'sql-txn-serializable + 'sql-driver-hdbc connection handle + 'sql-driver-henv environment handle + 'sql-driver-hlib unsigned integer + 'sql-driver-hstmt statement handle; `handle' argument + also a statement handle + 'sql-driver-name string + 'sql-driver-odbc-ver string + 'sql-driver-ver string + 'sql-expressions-in-orderby boolean + 'sql-fetch-direction a list with elements chosen from + '(sql-fd-fetch-next + sql-fd-fetch-first + sql-fd-fetch-last + sql-fd-fetch-prior + sql-fd-fetch-absolute + sql-fd-fetch-relative + sql-fd-fetch-bookmark) + 'sql-file-usage 'sql-file-not-supported, or + 'sql-file-table, or + 'sql-file-catalog + 'sql-getdata-extensions a list with elements chosen from + '(sql-gd-any-column + sql-gd-any-order + sql-gd-block + sql-gd-bound) + 'sql-group-by 'sql-gb-collate (ODBC 3.0 or greater), or + 'sql-gb-not-supported, or + 'sql-gb-group-by-equals-select, or + 'sql-gb-group-by-contains-select, or + 'sql-gb-no-relation + 'sql-identifier-case 'sql-ic-upper, or + 'sql-ic-lower, or + 'sql-ic-sensitive, or + 'sql-ic-mixed + 'sql-identifier-quote-char string + 'sql-integrity boolean + 'sql-keywords string + 'sql-like-escape-clause boolean + 'sql-lock-types a list with elements chosen from + '(sql-lck-no-change + sql-lck-exclusive + sql-lck-unlock) + 'sql-max-binary-literal-len unsigned integer + 'sql-max-catalog-name-len unsigned integer + 'sql-max-char-literal-len unsigned integer + 'sql-max-column-name-len unsigned integer + 'sql-max-columns-in-group-by unsigned integer + 'sql-max-columns-in-index unsigned integer + 'sql-max-columns-in-order-by unsigned integer + 'sql-max-columns-in-select unsigned integer + 'sql-max-columns-in-table unsigned integer + 'sql-max-cursor-name-len unsigned integer + 'sql-max-index-size unsigned integer + 'sql-max-owner-name-len unsigned integer + 'sql-max-procedure-name-len unsigned integer + 'sql-max-qualifier-name-len unsigned integer + 'sql-max-row-size unsigned integer + 'sql-max-row-size-includes-long boolean + 'sql-max-schema-name-len unsigned integer + 'sql-max-statement-len unsigned integer + 'sql-max-table-name-len unsigned integer + 'sql-max-tables-in-select unsigned integer + 'sql-max-user-name-len unsigned integer + 'sql-mult-result-sets boolean + 'sql-multiple-active-txn boolean + 'sql-need-long-data-len boolean + 'sql-non-nullable-columns 'sql-nnc-null or + 'sql-nnc-non-null + 'sql-null-collation 'sql-nc-end, or + 'sql-nc-high, or + 'sql-nc-low, or + 'sql-nc-start + 'sql-numeric-functions a list with elements chosen from + '(sql-fn-num-abs + sql-fn-num-acos + sql-fn-num-asin + sql-fn-num-atan + sql-fn-num-atan2 + sql-fn-num-ceiling + sql-fn-num-cos + sql-fn-num-cot + sql-fn-num-degrees + sql-fn-num-exp + sql-fn-num-floor + sql-fn-num-log + sql-fn-num-log10 + sql-fn-num-mod + sql-fn-num-pi + sql-fn-num-power + sql-fn-num-radians + sql-fn-num-rand + sql-fn-num-round + sql-fn-num-sign + sql-fn-num-sin + sql-fn-num-sqrt + sql-fn-num-tan + sql-fn-num-truncate) + 'sql-odbc-api-conformance 'sql-oac-none, or + 'sql-oac-level1, or + 'sql-oac-level2 + 'sql-odbc-sql-conformance 'sql-osc-minimum, or + 'sql-osc-core, or + 'sql-osc-extended + 'sql-odbc-sql-opt-ief boolean + 'sql-odbc-ver string + 'sql-order-by-columns-in-select boolean + 'sql-outer-joins boolean + 'sql-owner-term string + 'sql-owner-usage a list with elements chosen from + '(sql-ou-dml-statements + sql-ou-procedure-invocation + sql-ou-table-definition + sql-ou-index-definition + sql-ou-privilege-definition) + 'sql-pos-operations a list with elements chosen from + '(sql-pos-position + sql-pos-refresh + sql-pos-update + sql-pos-delete + sql-pos-add) + 'sql-positioned-statements a list with elements chosen from + '(sql-ps-positioned-delete + sql-ps-positioned-update + sql-ps-select-for-update) + 'sql-procedure-term string + 'sql-procedures boolean + 'sql-qualifier-location 'sql-ql-start or 'sql-ql-end + 'sql-qualifier-name-separator string + 'sql-qualifier-term string + 'sql-qualifier-usage a list with elements chosen from + '(sql-qu-dml-statements + sql-qu-procedure-invocation + sql-qu-table-definition + sql-qu-index-definition + sql-qu-privilege-definition) + 'sql-quoted-identifier-case 'sql-ic-upper, or + 'sql-ic-lower, or + 'sql-ic-sensitive, or + 'sql-ic-mixed + 'sql-row-updates boolean + 'sql-scroll-concurrency a list with elements chosen from + '(sql-scco-read-only + sql-scco-lock + sql-scco-opt-rowver + sql-scco-opt-values) + 'sql-scroll-options a list with elements chosen from + '(sql-so-forward-only + sql-so-static + sql-so-keyset-driven + sql-so-dynamic + sql-so-mixed) + 'sql-search-pattern-escape string + 'sql-server-name string + 'sql-special-characters string + 'sql-static-sensitivity a list with elements chosen from + '(sql-ss-additions + sql-ss-deletions + sql-ss-updates) + 'sql-string-functions a list with elements chosen from + '(sql-fn-str-ascii + sql-fn-str-bit-length + sql-fn-str-char + sql-fn-str-char-length + sql-fn-str-character-length + sql-fn-str-concat + sql-fn-str-difference + sql-fn-str-insert + sql-fn-str-lcase + sql-fn-str-left + sql-fn-str-length + sql-fn-str-locate + sql-fn-str-ltrim + sql-fn-str-octet-length + sql-fn-str-position + sql-fn-str-repeat + sql-fn-str-replace + sql-fn-str-right + sql-fn-str-rtrim + sql-fn-str-soundex + sql-fn-str-space + sql-fn-str-substring + sql-fn-str-ucase) + 'sql-subqueries a list with elements chosen from + '(sql-sq-correlated-subqueries + sql-sq-comparison + sql-sq-exists + sql-sq-in + sql-sq-quantified) + 'sql-system-functions a list with elements chosen from + '(sql-fn-sys-dbname + sql-fn-sys-ifnull + sql-fn-sys-username) + 'sql-table-term string + 'sql-timedate-add-intervals a list with elements chosen from + '(sql-fn-tsi-frac-second + sql-fn-tsi-second + sql-fn-tsi-minute + sql-fn-tsi-hour + sql-fn-tsi-day + sql-fn-tsi-week + sql-fn-tsi-month + sql-fn-tsi-quarter + sql-fn-tsi-year) + 'sql-timedate-diff-intervals a list with elements chosen from + '(sql-fn-tsi-frac-second + sql-fn-tsi-second + sql-fn-tsi-minute + sql-fn-tsi-hour + sql-fn-tsi-day + sql-fn-tsi-week + sql-fn-tsi-month + sql-fn-tsi-quarter + sql-fn-tsi-year) + 'sql-timedate-functions a list with elements chosen from + '(sql-fn-td-current-date + sql-fn-td-current-time + sql-fn-td-current-timestamp + sql-fn-td-curdate + sql-fn-td-curtime + sql-fn-td-dayname + sql-fn-td-dayofmonth + sql-fn-td-dayofweek + sql-fn-td-dayofyear + sql-fn-td-extract + sql-fn-td-hour + sql-fn-td-minute + sql-fn-td-month + sql-fn-td-monthname + sql-fn-td-now + sql-fn-td-quarter + sql-fn-td-second + sql-fn-td-timestampadd + sql-fn-td-timestampdiff + sql-fn-td-week + sql-fn-td-year) + 'sql-txn-capable 'sql-tc-none, or + 'sql-tc-dml, or + 'sql-tc-ddl-commit, or + 'sql-tc-ddl-ignore, or + 'sql-tc-all + 'sql-txn-isolation-option same as for 'sql-default-txn-isolation + 'sql-union a list with elements chosen from + '(sql-u-union sql-u-union-all) + 'sql-user-name string + + [ODBC 2.0 or greater]: + 'sql-bookmark-persistence a list with elements chosen from + '(sql-bp-close sql-bp-delete + sql-bp-drop sql-bp-transaction + sql-bp-update sql-bp-other-hstmt) + + [ODBC 2.01 or greater]: + 'sql-oj-capabilities a list with elements chosen from + '(sql-oj-left + sql-oj-right + sql-oj-full + sql-oj-nested + sql-oj-not-ordered + sql-oj-inner + sql-oj-all-comparison-ops) + + [ODBC 3.0 or greater]: + 'sql-active-environments unsigned integer + 'sql-aggregate-functions a list with elements chosen from + '(sql-af-all + sql-af-avg + sql-af-count + sql-af-distinct + sql-af-max + sql-af-min + sql-af-sum) + 'sql-alter-domain a list with elements chosen from + '(sql-ad-add-domain-constraint + sql-ad-add-domain-default + sql-ad-constraint-name-definition + sql-ad-drop-domain-constraint + sql-ad-drop-domain-default + sql-ad-add-constraint-deferrable + sql-ad-add-constraint-non-deferrable + sql-ad-add-constraint-inititally-deferred + sql-ad-add-constraint-initially-immediate) + 'sql-async-mode 'sql-am-connection, or + 'sql-am-statement, or + 'sql-am-none + 'sql-batch-row-count a list with elements chosen from + '(sql-brc-rolled-up + sql-brc-procedures + sql-brc-explicit) + 'sql-batch-support a list with elements chosen from + '(sql-bs-select-explicit + sql-bs-row-count-explicit + sql-bs-select-proc + sql-bs-row-count-proc) + 'sql-catalog-location 'sql-cl-start or 'sql-cl-end + 'sql-catalog-name boolean + 'sql-catalog-name-separator string + 'sql-catalog-term string + 'sql-catalog-usage a list with elements chosen from + '(sql-cu-dml-statements + sql-cu-procedure-invocation + sql-cu-table-definition + sql-cu-index-definition + sql-cu-privilege-definition) + 'sql-collation-seq string + 'sql-convert-interval-year-month same as for 'sql-convert-bigint + 'sql-convert-interval-day-time same as for 'sql-convert-bigint + 'sql-convert-interval-year-month same as for 'sql-convert-bigint + 'sql-create-assertion a list with elements chosen from + '(sql-ca-create-assertion + sql-ca-constraint-initially-deferred + sql-ca-constraint-initially-immediate + sql-ca-constraint-deferrable + sql-ca-constraint-non-deferrable) + 'sql-create-character-set a list with elements chosen from + '(sql-ccs-create-character-set + sql-ccs-collate-clause + sql-ccs-limited-collation) + 'sql-create-collation a list with elements chosen from + '(sql-ccol-create-collation) + 'sql-create-domain a list with elements chosen from + '(sql-cdo-create-domain + sql-cdo-constraint-name-definition + sql-cdo-default + sql-cdo-constraint + sql-cdo-collation + sql-cdo-constraint-initially-deferred + sql-cdo-constraint-initially-immediate + sql-cdo-constraint-deferrable + sql-cdo-constraint-non-deferrable) + 'sql-create-schema a list with elements chosen from + '(sql-cs-create-schema + sql-cs-authorization + sql-cs-default-character-set) + 'sql-create-table a list with elements chosen from + '(sql-ct-create-table + sql-ct-table-constraint + sql-ct-constraint-name-definition + sql-ct-commit-preserve + sql-ct-commit-delete + sql-ct-global-temporary + sql-ct-local-temporary + sql-ct-column-constraint + sql-ct-column-default + sql-ct-column-collation + sql-ct-constraint-initially-deferred + sql-ct-constraint-initially-immediate + sql-ct-constraint-deferrable + sql-ct-constraint-non-deferrable) + 'sql-create-translation a list with elements chosen from + '(sql-ctr-create-translation) + 'sql-create-view a list with elements chosen from + '(sql-cv-create-view + sql-cv-check-option + sql-cv-cascaded + sql-cv-local) + 'sql-datetime-literals a list with elements chosen from + '(sql-dl-sql92-date + sql-dl-sql92-time + sql-dl-sql92-timestamp + sql-dl-sql92-interval-year + sql-dl-sql92-interval-month + sql-dl-sql92-interval-day + sql-dl-sql92-interval-hour + sql-dl-sql92-interval-minute + sql-dl-sql92-interval-second + sql-dl-sql92-interval-year-to-month + sql-dl-sql92-interval-day-to-hour + sql-dl-sql92-interval-day-to-minute + sql-dl-sql92-interval-day-to-second + sql-dl-sql92-interval-hour-to-minute + sql-dl-sql92-interval-hour-to-second + sql-dl-sql92-interval-minute-to-second) + 'sql-ddl-index 'sql-di-create-index or + 'sql-di-drop-index + 'sql-describe-parameter boolean + 'sql-dm-ver string + 'sql-driver-hdesc descriptor handle; `handle' argument + also a descriptor handle + 'sql-drop-assertion a list with elements chosen from + '(sql-da-drop-assertion) + 'sql-drop-character-set a list with elements chosen from + '(sql-dcs-drop-character-set) + 'sql-drop-collation a list with elements chosen from + '(sql-dc-drop-collation) + 'sql-drop-domain a list with elements chosen from + '(sql-dd-drop-domain + sql-dd-cascade + sql-dd-restrict) + 'sql-drop-schema a list with elements chosen from + '(sql-ds-drop-schema + sql-ds-cascade + sql-ds-restrict) + 'sql-drop-table a list with elements chosen from + '(sql-dt-drop-table + sql-dt-cascade + sql-dt-restrict) + 'sql-drop-translation a list with elements chosen from + '(sql-dtr-drop-translation) + 'sql-drop-view a list with elements chosen from + '(sql-dv-drop-view + sql-dv-cascade + sql-dv-restrict) + 'sql-cursor-sensitivity 'sql-insensitive, or + 'sql-unspecified, or + 'sql-sensitive + 'sql-dynamic-cursor-attributes1 a list with elements chosen from + '(sql-ca1-next sql-ca1-absolute + sql-ca1-relative sql-ca1-bookmark + sql-ca1-lock-exclusive + sql-ca1-lock-no-change + sql-ca1-lock-unlock sql-ca1-pos-position + sql-ca1-pos-update sql-ca1-pos-delete + sql-ca1-pos-refresh + sql-ca1-positioned-update + sql-ca1-positioned-delete + sql-ca1-select-for-update + sql-ca1-bulk-add + sql-ca1-bulk-update-by-bookmark + sql-ca1-bulk-delete-by-bookmark + sql-ca1-bulk-fetch-by-bookmark) + 'sql-dynamic-cursor-attributes2 a list with elements chosen from + '(sql_ca2_read_only_concurrency + sql_ca2_lock_concurrency + sql_ca2_opt_rowver_concurrency + sql_ca2_opt_values_concurrency + sql_ca2_sensitivity_additions + sql_ca2_sensitivity_deletions + sql_ca2_sensitivity_updates + sql_ca2_max_rows_select + sql_ca2_max_rows_insert + sql_ca2_max_rows_delete + sql_ca2_max_rows_update + sql_ca2_max_rows_catalog + sql_ca2_max_rows_affects_all + sql_ca2_crc_exact + sql_ca2_crc_approximate + sql_ca2_simulate_non_unique + sql_ca2_simulate_try_unique + sql_ca2_simulate_unique) + 'sql-forward-only-cursor-attributes1 + same as for 'sql-keyset-cursor-attributes1 + 'sql-forward-only-cursor-attributes2 + same as for 'sql-keyset-cursor-attributes2 + 'sql-index-keywords a list with elements chosen from + '(sql-ik-asc sql-ik-desc) + 'sql-info-schema-views a list with elements chosen from + '(sql-isv-assertions + sql-isv-character-sets + sql-isv-check-constraints + sql-isv-collations + sql-isv-column-domain-usage + sql-isv-column-privileges + sql-isv-columns + sql-isv-constraint-column-usage + sql-isv-constraint-table-usage + sql-isv-domain-constraints + sql-isv-domains + sql-isv-key-column-usage + sql-isv-referential-constraints + sql-isv-schemata + sql-isv-sql-languages + sql-isv-table-constraints + sql-isv-table-privileges + sql-isv-tables sql-isv-translations + sql-isv-usage-privileges + sql-isv-view-column-usage + sql-isv-view-table-usage) + 'sql-insert-statement a list with elements chosen from + '(sql-is-insert-literals + sql-is-insert-searched + sql-is-select-into) + 'sql-keyset-cursor-attributes1 same as for 'sql-dynamic-cursor-attributes1 + 'sql-keyset-cursor-attributes2 same as for 'sql-dynamic-cursor-attributes2 + 'sql-max-async-concurrent-statements unsigned integer + 'sql-max-concurrent-activities unsigned integer + 'sql-max-driver-connections unsigned integer + 'sql-max-identifier-len unsigned integer + 'sql-odbc-interface-conformance 'sql-oic-core, or + 'sql-oic-level1, or + 'sql-oic-level2 + 'sql-param-array-row-counts 'sql-parc-batch or 'sql-parc-no-batch + 'sql-param-array-selects 'sql-pas-batch, or 'sql-pas-no-batch, or + 'sql-pas-no-select + 'sql-schema-term string + 'sql-schema-usage a list with elements chosen from + '(sql-su-dml-statements + sql-su-procedure-invocation + sql-su-table-definition + sql-su-index-definition + sql-su-privilege-definition) + 'sql-sql-conformance 'sql-sc-sql92-entry, or + 'sql-sc-fips127-2-transitional, or + 'sql-sc-sql92-full, or + 'sql-sc-sql92-intermediate, or + 'sql-sql92-datetime-functions a list with elements chosen from + '(sql-sdf-current-date + sql-sdf-current-time + sql-sdf-current-timestamp) + 'sql-sql92-foreign-key-delete-rule + a list with elements chosen from + '(sql-sfkd-cascade + sql-sfkd-no-action + sql-sfkd-set-default + sql-sfkd-set-null) + 'sql-sql92-foreign-key-update-rule + a list with elements chosen from + '(sql-sfku-cascade + sql-sfku-no-action + sql-sfku-set-default + sql-sfku-set-null) + 'sql-sql92-grant a list with elements chosen from + '(sql-sg-delete-table + sql-sg-insert-column + sql-sg-insert-table + sql-sg-references-table + sql-sg-references-column + sql-sg-select-table + sql-sg-update-column + sql-sg-update-table + sql-sg-usage-on-domain + sql-sg-usage-on-character-set + sql-sg-usage-on-collation + sql-sg-usage-on-translation + sql-sg-with-grant-option) + 'sql-sql92-numeric-value-functions + a list with elements chosen from + '(sql-snvf-bit-length + sql-snvf-char-length + sql-snvf-character-length + sql-snvf-extract + sql-snvf-octet-length + sql-snvf-position) + 'sql-sql92-predicates a list with elements chosen from + '(sql-sp-between + sql-sp-comparison + sql-sp-exists + sql-sp-in + sql-sp-isnotnull + sql-sp-isnull + sql-sp-like + sql-sp-match-full + sql-sp-match-partial + sql-sp-match-unique-full + sql-sp-match-unique-partial + sql-sp-overlaps + sql-sp-quantified-comparison + sql-sp-unique) + 'sql-sql92-relational-join-operations + a list with elements chosen from + '(sql-srjo-corresponding-clause + sql-srjo-cross-join + sql-srjo-except-join + sql-srjo-full-outer-join + sql-srjo-inner-join + sql-srjo-intersect-join + sql-srjo-left-outer-join + sql-srjo-natural-join + sql-srjo-right-outer-join + sql-srjo-union-join) + 'sql-sql92-revoke a list with elements chosen from + '(sql-sr-cascade + sql-sr-delete-table + sql-sr-grant-option-for + sql-sr-insert-column + sql-sr-insert-table + sql-sr-references-column + sql-sr-references-table + sql-sr-restrict + sql-sr-select-table + sql-sr-update-column + sql-sr-update-table + sql-sr-usage-on-domain + sql-sr-usage-on-character-set + sql-sr-usage-on-collation + sql-sr-usage-on-translation) + 'sql-sql92-row-value-constructor a list with elements chosen from + '(sql-srvc-value-expression + sql-srvc-null + sql-srvc-default + sql-srvc-row-subquery) + 'sql-sql92-string-functions a list with elements chosen from + '(sql-ssf-convert + sql-ssf-lower + sql-ssf-upper + sql-ssf-substring + sql-ssf-translate + sql-ssf-trim-both + sql-ssf-trim-leading + sql-ssf-trim-trailing) + 'sql-sql92-value-expressions a list with elements chosen from + '(sql-sve-case + sql-sve-cast + sql-sve-coalesce + sql-sve-nullif) + 'sql-standard-cli-conformance a list with elements chosen from + '(sql-scc-xopen-cli-version1 + sql-scc-iso92-cli) + 'sql-static-cursor-attributes1 same as for 'sql-dynamic-cursor-attributes1 + 'sql-static-cursor-attributes2 same as for 'sql-dynamic-cursor-attributes2 + 'sql-xopen-cli-year string + +> (get-functions hdbc fn) + + ODBC 1.0. + + For the driver that supports the connection indicated by the connection + handle `hdbc', get-functions indicates whether the function or set + of functions denoted by the symbol `fn' is supported by the driver. + + For ODBC 2.0 or later, `fn' may be 'sql-api-all-functions. + In that case, get-functions returns a list of two-element lists in which + the first element is a symbol indicating a function name, and + the second element is #t if the driver supports the function, + otherwise #f. The function names in the list are those below indicated + as ODBC 2.0 or earlier. + + For ODBC 3.0 or greater, `fn' may be 'sql-api-odbc3-all-functions. + In that case, get-functions returns a list of two-element lists in which + the first element is a symbol indicating a function name, and + the second element is #t if the driver supports the function, + otherwise #f. The function names in the list include those from ODBC 3.0, + and those from ODBC 2.0 and earlier. + + `fn' may also be one of the symbols in the following list of functions. + In this case, get-functions returns #t if the function is supported, + #f otherwise. + + [ODBC 2.0 and earlier] + 'sql-api-sqlbindcol + 'sql-api-sqlcancel + 'sql-api-sqlconnect + 'sql-api-sqlgetfunctions + 'sql-api-sqlgetinfo + 'sql-api-sqldatasources + 'sql-api-sqldescribecol + 'sql-api-sqlgettypeinfo + 'sql-api-sqldisconnect + 'sql-api-sqlnumresultcols + 'sql-api-sqldrivers + 'sql-api-sqlparamdata + 'sql-api-sqlprepare + 'sql-api-sqlexecdirect + 'sql-api-sqlputdata + 'sql-api-sqlexecute + 'sql-api-sqlrowcount + 'sql-api-sqlfetch + 'sql-api-sqlsetcursorname + 'sql-api-sqlfreestmt + 'sql-api-sqlgetcursorname + 'sql-api-sqlgetdata + 'sql-api-sqlcolumns + 'sql-api-sqlstatistics + 'sql-api-sqlspecialcolumns + 'sql-api-sqltables + 'sql-api-sqlbindparameter + 'sql-api-sqlnativesql + 'sql-api-sqlbrowseconnect + 'sql-api-sqlnumparams + 'sql-api-sqlprimarykeys + 'sql-api-sqlcolumnprivileges + 'sql-api-sqlprocedurecolumns + 'sql-api-sqldescribeparam + 'sql-api-sqlprocedures + 'sql-api-sqldriverconnect + 'sql-api-sqlsetpos + 'sql-api-sqlforeignkeys + 'sql-api-sqltableprivileges + 'sql-api-sqlmoreresults + + [ODBC 3.0] + 'sql-api-sqlallochandle + 'sql-api-sqlgetdescfield + 'sql-api-sqlgetdescrec + 'sql-api-sqlgetdiagfield + 'sql-api-sqlclosecursor + 'sql-api-sqlgetdiagrec + 'sql-api-sqlcolattribute + 'sql-api-sqlgetenvattr + 'sql-api-sqlcopydesc + 'sql-api-sqlgetstmtattr + 'sql-api-sqlendtran + 'sql-api-sqlsetconnectattr + 'sql-api-sqlfetchscroll + 'sql-api-sqlfreehandle + 'sql-api-sqlgetconnectattr + 'sql-api-sqlsetdescfield + 'sql-api-sqlsetdescrec + 'sql-api-sqlsetenvattr + 'sql-api-sqlsetstmtattr + 'sql-api-sqlbulkoperations + +> (get-connect-attr hdbc attr) + + ODBC 3.0. + + For the connection handle `hdbc', returns the value of an attribute + given by the symbol `attr'. The permissible values of `attr' and + the corresponding ranges of return values are: + + 'sql-attr-access-mode 'sql-mode-read-only, 'sql-mode-read-write + 'sql-attr-async-enable 'sql-async-enable-off, 'sql-async-enable-on + 'sql-attr-autocommit 'sql-autocommit-off, 'sql-autocommit-on + 'sql-attr-auto-ipd boolean + 'sql-attr-connection-dead 'sql-cd-true, 'sql-cd-false + 'sql-attr-connection-timeout exact integer + 'sql-attr-current-catalog string + 'sql-attr-login-timeout exact integer + 'sql-attr-metadata-id boolean + 'sql-attr-odbc-cursors 'sql-cur-use-if-needed, + 'sql-cur-use-odbc, + 'sql-cur-use-driver + 'sql-attr-packet-size exact integer + 'sql-attr-quiet-mode exact integer + 'sql-attr-trace exact integer + 'sql-attr-tracefile string + 'sql-attr-translate-lib string + 'sql-attr-translate-option exact intger + 'sql-attr-txn-isolation 'sql-txn-read-uncommitted, + 'sql-txn-read-committed, + 'sql-txn-repeatable-read, + 'sql-txn-serializable + + See an ODBC reference for the significance of these connection attributes. + Driver-specific attributes are not supported. + +> (get-connect-option hdbc option) + + ODBC 1.0, deprecated in favor of get-connect-attr. + + For a connection handle `hdbc', returns the value of the + connection option specified by the symbol `option'. + The permisible values of `option' are the same as for `attr' in + `get-connect-attr'. See `get-connect-attr' for more information. + +> (set-connect-attr hdbc attr val) + + For a connection handle `hdbc', sets the attribute indicated by the + symbol `attr' to be `val'. The type of `val' depends on `attr', + as follows: + + 'sql-attr-access-mode 'sql-mode-read-only, 'sql-mode-read-write + 'sql-attr-async-enable 'sql-async-enable-off, 'sql-async-enable-on + 'sql-attr-autocommit 'sql-autocommit-off, 'sql-autocommit-on + 'sql-attr-connection-timeout exact integer + 'sql-attr-current-catalog string + 'sql-attr-login-timeout exact integer + 'sql-attr-metadata-id boolean + 'sql-attr-odbc-cursors 'sql-cur-use-if-needed, + 'sql-cur-use-odbc, + 'sql-cur-use-driver + 'sql-attr-packet-size exact integer + 'sql-attr-quiet-mode exact integer + 'sql-attr-trace exact integer + 'sql-attr-tracefile string + 'sql-attr-translate-lib string + 'sql-attr-translate-option exact intger + 'sql-attr-txn-isolation 'sql-txn-read-uncommitted, + 'sql-txn-read-committed, + 'sql-txn-repeatable-read, + 'sql-txn-serializable + + Returns the value of `hdbc'. + + Note that some connection attributes listed in the documentation + for `get-connect-attr' are not settable. The type boolean + above indicates that any Scheme value other than #f is + interpreted as true. + + See an ODBC reference for the significance of these connection attributes. + Driver-specific attributes are not supported. + +> (set-connect-option hdbc option val) + + ODBC 1.0, deprecated in favor of set-connect-attr. + + For a connection handle `hdbc', sets the option indicated by the + symbol `option' to be `val'. The type of `val' depends on `attr'. + The permisible values of `option' are the same as for `attr' in + `set-connect-attr'. See `set-connect-attr' for more information. + Returns the value of `hdbc'. + + Statements and Parameters + ------------------------- + +> (prepare hstmt sql) + + ODBC 1.0. + + Compiles the SQL statement given by the string `sql' for the + statement handle `hstmt'. Returns the value of `hstmt'. Once + an SQL statement has been compiled for a statement handle, + `sql-execute' can be called as many times as desired using that handle. + +> (execute hstmt) + + ODBC 1.0. + + Executes the SQL statement associated with the statement handle + `hstmt'. The SQL statement must have been compiled using + `sql-prepare'. When a statement executes, its parameters, + indicated by ?'s in the SQL text, are replaced by the values + bound to those parameters. See `bind-parameter' and `bind-param'. + The value of `hstmt' is returned. + +> (exec-direct hstmt sql) + + ODBC 1.0. + + Compiles and executes the SQL statement `sql', a string, and + associates that statement with the statement handle `hstmt'. + When a statement executes, its parameters, indicated by ?'s in + the SQL text, are replaced by the values bound to those parameters. + See `bind-parameter' and `bind-param'. The value of `hstmt' is + returned. + +> (native-sql hdbc sql) + + ODBC 1.0. + + Given a connection handle `hdbc' and an SQL statement `sql', returns + a string indicating the SQL that would be passed to the + data source associated with the handle. + +> (param-data hstmt) + + ODBC 1.0. + + Returns the sql-buffer that is bound to the statement handle + `hstmt'. If no such buffer exists, an error occurs. + +> (put-data hstmt buff) + + ODBC 1.0. + + Given the statement handle `hstmt' and an sql-buffer `buff', + sends the buffer data to either 1) the parameter associated + with the statement, or 2) the column associated with the + statement, for use with bulk-operations or set-pos. Returns the + value of `hstmt'. + +> (cancel hstmt) + + ODBC 1.0. + + Terminates processing of the statement given by the statement handle + `hstmt'. Returns the value of `hstmt'. + +> (end-tran handle action) + + ODBC 3.0. + + Requests a commit or rollback for all transactions associated with + `handle', which may be either an environment handle or a + connection handle. `action' is one of the symbols + 'sql-commit or 'sql-rollback. Returns the value of `handle'. + +> (transact henv hdbc action) + + ODBC 1.0, deprecated in favor of end-tran. + + Requests a commit or rollback for all transactions associated with + either the environment handle `henv' or the connection handle `hdbc'. + `action' is one of the symbols 'sql-commit or 'sql-rollback. + If `hdbc' is the symbol 'sql-null-hdbc, the action is performed + for the environment handle; otherwise, it is performed for the + connection handle. Returns void. + +> (num-params hstmt) + + ODBC 1.0. + + Returns the number of parameters (placeholders indicated by a ?) + in the SQL associated with the statement handle `hstmt'. + The `prepare' procedure must be called before calling this + procedure. + +> (bind-parameter hstmt num param-type sql-type col-size buff ind [digits]) + + ODBC 2.0. + + Associates the sql-buffer `buff' with the parameter (a placeholder + indicated by ? in an SQL statement) denoted by the statement + handle `hstmt' and positive integer `num'. The param-type is + one of the symbols 'sql-param-input, 'sql-param-output, or + 'sql-param-input-output. `sql-type' is an SQL data type. + `col-size' is the number of bytes to be sent from the buffer + to the parameter, or, if `sql-data-type' is any of 'sql-decimal, + 'sql-numeric, 'sql-float, 'sql-real, or 'sql-double, the number of + digits of precision used. `ind' is an sql-indicator. The optional + argument `digits' indicates the number of digits to the right of the + decimal point, and is used if `sql-data-type' is 'sql-decimal, + 'sql-numeric, 'sql-time, 'sql-timestamp, 'sql-type-time, + 'sql-type-timestamp, 'sql-interval-second, 'sql-interval-day-to-second, + 'sql-interval-hour-to-second, or 'sql-interval-minute-to-second. + Returns the value of `hstmt'. + + The `prepare' procedure must be called before calling `bind-parameter'. + +> (param-options hstmt numrows) + + ODBC 1.0, deprecated in favor of set-stmt-attr. + + For the statement handle `hstmt', indicates to the ODBC driver the + number of rows associated with each parameter. `numrows' is + an exact positive integer. Returns the current row number. + +> (describe-param hstmt pos) + + ODBC 1.0. + + For the statement handle `hstmt', returns information about the + parameter at position `pos', a positive exact integer. The + returned information is a list consisting of + + - a symbol indicating an SQL data type, + - an exact integer that denotes, depending on the data type, + either the number of bytes expected by a data source for + the parameter, or the precision associated with the data type + - an exact integer denoting the number of trailing decimal digits + expected in the column or expression associated with the parameter + - a symbol indicating the parameter may be associated with + NULLs, either 'sql-no-nulls, 'sql-nullable, or + 'sql-nullable-unknown. + +> (bind-param hstmt num sql-type col-size buff ind [digits]) + + ODBC 3.0, deprecated in favor of bind-parameter. + + Associates the sql-buffer `buff' with the parameter (a placeholder + indicated by ? in an SQL statement) denoted by the statement + handle `hstmt' and positive integer `num'. The arguments are as + for the same-named arguments of procedure `bind-parameter'; some arguments + are omitted for `bind-param'. Note that `bind-param' always + assumes an input parameter, unlike `bind-parameter', which takes + an argument to indicate the parameter type. Returns the value + of `hstmt'. + +> (set-param hstmt num sql-type buff ind) + + ODBC 1.0, deprecated in favor of bind-parameter. + + Associates the sql-buffer `buff' with the parameter (a placeholder + indicated by ? in an SQL statement) denoted by the statement + handle `hstmt' and positive integer `num'. `sql-type' is an SQL + data type. `ind' is an sql-indicator. Returns the value of + `hstmt'. + +> (get-stmt-attr hstmt attr) + + ODBC 3.0. + + For the statement handle `hstmt', returns the value of its + associated attribute `attr'. The statement handle attributes + and their possible values are: + + attr returns + ---- ------- + 'sql-attr-app-param-desc an APD descriptor handle + 'sql-attr-app-row-desc an ARD descriptor handle + 'sql-attr-async-enable 'sql-async-enable-off, or + 'sql-async-enable-on + 'sql-attr-concurrency 'sql-concur-read-only, or + 'sql-concur-lock, or + 'sql-concur-rowver, or + 'sql-concur-values + 'sql-attr-cursor-scrollable 'sql-nonscrollable, or + 'sql-scrollable + 'sql-attr-cursor-sensitivity 'sql-insensitive, or + 'sql-sensitive, or + 'sql-unspecified + 'sql-attr-cursor-type 'sql-cursor-forward-only, or + 'sql-cursor-static, or + 'sql-cursor-keyset-driven, or + 'sql-cursor-dynamic + 'sql-attr-enable-auto-ipd boolean + 'sql-attr-fetch-bookmark-ptr unsigned integer + 'sql-attr-imp-param-desc an IPD descriptor handle + 'sql-attr-imp-row-desc an IRD descriptor handle + 'sql-attr-keyset-size unsigned integer + 'sql-attr-max-length unsigned integer + 'sql-attr-max-rows unsigned integer + 'sql-attr-metadata-id boolean + 'sql-attr-noscan 'sql-noscan-off, or + 'sql-noscan-on + 'sql-attr-param-bind-offset-ptr sql-boxed-uint + (see read-boxed-uint, below) + 'sql-attr-param-bind-type 'sql-param-bind-by-column, or + unsigned integer + 'sql-attr-param-operation-ptr sql-op-parms (see read-op-parms, below) + 'sql-attr-param-status-ptr row-status (see below) + 'sql-attr-params-processed-ptr sql-boxed-uint + (see read-boxed-uint, below) + 'sql-attr-paramset-size unsigned integer + 'sql-attr-query-timeout unsigned integer + 'sql-attr-retrieve-data 'sql-rd-on, or + 'sql-rd-off + 'sql-attr-row-array-size unsigned integer + 'sql-attr-row-bind-offset-ptr sql-boxed-uint + (see read-boxed-uint, below) + 'sql-attr-row-bind-type 'sql-bind-by-column, or + unsigned integer + 'sql-attr-row-number unsigned integer + 'sql-attr-row-operation-ptr op-parms (see read-op-parms, below) + 'sql-attr-row-status-ptr row-status (see read-row-status, below) + 'sql-attr-rows-fetched-ptr sql-boxed-uint + (see read-boxed-uint, below) + 'sql-attr-simulate-cursor 'sql-sc-non-unique, or + 'sql-sc-try-unique, or + 'sql-sc-unique + 'sql-attr-use-bookmarks 'sql-ub-off, or + 'sql-ub-variable, or + 'sql-ub-on + + See an ODBC reference for information about the significance of + these attributes. The type `sql-boxed-uint' is a Scheme representation + of a pointer value. See `read-boxed-uint', below. + An instance of the type `sql-op-parms' is a value that encapsulates an + array whose elements are either 'sql-param-proceed or + 'sql-param-ignore. See `read-op-parms', below. An instance + of the type `sql-row-status' encapsulates an array, one element for + each parameter in the statement, each with one of the values: + + 'sql-param-success + 'sql-param-success-with-info + 'sql-param-error + 'sql-param-unused + 'sql-param-diag-unavilable + +> (get-stmt-option hstmt option) + + ODBC 1.0, deprecated in favor of get-stmt-attr. + + For the statement handle `hstmt', returns the value of its + associated `option'. The statement handle options + and their return values are: + + option returns + ------ ------- + 'sql-async-enable 'sql-async-enable-off, or + 'sql-async-enable-on + 'sql-bind-type 'sql-param-bind-by-column, or + unsigned integer + 'sql-concurrency 'sql-concur-read-only, or + 'sql-concur-lock, or + 'sql-concur-rowver, or + 'sql-concur-values + 'sql-cursor-type 'sql-cursor-forward-only, or + 'sql-cursor-static, or + 'sql-cursor-keyset-driven, or + 'sql-cursor-dynamic + 'sql-keyset-size unsigned integer + 'sql-max-length unsigned integer + 'sql-max-rows unsigned integer + 'sql-noscan 'sql-noscan-off, or + 'sql-noscan-on + 'sql-query-timeout unsigned integer + 'sql-retrieve-data 'sql-rd-on, or + 'sql-rd-off + 'sql-rowset-size unsigned integer + 'sql-simulate-cursor 'sql-sc-non-unique, or + 'sql-sc-try-unique, or + 'sql-sc-unique + 'sql-use-bookmarks 'sql-ub-off, or + 'sql-ub-variable, or + 'sql-ub-on + + See an ODBC reference for the significance of these options. + +> (set-stmt-attr hstmt attr val) + + ODBC 3.0. + + For the statement handle `hstmt', sets its associated attribute `attr' + to the value `val'. See `get-stmt-attr' for attributes and + their possible values. Returns the value of `hstmt'. + +> (set-stmt-option hstmt attr val) + + ODBC 1.0, deprecated in favor of set-stmt-attr. + + For the statement handle `hstmt', sets its associated `option' + to the value `val'. See `get-stmt-option' for options and + their possible values. Returns the value of `hstmt'. + + Descriptors + ----------- + +> (copy-desc hdesc-src hdesc-target) + + ODBC 3.0. + + Copies information from descriptor handle `hdesc-src' to + descriptor handle `hdesc-target'. Returns the value of + `hdesc-src'. + +> (get-desc-rec hdesc recnum) + + ODBC 3.0. + + Given a descriptor handle `hdesc' and record number + `recnum', a positive exact integer, returns a list + of values pertaining to the descriptor record. The first + element of that list is a string, the name of the parameter or column + associated with the descriptor record; the second element + is a symbol indicating a concise SQL data type (see SQL data + types, below); the third element is a symbol that indicates an + interval subtype for the types 'sql-datetime or 'sql-interval, + otherwise 'no-subtype; the fourth element is an exact integer + indicating the byte length of the parameter or column; the fifth + element is an exact integer indicating the number of digits of + precision for the parameter or column (only relevant for numeric data + types); the sixth element is an exact integer indicating the number of + digits to the right of the decimal point used for data in the + column or parameter; while the seventh element is one of + 'sql-no-nulls, 'sql-nullable, or 'sql-nullable-unknown, indicating + whether the parameter or column may have NULL values. + +> (set-desc-rec hdesc recnum type subtype length precision scale buff len ind) + + ODBC 3.0. + + For the descriptor record denoted by the descriptor handle `hdesc' and + positive exact integer `recnum', sets its associated information. + `type' is a symbol indicating a concise SQL or C data type (see SQL data + types, below); `subtype' is a symbol indicating a subtype for the types + 'sql-datetime or 'sql-interval, or it may be 'no-subtype; + `len' is an sql-length (see make-length and read-length, below), which + should be initialized to the desired length of the column or parameter + associated with the descriptor record; `ind' is an sql-indicator + (see Indicators, below). Returns the value of `hdesc'. + +> (get-desc-field hdesc recnum field) + + ODBC 3.0. + + For the descriptor handle `hdesc', returns the value of a field + in the descriptor record with index `recnum', an integer. `field' is a + symbol indicating the field within that record. + + Valid values of `field' and their return types are listed below. + Please consult an ODBC reference for the significance of these + fields. + + field returns + ----- ------- + 'sql-desc-alloc-type integer + 'sql-desc-array-size unsigned integer + 'sql-desc-array-status-ptr array status indicator + 'sql-desc-bind-offset-ptr binding offset + 'sql-desc-bind-type integer + 'sql-desc-count integer + 'sql-desc-rows-processed-ptr rows-processed + 'sql-desc-auto-unique-value integer + 'sql-desc-base-column-name string + 'sql-desc-case-sensitive boolean + 'sql-desc-concise-type SQL data type + 'sql-desc-base-table-name string + 'sql-desc-catalog-name string + 'sql-desc-data-ptr sql-buffer + 'sql-desc-datetime-interval-code 'sql-code-date, or + 'sql-code-time, or + 'sql-code-timestamp, or + 'sql-code-day, or + 'sql-code-day-to-hour, or + 'sql-code-day-to-minute, or + 'sql-code-day-to-second, or + 'sql-code-hour, or + 'sql-code-hour-to-minute, or + 'sql-code-hour-to-second, or + 'sql-code-minute, or + 'sql-code-minute-to-second, or + 'sql-code-month, or + 'sql-code-second, or + 'sql-code-year, or + 'sql-code-year-to-month + 'sql-desc-datetime-interval-precision integer + 'sql-desc-display-size integer + 'sql-desc-fixed-prec-scale boolean + 'sql-desc-indicator-ptr sql-indicator + 'sql-desc-label string + 'sql-desc-length unsigned length + 'sql-desc-literal-prefix string + 'sql-desc-literal-suffix string + 'sql-desc-local-type-name string + 'sql-desc-name string + 'sql-desc-nullable 'sql-nullable, or + 'sql-no-nulls, or + 'sql-nullable-unknown + 'sql-desc-num-prec-radix integer + 'sql-desc-octet-length integer + 'sql-desc-octet-length-ptr octet-length + 'sql-desc-parameter-type 'sql-param-input, or + 'sql-param-output, or + 'sql-param-input-output + 'sql-desc-precision integer + 'sql-desc-rowver boolean + 'sql-desc-scale integer + 'sql-desc-schema-name string + 'sql-desc-searchable for ODBC 3.0 or greater: + 'sql-pred-char, or + 'sql-pred-basic, or + 'sql-pred-none, or + 'sql-pred-searchable + for earlier versions: + 'sql-all-except-like, or + 'sql-like-only, or + 'sql-searchable, or + 'sql-unsearchable + 'sql-desc-table-name string + 'sql-desc-type SQL data type (except intervals) + 'sql-desc-type-name string + 'sql-desc-unnamed 'sql-named or 'sql-unnamed + 'sql-desc-unsigned boolean + 'sql-desc-updatable 'sql-attr-readonly, or + 'sql-attr-write, or + 'sql-attr-readwrite-unknown + +> (set-desc-field hdesc recnum field val) + + ODBC 3.0. + + For the descriptor handle `hdesc', sets the field indicated + by the symbol `field' in the record with index `recnum', an integer, + to the value `val'. See get-desc-field for valid values of + `field' and corresponding types for `val'. Returns the value of + `hdesc'. + + Cursors + ------- + +> (get-cursor-name hstmt) + + ODBC 1.0. + + Returns a string naming the cursor associated with the statement + handle `hstmt'. + +> (set-cursor-name hstmt name) + + ODBC 1.0. + + Assigns the string `name' as the name of the cursor associated with + the statement handle `hstmt'. Returns the value of `hstmt'. + +> (close-cursor hstmt) + + ODBC 3.0. + + Closes the cursor associated with the statement handle `hstmt', + discarding any pending results. Returns the value of `hstmt'. + + Columns and data retrieval + ------------------------------- + + Data in a relational database is organized into tables consisting + of rows and columns. A column corresponds to a field in the + database. A row is an individual data record. + +> (num-result-cols hstmt) + + ODBC 1.0. + + Returns the number of data columns in the data set associated with + the statement handle `hstmt'. + +> (describe-col hstmt colnum) + + ODBC 1.0. + + Given the statement handle `hstmt' and the exact integer `colnum', + indicating a column number, returns a list of information describing + a column in a data set. The first element in the list is a + string giving the name of the column; the second element is a + symbol indicating its SQL data type (see SQL data types, below); + the third element is the maximum byte length of data for the + column; the fourth element is either the number of digits to the right + of the decimal point, for relevant data types (see SQL data types), + otherwise 0; the fifth element is a symbol indicating whether the column + accepts NULL entries, either 'sql-no-nulls, 'sql-nullable, or + 'sql-nullable-unknown. + +> (col-attribute hstmt colnum attr) + + ODBC 3.0. + + Given the statement handle `hstmt', an exact integer `colnum', + indicating a column number, and the symbol `attr', indicating a + column attribute, returns the value of the column attribute. + Columns are numbered starting at 1. The attributes and their + associated types are + + attr returns + ---- ------- + 'sql-desc-count integer + 'sql-desc-auto-unique-value boolean + 'sql-desc-base-column-name string + 'sql-desc-base-table-name string + 'sql-desc-case-sensitive boolean + 'sql-desc-catalog-name string + 'sql-desc-concise-type SQL data type + 'sql-desc-data-ptr sql-buffer + 'sql-desc-display-size integer + 'sql-desc-fixed-prec-scale boolean + 'sql-desc-label string + 'sql-desc-length integer + 'sql-desc-literal-prefix string + 'sql-desc-literal-suffix string + 'sql-desc-local-type-name string + 'sql-desc-name string + 'sql-desc-nullable 'sql-nullable, or + 'sql-no-nulls, or + 'sql-nullable-unknown + 'sql-desc-num-prec-radix integer + 'sql-desc-octet-length integer + 'sql-desc-precision integer + 'sql-desc-scale integer + 'sql-desc-schema-name string + 'sql-desc-searchable ODBC 3.0 or greater: + 'sql-pred-char, or + 'sql-pred-basic, or + 'sql-pred-none, or + 'sql-pred-searchable + earlier versions of ODBC: + 'sql-like-only, or + 'sql-all-except-like, or + 'sql-searchable, or + 'sql-unsearchable + 'sql-desc-table-name string + 'sql-desc-type concise SQL data type + 'sql-desc-type-name string + 'sql-desc-unnamed 'sql-named, or + 'sql-unnamed + 'sql-desc-unsigned boolean + 'sql-desc-updatable 'sql-attr-readonly, or + 'sql-attr-write, or + 'sql-attr-readwrite-unknown + +> (col-attributes hstmt colnum attr) + + ODBC 1.0, deprecated in favor of col-attribute. + + Given the statement handle `hstmt', an exact integer `colnum', + indicating a column number, and the symbol `attr', indicating a + column attribute, returns the value of the column attribute. + Columns are numbered starting at 1. The attributes and their + associated types are + + attr returns + ---- ------- + 'sql-column-count integer + 'sql-column-name string + 'sql-column-type SQL data type + 'sql-column-length integer + 'sql-column-precision integer + 'sql-column-scale integer + 'sql-column-display-size integer + 'sql-column-nullable 'sql-no-nulls, or + 'sql-nullable + 'sql-column-unsigned boolean + 'sql-column-money boolean + 'sql-column-updatable 'sql-attr-readonly, or + 'sql-attr-write, or + 'sql-attr-readwrite-unknown + 'sql-column-auto-increment boolean + 'sql-column-case-sensitive boolean + 'sql-column-searchable 'sql-searchable, or + 'sql-like-only, or + 'sql-all-except-like, or + 'sql-unsearchable + 'sql-column-type-name string + 'sql-column-table-name string + 'sql-column-owner-name string + 'sql-column-qualifier-name string + 'sql-column-label string + +> (bind-col hstmt colnum buff ind) + + ODBC 1.0. + + Associates the sql-buffer `buff' and sql-indicator `ind' + with a column of data denoted by the statement handle `hstmt' + and column numer `colnum', an integer. Returns the value + of `hstmt'. + +> (fetch hstmt) + + ODBC 1.0. + + Retrieves data in the current row of the data set for + the statement handle `hstmt' into the sql-buffers + bound to the data set's columns, and sets the columns' + associated sql-indicator's. Returns the value of `hstmt'. + For columns without bound sql-buffers, `get-data' can be used + to retrieve data following a `fetch'. + +> (get-data hstmt colnum buff ind) + + Retrieves data in the current row of the data set for + the column denoted by the statement handle `hstmt' + and column number `colnum', an integer, into the sql-buffer + `buff' and sets the sql-indicator `ind'. Returns the value of + `hstmt'. `get-data' allows column data to be retrieved without + binding columns to buffers. + +> (fetch-scroll hstmt orient [rownum]) + + ODBC 3.0. + + Fetches multiple rows of data in a data set associated with + the statement handle `hstmt'. `orient' indicates which rows + to fetch, and may be one of the symbols + + 'sql-fetch-first first rowset + 'sql-fetch-next next rowset + 'sql-fetch-prior previous rowset + 'sql-fetch-last last rowset + 'sql-fetch-absolute rowset starting at `rownum' + 'sql-fetch-relative rowset relative to current, + using `rownum' (may be negative) + 'sql-fetch-bookmark rowset relative to + 'sql-attr-fetch-bookmark-ptr + statement attribute + + fetch-scroll returns the value of `hstmt'. The size of rowsets is + specified by the 'sql-attr-rowset-size statement attribute (see + `get-stmt-attr' and `set-stmt-attr'). See an ODBC reference for more + information on using rowsets. + +> (set-scroll-options hstmt concurrency keyset size) + + ODBC 1.0, deprecated in favor of get-info and set-stmt-attr. + + Sets cursor scrolling options for the statement handle + `hstmt'. `concurrency' is one of + + 'sql-concur-read-only updates and deletes not permitted + 'sql-concur-lock updates and deletes permitted + 'sql-concur-rowver compares row versions for concurrency + control + 'sql-concur-values compares values for concurrency control + + `keyset' is one of + + 'sql-scroll-forward-only only forward scrolling + 'sql-scroll-static no scrolling + 'sql-scroll-keyset-driven cursor uses keys for scrolling + 'sql-scroll-dynamic use `size' parameter for keyset size + + `size', a nonnegative exact integer, gives the size of + rowsets when using `extended-fetch'. Returns the value of `hstmt'. + +> (extended-fetch hstmt orientation [rownum]) + + ODBC 1.0, deprecated in favor of fetch-scroll. + + Retrieves a rowset from a result data set for the statement handle + `hstmt' and returns a row-status value (see Row Status, below). + `orientation' indicates which rowset is to be retrieved, one of + + 'sql-fetch-first first rowset in the data set + 'sql-fetch-next next rowset in the data set + 'sql-fetch-prior prior rowset in the data set + 'sql-fetch-last last rowset in the data set + 'sql-fetch-absolute fetches the rowset starting at the row + given by `rownum' + 'sql-fetch-relative fetches the rowset `rownum' rows from + the start row of the current rowset + 'sql-fetch-bookmark fetches the rowset, interpreting + `rownum' as a bookmark + + The `rownum' argument is an integer, which may be negative. + It must be provided if `orientation' is in 'sql-fetch-absolute, + 'sql-fetch-relative, or 'sql-fetch-bookmark, and must be omitted + otherwise. + +> (more-results hstmt) + + ODBC 1.0. + + Retrieves the next data set for the statement handle `hstmt', whose + value is returned by the procedure. `more-results', which moves between + data sets, is distinguished from procedures such as `fetch', which return + results within data sets. + +> (set-pos hstmt rownum operation lock) + + ODBC 1.0. + + Sets a cursor position for the statement handle `hstmt' + and updates the data source. `rownum', a nonnegative exact + integer, specifies the ordinal position of the row within the + current rowset where `operation' is to occur. A value of 0 + indicates that the operation is to occur on every row in the + rowset. + +`operation' is one of + + 'sql-position positions the cursor at the indicated row + 'sql-refresh refreshes data in buffers associated with + the rowset indicated by `rownum' + 'sql-add a new row is added to the data source (but see below) + 'sql-update data in buffers is used to update the rowset + 'sql-delete deletes the indicated row from the data source + + `set-pos' with 'sql-add is deprecated in favor of `bulk-operations' + with 'sql-add. + + `lock' indicates the lock status for the row or rows after the + operation is performed, one of + + 'sql-lock-no-change use lock status before operation performed + 'sql-lock-exclusive no other application or connection can + access + 'sql-lock-unlock no lock restrictions on access + + set-pos returns the value of `hstmt'. + +> (bulk-operations hstmt operation) + + ODBC 3.0. + + Performs bulk inserts and bulk bookmark operations on the data source + associated with the statement handle `hstmt'. `operation' may + be one of + + 'sql-add adds new rows + 'sql-update-by-bookmark updates rows identified by a bookmark + 'sql-delete-by-bookmark deletes rows identified by a bookmark + 'sql-fetch-by-bookmark retrieves rows identified by a bookmark + + Returns the value of `hstmt'. + + The details of using bulk-operations are beyond the scope of this + documentation. Consult an ODBC reference for more information. + +> (row-count hstmt) + + ODBC 1.0. + + For the data source associated with the statement handle `hstmt', + returns the number of rows affected by the most recent INSERT, + UPDATE, or DELETE operation. + + Metadata + -------- + +> (column-privileges hstmt catalog schema table column) + + Creates a result data set describing column privileges in the current + data source. There are at least eight columns in the resulting data set; a + driver may add columns. The contents of those columns are beyond the scope + of this documentation; consult an ODBC reference for details. + + `hstmt' is a statement handle, and its value is returned by the + procedure. `catalog', `schema', `table', and `column' are strings. + `column' may contain an underscore "_" indicating a single-character + wildcard, or a percent sign "%", which matches zero or more characters. + +> (columns hstmt catalog schema table column) + + Creates a result data set describing columns in the current data source. + There are at least eighteen columns in the resulting data set; a + driver may add columns. The contents of those columns are beyond the scope + of this documentation; consult an ODBC reference for details. + + `hstmt' is a statement handle, whose value is returned by the procedure. + `catalog', `schema', `table', and `column' are strings. `table' and + `column' may contain an underscore "_" indicating a single-character + wildcard, or a percent sign "%", which matches zero or more characters. + +> (foreign-keys hstmt catalog schema table fk-catalog fk-schema fk-table) + + ODBC 1.0. + + Creates a result data set containing foreign key information for the + specified table. There are fourteen ODBC-defined columns in the resulting + data set; a driver may add columns. The contents of those columns are beyond + the scope of this documentation; consult an ODBC reference for details. + + `hstmt' is a statement handle; its value is returned by the procedure. + `catalog', `schema', `table', `fk-catalog', `fk-schema', and `fk-table' + are all strings. `catalog', `schema', and `table' specify a table + containing a primary key, while `fk-catalog', `fk-schema', and `fk-table' + specify a table containing a foreign key. + +> (get-type-info hstmt type) + + ODBC 1.0. + + Given a statement handle `hstmt' and a symbol `type' indicating an + SQL data type (see SQL data types, below), creates a result data set + describing support for that data type in the current data source. + Returns the value of `hstmt'. There are at least nineteen columns in + the resulting data set; a driver may add columns. The contents of + those columns are beyond the scope of this documentation; consult an + ODBC reference for details. + +> (primary-keys hstmt catalog schema table) + + ODBC 1.0. + + Creates a result data set containing the column names that make up the + primary key for a table. There are up to six ODBC-defined columns in + the resulting data set; a driver may add columns. The contents of those + columns are beyond the scope of this documentation; consult an ODBC + reference for details. + + `hstmt' is a statement handle; its value is returned by the procedure. + `catalog', `schema', and `table' are strings. + +> (procedure-columns hstmt catalog schema name column) + + ODBC 1.0. + + Creates a result data set containing the input and output parameters and + columns associated with registered procedures in the current data source. + There are nineteen ODBC-defined columns in the resulting data set; a + driver may add columns. The contents of those columns are beyond the + scope of this documentation; consult an ODBC reference for details. + + `hstmt' is a statement handle; its value is returned by the procedure. + `catalog', `schema', `name', and `column' are strings. `name' indicates + a procedure name, while `column' is a column name. `schema', `name', and + `column' may contain an underscore "_" indicating a single-character + wildcard, or a percent sign "%", which matches zero or more characters. + +> (procedures hstmt catalog schema name) + + ODBC 1.0. + + Creates a result data set containing the registered procedure names in the + current data source. There are eight ODBC-defined columns in the + resulting data set; a driver may add columns. The contents of those + columns are beyond the scope of this documentation; consult an ODBC + reference for details. + + `hstmt' is a statement handle; its value is returned by the procedure. + `catalog', `schema', and `name' are strings. `name' indicates a procedure + name. Both `schema' and `name' may contain an underscore "_" indicating + a single-character wildcard, or a percent sign "%", which matches zero or + more characters. + +> (table-privileges hstmt catalog schema table) + + ODBC 1.0. + + Creates a result data set describing tables in the system catalog. + Such a data set consists of at least seven string columns, consisting of + a catalog name, a schema name, a table name, the grantor of + table privileges, the grantee, the name of the privilege, and + a string indicating whether the grantee may transfer the privilege. + Valid privilege names are "SELECT", "INSERT", "UPDATE", and "DELETE". + The seventh column is either "YES", "NO", or a NULL. Drivers may + add additional columns. + + `hstmt' is a statement handle; its value is returned by the procedure. + + `catalog', `schema', and `table' are strings to be matched when + searching the system catalog. An underscore "_" indicates a + single-character wildcard; a percent sign "%" matches zero or more + characters. + +> (tables hstmt catalog schema table table-type) + + ODBC 1.0. + + Creates a result data set giving information about the tables + in the database system catalog. Such a data set may be + processed as ordinary data. The result data set has at least five + string columns, consisting of the catalog name, schema name, table + name, table type, and descriptive remarks. Drivers may add additional + columns. + + `hstmt' is a statement handle, and its value is returned by the + procedure. + + `catalog', `schema', `table', and `table-type' are strings + to be matched when searching the system catalog. `catalog' and + `schema' may be empty strings for unnamed catalogs and schemas. + In `catalog', `schema', and `table', an underscore "_" may be used + as a single-character wildcard, while a percent sign "%" may be + used to match zero or more arbitrary characters. + + The following remarks apply only to ODBC 3.0 or greater: + + `catalog' may also be the symbol 'sql-all-catalogs. In that case, + if `schema' and `table' are empty strings, the result data set consists + of valid catalog names (the other columns are NULL's). + + `schema' may also be the symbol 'sql-all-schemas. In that case, if + `catalog' and `table' are empty strings, the result data set + consists of valid schema names (the other columns are NULL's). + + `table-type' may also be the symbol 'sql-all-table-types. In that case, + if `catalog', `schema, and `table' are empty strings, the result data set + consists of valid table type names (the other columns are NULL's). + + End of ODBC 3.0-or-greater-specific remarks. + + Other factors may affect the result data set. Please consult an + ODBC reference for more details. + +> (special-columns hstmt rowid catalog schema table scope nullable) + + ODBC 1.0. + + Creates a result data set describing primary key information in a + given table. There may be up to eight ODBC-defined columns in the + resulting data set; a driver may add columns. The contents of those + columns are beyond the scope of this documentation; consult an ODBC + reference for details. + + `hstmt' is a statement handle, and its value is returned by the + procedure. `rowid' is either 'sql-best-rowid, indicating that the + result data set contains a column or columns that uniquely identify + a row in a table; or 'sql-rowver, indicating that the result data set + contains those columns that are automatically updated when a row value + is updated by a transaction. `catalog', `schema', and `table' are + strings. `scope' is either 'sql-scope-currow, indicating that the primary + key sought is for the current row, or 'sql-scope-transaction, indicating + that the primary key applies to the current transaction. `nullable' is + either 'sql-no-nulls, which excludes columns in the result data set that + may contain NULL, or 'sql-nullable, which allows such columns. + +> (statistics hstmt catalog schema table index-type accuracy) + + ODBC 1.0. + + Creates a result data set describing statistics about a table and its + indexes. There are thirteen ODBC-defined columns in the resulting data + set; a driver may add columns. The contents of those columns are beyond + the scope of this documentation; consult an ODBC reference for details. + + `hstmt' is a statement handle, and its value is returned by the + procedure. `catalog', `schema', and `table' are strings. + `index-type' is either 'sql-index-unique, indicating that only unique + indexes are to be considered, or 'sql-index-all, indicating that all + indexes are to be considered. `accuracy' is either 'sql-quick, indicating + that readily-available but perhaps stale data may be used when generating + the data set, or 'sql-ensure, indicating that only up-to-date data is used. + + Errors and Diagnostics + ---------------------- + +> (get-diag-field handle recnum field) + + ODBC 3.0. + + Returns the value of an individual field of a diagnostic header + record or status record. The type of the value depends on the field. + + `handle' may be an environment handle, connection handle, statement + handle, or descriptor handle. `recnum' is a positive integer indicating + which record contains the field. `field' is a symbol, as listed below. + + Please consult an ODBC reference for information on the significance + of individual fields. The valid values for `field' and their corresponding + return types are: + + field returns + ----- ------- + 'sql-diag-dynamic-function string + 'sql-diag-connection-name string + 'sql-diag-class-origin string + 'sql-diag-message-text string + 'sql-diag-server-name string + 'sql-diag-sqlstate string + 'sql-diag-subclass-origin string + 'sql-diag-cursor-row-count integer + 'sql-diag-dynamic-function-code integer + 'sql-diag-number integer + 'sql-diag-row-count integer + 'sql-diag-column-number 'sql-no-column-number, or + 'sql-column-number-unknown, or + integer + 'sql-diag-native integer + 'sql-diag-row-number 'sql-no-row-number, or + 'sql-row-number-unknown, or + integer + 'sql-diag-returncode 'sql-success, or + 'sql-no-data, or + 'sql-invalid-handle, or + 'sql-error, or + 'sql-need-data, or + 'sql-success-with-info + +> (get-diag-rec handle recnum) + + ODBC 3.0. + + Returns a three-element list that describes the last ODBC error, + as indicated by the exn-error, exn-with-info, or exn-no-data + exceptions. + + The first element of the list is a five-character string indicating + an SQL state. The second element of the list is an integer + indicating an error code specific to the data source. The third + element is a string describing the error. See an ODBC reference + for more information on SQL states. + + `handle' may be an environment handle, connection handle, statement + handle, or descriptor handle. `recnum' is a positive integer + indicating a status record index. + +> (sql-error henv hdbc hstmt) + + ODBC 1.0, deprecated in favor of get-diag-rec. + + Returns a three-element list that describes the last ODBC error, + as indicated by the exn-error, exn-with-info, or exn-no-data + exceptions. + + The first element of the list is a five-character string indicating + an SQL state. The second element of the list is an integer + indicating an error code specific to the data source. The third + element is a string describing the error. See an ODBC reference + for more information on SQL states. + + `henv' is an environment handle. `hdbc' is ordinarily a connection + handle, and `hstmt' is ordinarily a statement handle. For information + about `henv', pass the symbol 'sql-null-hdbc for `hdbc' and the + symbol 'sql-null-hstmt for `hstmt'. For information about `hdbc', + when it is a connection handle, pass 'sql-null-hstmt for `hstmt'. + + Utilities + --------- + +> (make-indicator) + + Creates an sql-indicator. + +> (read-indicator an-sql-indicator) + + Given an sql-indicator, returns its stored value, which is + one of 'sql-no-total, 'sql-null-data, 'sql-nts, 'sql-column-ignore, + 'sql-data-at-exec, a pair consisting of 'sql-len-data-at-exec + and an integer, or an integer. + + Please consult an ODBC reference for the significance of these + values. + +> (make-length [n]) + + Creates an sql-length. `n' is an exact integer, which defaults to 0. + +> (read-length an-sql-length) + + Given an sql-length, returns its stored value, which is + an integer. + +> (make-buffer c-type num-elts) + + Creates an sql-buffer. `c-type' is a symbol denoting a C data type + (see "C data types", below) indicating the size of buffer elements. + `num-elts' is a nonnegative exact integer indicating the number + of buffer elements. + + It is the responsibility of the programmer to make sure that + buffers bound to columns have the correct type and adequate + size for the column. If a column has the incorrect type or + is too small, unpredictable effects may occur. + +> (read-buffer sql-buffer) + + Returns the contents of an sql-buffer. For a buffer of type + 'sql-c-char or 'sql-c-wchar, a string is returned. For all other + types, a list of values of appropriate type is returned. In the + case of 'sql-c-wchar, an error occurs if the buffer contains + a character not representable as an ordinary character. + + SrPersist provides no guarantees that a buffer contains valid data. + +> (write-buffer sql-buffer vals) + + Updates the contents of an sql-buffer. The type of `vals' + depends on the C type used to create the buffer. Also, if + `vals' is a list, its length should depend on the size of + `sql-buffer'. For a type of 'sql-c-char or 'sql-c-wchar, `vals' + should be a string. For all other types, `vals' should be a a list + of values of appropriate Scheme type. If the type of `vals' is + incorrect, an error occurs. If `vals' is a string that is longer + than the number of elements in `sql-buffer', or `vals' is a list + longer than the number of elements in `sql-buffer', an error + occurs. + +> (read-row-status an-sql-row-status) + + Given an sql-row-status value, returns a list, each element of which + is one of 'sql-row-deleted, 'sql-row-error, 'sql-row-success, or + 'sql-row-updated. + +> (read-op-parms an-sql-op-parms) + + Available when compiled for ODBC 3.0 or greater. + + Given an sql-op-parms value, returns a list, each element of which + is either 'sql-param-proceed or 'sql-param-ignore. + +> (read-boxed-uint an-sql-boxed-uint) + + Given an sql-boxed-uint, returns an unsigned integer value. + + SQL data types + -------------- + + Data stored in data source have SQL data types. In contrast, + data in sql-buffer's have C data types. + + The significance of most of these types should be clear. Consult + an ODBC reference for more details. + + 'sql-char + 'sql-varchar + 'sql-longvarchar + 'sql-wchar + 'sql-wvarchar + 'sql-wlongvarchar + 'sql-date + 'sql-time + 'sql-timestamp + 'sql-decimal + 'sql-numeric + 'sql-smallint + 'sql-integer + 'sql-real + 'sql-float + 'sql-double + 'sql-bit + 'sql-tinyint + 'sql-bigint + 'sql-binary + 'sql-varbinary + 'sql-longvarbinary + 'sql-interval-year + 'sql-interval-year-to-month + 'sql-interval-hour + 'sql-interval-minute + 'sql-interval-day-to-hour + 'sql-interval-day-to-minute + 'sql-interval-day-to-second + 'sql-interval-hour-to-minute + 'sql-interval-hour-to-second + 'sql-interval-minute-to-second + + [ODBC 3.0 and greater] + 'sql-type-date + 'sql-type-time + 'sql-type-timestamp + + [ODBC 3.5 and greater] + 'sql-guid + + C data types + ------------ + + Data in sql-buffer's have C data types. In contrast, data stored in + data sources have SQL data types. + + The significance of most of these types should be clear. Consult + an ODBC reference for more details. + + 'sql-c-char + 'sql-c-wchar + 'sql-c-long + 'sql-c-short + 'sql-c-float + 'sql-c-double + 'sql-c-date + 'sql-c-time + 'sql-c-timestamp + 'sql-c-binary + 'sql-c-bit + 'sql-c-tinyint + 'sql-c-slong + 'sql-c-sshort + 'sql-c-stinyint + 'sql-c-ulong + 'sql-c-ushort + 'sql-c-utinyint + 'sql-c-bookmark + + [ODBC 3.0 or greater] + 'sql-c-numeric + 'sql-c-timestamp + 'sql-c-type-timestamp + 'sql-c-type-date + 'sql-c-type-time + 'sql-c-interval-year + 'sql-c-interval-month + 'sql-c-interval-day + 'sql-c-interval-hour + 'sql-c-interval-minute + 'sql-c-interval-second + 'sql-c-interval-year-to-month + 'sql-c-interval-day-to-hour + 'sql-c-interval-day-to-minute + 'sql-c-interval-day-to-second + 'sql-c-interval-hour-to-minute + 'sql-c-interval-hour-to-second + 'sql-c-interval-minute-to-second + 'sql-c-sbigint + 'sql-c-ubigint + 'sql-c-varbookmark + + [ODBC 3.5 or greater] + 'sql-c-guid + diff --git a/collects/srpersist/info.ss b/collects/srpersist/info.ss new file mode 100644 index 00000000..675a9f96 --- /dev/null +++ b/collects/srpersist/info.ss @@ -0,0 +1,19 @@ +;; info.ss for srpersist collection + +;; no .zo compilation necessary, since all the +;; real code is in C++ + +(lambda (request failure-thunk) + (case request + [(name) "SrPersist"] + [(compile-prefix) void] + [(compile-omit-files) + '("info.ss" + "sigs.ss" + "invoke-1.0.ss" + "invoke-2.0.ss" + "invoke-3.0.ss" + "invoke-3.5.ss" + "srpersist.ss" + "srpersistu.ss")] + [else (failure-thunk)])) diff --git a/collects/srpersist/invoke-1.0.ss b/collects/srpersist/invoke-1.0.ss new file mode 100644 index 00000000..9e5e0c7c --- /dev/null +++ b/collects/srpersist/invoke-1.0.ss @@ -0,0 +1,3 @@ +(define-values/invoke-unit/sig + srpersist:odbc-1.0^ + srpersist@) diff --git a/collects/srpersist/invoke-2.0.ss b/collects/srpersist/invoke-2.0.ss new file mode 100644 index 00000000..ebb9ce67 --- /dev/null +++ b/collects/srpersist/invoke-2.0.ss @@ -0,0 +1,3 @@ +(define-values/invoke-unit/sig + srpersist:odbc-2.0^ + srpersist@) \ No newline at end of file diff --git a/collects/srpersist/invoke-3.0.ss b/collects/srpersist/invoke-3.0.ss new file mode 100644 index 00000000..5dd02686 --- /dev/null +++ b/collects/srpersist/invoke-3.0.ss @@ -0,0 +1,3 @@ +(define-values/invoke-unit/sig + srpersist:odbc-3.0^ + srpersist@) diff --git a/collects/srpersist/invoke-3.5.ss b/collects/srpersist/invoke-3.5.ss new file mode 100644 index 00000000..b60c92d4 --- /dev/null +++ b/collects/srpersist/invoke-3.5.ss @@ -0,0 +1,4 @@ +(define-values/invoke-unit/sig + srpersist:odbc-3.5^ + srpersist@) + diff --git a/collects/srpersist/lib/win32/i386/srpmain.dll b/collects/srpersist/lib/win32/i386/srpmain.dll new file mode 100644 index 0000000000000000000000000000000000000000..9b9dc211f2067a8dc589332bd5d2d7372733c61c GIT binary patch literal 159744 zcmeEve|S{I)&Fj?gcTQdg#}ZLnChyrMok;qqM!!F5Eb!mLUyqrXr<{j{-QQ3XfcK^ zsf0_~;EUDvwSA@7*0#2_t$mAq6@ozlf3!qxi`pO9T01nfrM1$azj{(w0)Y^oTrLpUfN%P%_zgJ6Mi}- z@W@fmy?;Y+)^qQlV_*B}%EdR|^vRpAzM=A(t8cvVrnbtDf1>i{%#D@T-dH)~@}|lg zZd&w-Ge?gel~ACq+ROeCZ#-$8er}q5*1BWy`@m&Y>&D~zp4n%tJC1*!wyv4;ow)7> zd|&pdnswvwJ#cds=O4KFRL(ze^J)CucbhXS!P}~q zV8Ei}q5iHa39LS2sKmp(2cANrUNqC0ZJ$`$hLp9Js&-LZ8BZ^JC0cvt&5N#XyE+gU zI2!M%?UYB-z|B|(_Bc~!3#|A9UN1(z9qQZ7#XQt|=FOkD{-$dJfv3+x0@@a+!FQdc zl+Icg2wb55fA9M}3cN>w_bBil1>U2;dlYz&0`F1aJqo->f%hoz9tHkyDB#RUgq=Bw zkP}WeioabF3}m;2`+B@Tq(y3bQ=QM>GTv!J)>(YbA2N2EK8I-BbzO;MndoGZHv`sw}z*_akE&s;L7Z_ z+`K+#W(fbz0|?*~qe@a~l#AF{e#TlORx&NF{(B(c?9Fb8ckauKcgF8Iza*Bn=c4l5 zT^%3|(01ynB{64q$Xfn;vSpw}=jL*`?3Tzvh23G`2agE;>=0F90rDRXg0oze8(xh3Q*CnFDfbaGQOI;h-v zx%0+Q+X>DDtFil0vLWQwY=cQCyCr1hj+LcA-Rx80OEbT`a-K&@ZZP^P4|Ovg5A?A&h18TW%f@Nj&_TTyEK^$rRx%?V> z^lG&2WEwG>Md(Za+TY?l;S!NsoNA5adgg*w=+l_9mxyh3m37SyiN`U%xFk5FJJR{! zRB%{`ztG*Gt`9;oG=w|1w;knd=6^E(>RKFj2P05OkyJ^Ej0Y#=0%$w>?3%Wtow_h! zy;<7}Sal(@EVTf*gd_rkBbJa(mh6;@wi9H>w+34S_5r}KtMHNQSqr*BA`N^*%A;XZ#g!u5#gmc}@q(2_m{|9stK1oG;VM?rGC&dt025&bI9CK-+N_w;f~I zRe+9=h+2$+CR+514da z)Dd8}2`&*Wd#MQnNuVqS%niW(OL(gB%*B(%a{(UWmje0_4;IiT9s_+s_%OMJ+wC-j zlDWGSlBf$)%6!b;#4A1~WU?PG8<1)O12V~9B#>(~$?HR4+A<8dliH3~o!!(Lw4bHQ zIj762?IGt(s1V%Vw3u=Mt1TFB^RsW4w&@8FOyEiBef8mB#;dfdtT)`#CKhp04pI-+EE#AV5hF3l~Tb zP;i({(&BTzoXA)tCvizy%=hJdt7uN*oV56mFDJBzLYO>0(srdw7>OT^KW?Ma!H6&P zUjcutEXE%PsEY)XM0aMH>_NyB5+FY$W^Gt{UQ=@#vZLD$GAb=jG}(PG4G%FHO|x?2 zRJTKj5|3xM#2^+fbM|I-EWC0ahT2p4;@_2b%P=vK%#-X>!QfMA@ELPY+cCrn8a3v# zlUT58j!1*gSg>@~(P_@p+-9maYY1apu3!tFt3r z^)Xq&=2uGqo~DMB)m0x7vj<5jjXO_4e9MV}`_DHL2|5q(h$1#k2M+)tdy7w?j%jg{ zVbbF+jzl-T)xD%*`61GwqIZ5D)j^N?V$USjqayf9TH+cE5-<|fL;U!L`Qz*-jg()T zKkj(SNI7w<@#9JJ$J}j3%7FQ!{aGVr`p=9X@g2sGCBHI$eA)c*ocSZL)5un9{%A3O zbeTUMGk^Te{Bhz-2DDF@KkhYuJY)ViWd3;nD+Yiq=8u`bHBu(NYW(=F`Qzc|b&4AJ zD_piK82F^aK6`v1_Cq|I@O&N54Hbddop`Roa~qzQ@U98p_u|{ZQ;+|@hi5IGb$I>< z&o(^2!1H@Nf5USC&r!%b0nbTzYVe$k=Mp?=Jd5yr3Qs$p*YN~`C8d@87aCDE690rN zD~}pgf`5*#tc;AV#Je%k*fC>eo`2h?2XS0{{Dfo6-#78NisL7pAoWYEZd@&k^i7DF zqgZ;BLid+T2rVvIAAK;`cFcz3Fji`}x14)IAi8$5v$+qtnE6u|a7M2sof%Lq?j+V; z{>jTPUWYrQ+ejK5CjEh7$}c-?d9IY#fmm`k=X%I z3+ve$6zn>7l@+et-tpGy(YrUdbX^{zb!=7V_V&dnJsEY@oczPawtn`F52q~1+*BD%Ck>}8UVLE^B`d=x$+iF zffZf&san+eQM8igCTFamSBZDkSqaieDW-es0QF4wHX2@>c?WQhby0Gd{;} z8XA7R%5RA!l%MhW%3<;oJ_Nr}%yjYTewpYTM`2y}>2BR}K8yo#-R`JcPbWqgmGj#8 z#@o7$SMaPXVOrdtUr`#j=kdefNA*yCOMH{^b9>I{9lHHgcL%p;iCgz&n}^O%ZM>iH znd#zlC74Mv9<|2be}qpj<8!Qw&uC~+L**xYD1W2)6O?P&-=m>D4V9np*~R$$gz__e zZhvOz{KlYqKjg+V$;BzlH>zA!n!$Y!8i}qxT+lqFzMlx~^vJ;7)ITJ+bq$#IAPQrR zPD309mw4|#12IUHD#wa|6fo6PB{BY6gH6`%7a6Lqyfl;V^ws` zNmPL*F;FT-lp=}|hE81sL`ftYt=5v(k-NW6C9kKFRvbkVPD2IJjPS}Y+2|v5NoyDt zBL*(8?q1SYd=)zl2?eD(9}0e#Q_KC(N?VTtwBrfd;(}%X8t|!htZHCbQ>;;4n1%tk zf=Hwrh~bSkhFV88L5iNr%c#nA)kC(FXag{DKVBuRM+2`;%m?f0is5Cpk{|$yIJJ&i zNyzx2m9|EjtbudZ%`X6@8>Py|sjO}Y_ta<-plHYftQWIeD&>&F93_Vw&s5O&znBQb zeun2ZJU_(q=aZn9ymbxsKu+UK5?=dnXNY3sBy=^u=4+E)Ag)NRqVPq-F+l}=`oip&X; zF~Cl2w|31Gs2O7`&<7wscu>TiU;ZjN3S6MR^ytQ+>XZ1W@&N6YU%saYKb;kcd+BR+ z;(mNtNeq;7y93l~6mMc?S9G3{s3ffxs7bs@NzL6wfvnEj#KS0v7Zm{YApS+0NI9-# zO)uG63Y+j=tg4*xb1<5aSZO2%kx07o@-2_y)34C33oQx8?6p9}VJDMw479p%qm>jF zKm*QhL6`Xc)>Tmchl=DMTQooWrqzIocvUw8n&;zc9!x}E#E@9 zq_;}_kH!)+qCFAIo;F~*StlI4~4Z71^A>I?E|2@C7yVJI+|$!E`WiIXh5y!hUR*h zW5zGi7|a3&B{F{!7=%$kVnCI;oK^u$E1=sDIFQ_jg4qkd1`0`WK2SKKURd^T=!K*t zpZyrB)@#_X*GIYY&J4sh<9P|3^o=tDu^IUOA-*@_*@FK`28T@7;Qz({Bg%N3NcjfK zz+lUgT3V*P$XwpN0bd)|f`j@ttmMx&{uD>kn??NpEdFE{o|C&5`M-*1HJ)$dc>vE{ zcpk<>?J4`e{tJ!Z_V9dR`m4zQUEn|I1?u+vh;OA!gEq;gjEyi{a;hc%LYh6ZZfn@t zo4bpgt}V`J@|eRa(9*>o_0D}=R;cZg?4e*rLbXIQ%E9`&pf7uwAgmecoJ3}w5Dd;0>zVriO9;Q>9g;XABpYzYsqr$ zF5u6zE60OgTf=E_e3f#^L_5DgqxS7!yIyT?iF>1kj4|=X)89ntf@oT_^FI8en)f;@$T0T9qcw|BedH7uRV*1jRAUGUA?|HcE*ZkK4kZ|n z*JUYMk;RkF1tF`oR6Gh0s-|C~rXtKo@gXkr5vC33gl37U+X;0Zmbw!%qruPK>)}|C z8(6~)eBorbffyQI1H&y-d3gF1}@HcC3!&ys*JM`B2hM9QMH zoC0~rolB-J)1S`mpD~oY+qE5yr&LQE+*gzl-R>=vce30kP|lTi^orzNhkiL+lMQ*t z?crE6Q;1Xj=uj4V>_xO7Q0ytxAa`)Vpdo(yPeKEB;*4T%@*_@j^STnLJ}d_=F$??O zw0}F@T4L9@`CVqIk9Y&!=Q&TemP*gLAD0Of`-UZ-b6d!PkO+P98$}4ck_g8o z{Djsa1R8dUoFsg(K^Kr%JArw|MMsxPCot#qIwR(FhUz>GIV3wT4{}`QC(*~9=kmq~ z*>`@F$2jd_IAD??=f;rXZcf-cSHRs28%A~iL2(V)?Ud75$2ZJJ^W7*kClz6?Ctop( zQmFp4o^#+TPQ@`)TAZa}Oazdyu#S-GorrGg%l0114&Jn+l@zhqRJNCg@r6ZQWp;36 z+e9TFt=5sPBPFHpqBTesw#oW(OMKz)x>ra5C^G{Bbjob6YdkWR_YV$~)b_&uP7AO^ z5=AN+Evn0EN;fCPFW?&HN-XjEKRn(H6K_KJF?&vMCUBNUagEHPlS=q?<`}2U5=+e_ zIfxaLvTZ3&yoXNpXBBF)2FX_L1@(_|hwh?^pHfBgS|69)woH_m*-VNtENi zwDVY^65q~9Z%~`kKAnP2$>g?8QRJi{gzo>VW_LNFkvAwgo%6avXeLQ}pAbS$C4~G? zZwkv1AIUx$Zav-}>C|Ay%o!%zD?SHcq$O$;KT?1MDT^A# zhJw`L6ey#u5*hmegFjUqCNJWQoIRgCFA)3fxrp zg|fL&`!mi2XLi`RDByf7gxMGqFJ?~QfZ%fYqi+kfIE`VL{41RHSPK%%TM(EGvC!h& z5l%N^Qmdqosz#dD5=pDMNszD9rm8G4VUL>6;4&v=i`K-fY)#+{jpFVBDevfg3BQA~ zg{kbj?)zcqG3kmgkk3Qw=SNIFwPH>khJ2+4`JjVd3$lQ2DN;j;PA$+m;?5;ZLn2do zvauPHz6ikmY*#Xg-uSaYB4Y+CQ|X_U>2e06BA5}Njjq zLYigmKIeDLDT>o*&DB;R37u|E*?Ym$_Iz_1s3%@I6l~w_Tpn_cr6yhwh86yNcL%UsJ!Cg(@Gcji*td>T~u$|42X}o0jG*Fk%p(V^5 za|z?K4^SW^+XrGaWHjeXdxD;*v<|FHDx6c#-c5*;(Yk40xHV)?K`3OCj7}INnUl*% zt+dHLK!TvBg9H%5O2E1x$ps+!cYTJlV87b=`5XzMQDoHP7hk+K$>?w_w-pS%+L~7^0d2LN3 z7vrkJNvII-Nr`M=Lk;1PiCW^rW`cyS3{^v^kPVW*mhXuHQ$*oElBmQ#tZv}j>={$t z@D`T=U(e8*XZh=dT(QL^=hf;4C>eLg5J6$-VT(^CXidK-xgRzCgEncKMDMTu6!azt zmbl|jxm*i|<3u9#;Qx?mwRZc4Ut`_TGBwsVI@=qbe(r(JU~JjmfsszdbF?6VG{vNr z`lFtcfuOU7yNILG$q%N&-4T9HeWPSA^-ZIUT-WnAwiiwCIu3vk0yWBkiF_|9D0ylgI*DOYVjiK$D5ljU2e%lfjp5>CpDv&2X86D6K$ zIcFDV0S$*nrT6y^(1Ag{{_<8lwgVHL385aJpG;$lcHHBO6f?iq`rKketpFH zGUF@lA!FpeE(k~3*TwV58K@n$6QSlJm8>z;jLaA~-eHytiqBIjhtqLOEOF&)n&^HL31M%E-~B;} z4;JP0PMS#m<-Q+oRw5IL?+@|=S|5pz3Vf6Jpl?%r6cC;TJ2^^B!7fRFzH$w)r=Zb3 z>p9!1jzy<&SuIY;lEmawWm#GkDGM#7uKmxq@L3z@7mlzsk0OjcC>i<5Erhd!rPDu{tdUVidtOZ_BtdG;!8`hyu{={^G!uk zYR>pc(J7S(UP(8JM}LfwL@l+%O6(5xW*91wH_MPyc0!U|##(}S`yk0+5qGB-<-j*L zN&;To+et~TM_|aS2cCcC()@F*!sM%Prh_I67eEG~n|TT%95Z9Fp3h4gUME*TeEejL zXJboP@hRxnc|7Fm(4MtYMKN+tckp847)3^63_;bi8k3^w5zw0QSfWC<0&>F~Kw~%+ zbI~qy08t4HAlN1T+kHQr;L0CB1@hKiKA84tUOv1?%{3Z9QN{oDBVbMmmiV~DAz$87 zVp9C^cZ|4{xAaQN+e7;GaA>>3{vF`^Y!Q6l{2}nA1n`TjJ0D+4g#AY&M#~F&CGnlD zUmr2PN`HpR>EGYwk3Vkxsz%`n+;gtCVktq)mEhK^ZHOKutRQvsSQv1A$egd7rw{e#fPDAJ+D zX@VU-DH?u&E+d$h$o+=72*pQ|k<(o)l&SPPWV%Wz;kQ^UVA*rGkuv-o!#nGxSSaAP zq1T6x72&rv2(z&%!4em^$Q!FQ1ky9VJ^5>6e9$Y&Z@<;AkC@*I@a5?*-#*Gy;KN1m z{nPh>FC}39k#*;f4@yjm@ftB2AM{G%d!~NRJ@-OFF+!|lIp@6;72=Fm>h~BN<0~JlNqzN6WnM| zcE=!6E3sJPH}LmC*N4r&`E=P?@A5{yLUZ z;-5epohapQ%3kCnB&^VPgq@?i(+45zvTuc>cYX)9Xq>T7lV%%qj25D?R$hL7@*z-~ zP_je-q=dChse_~&7PCI%@D9K6xtxn9#nn4iPnfo6f}9zb6m9v5LtBP;3CN~x!je$M z8WEj9i{(eZ<6_$gh*H$D9lD&25tVs{S2Admf+umb#N)rp#}Rf{iK8WUPF z(S#p$`XHBuUorMsnA%fnAMpI2@;+cPwdbNMR$$(ii+0H|H~uo8oLIDLbeHERN_5qt zy{La$lT#ARo=jZrTiu7Wk5K3QNpm3f@i~E588}-%>6G{XXr!A8`0_m=uoByYNW-TE z9l4=Q_merk+5N=hyT>OCXBLcac0RG{#5vvZy~G^f5&J<9Hzg9Fzh4%n?8nR@OsbPJ zFYH9SKf_}a7aqSsEz%L6u)B~W;uyf7 z@zAPrfA>YN1BozwfQaDfq)2%XcO%cx984B|Il^T9^YS4Q2U8N+ac;~{JR%PEA@=w; z-KJWEn8CUuY};hrbw4p#_gKP{?M)KTAH9&*aJR;Wh;W^&J^Fcs!26>&D z63+lDgem(+lSHX9zg82a+WbV>CBvD(7$+Xtc8|+ovM8Af)iDDYO`Ormb<7RK-ggDg z$HDhzd^dy3$R`A+P^bhRA&eiyK#@HphHujj!Yhu1vpNx>1Zlmdt?azE>!8u&j)^ju z0?H_;JOVw-#u-77?c&d0N5@h=>{ojp1Y-!&sWwI$ntigpEk#^6L6!I;Jc5|8ux=;x zc->B*GRIirEq~H*GF^jELgSt2OKsFhS6?EN@$4OhRxy(?=QV6RQoR^D9*Oh21ROpd z$&U-gBQ-hg5pt!ec%<2(?AA~-TxsMFN;fw5@3)do;<^XW2~^e+|6tr<-ze>sdgLEfUqMbj&)MAO%1vzx(303*Wyvo0T%tqx^ zo^G_8oHe@SG|%&XyjQrQw*mmrtJc8} zVY?1|=LSDK{jeGQ@O8jK4@EmajT2^eH{(M?u2hi!{9kUvPaw#9F%c!G(XNrCfp}NB z2^q{Sx+a%i;6 z7235P+BPz~#K=2&OU2+L%EB4NLC0&AhND^bnP-N?WyMj*D;sA5YgZD<{ZQ6Z1J~bMeFcUpAE+;hhN;JG9$-WFUP`wOO)=}dG$sEa#JUt{?I?Iq3 z{_lbu8k5P2AU$7k3GyT|7h>{x6O$Shn*RpLNaEP#_(zGcQ--Wdw>sg~bw$y-R-1L{ zR^KV>aw)!X`%tZ>(4ZX!sVS*B-9OYu4TJw1)hH39W$B54i|d$eS6VbL2*mz+WgzxE zzAs)FhzUFqJo~RgsOQyz*w~K;V)x+*V}`f@?;gc>AQ&krjf5ij8$loVD~pT_A2lj+ zw7I;&d>V%WBSaKpmDbL2&x`I=-h7xu&@%!1B~@PGdGcKc867p(`AQoO zU?X`WY1|76;I(90ViP(-jnjzxpD##d?!}o1hv$9<OPWzdDE0 z|NKxFy78chvWeOa?G$D6$uFZh0#?4xzvu(Un(T*+$r0ke#mUhAk_s$z%IS34PkbB9 z2eaG_VMu1^g9nd^-g!290D<1!_Vpa-JqKUt)Uhanz!8k8)<7~v-pv{;j(&G9Mhf9( ziH|+Wy$D*Jz>8m2V&MBwu20pwtO^bWu@j0!AdKi#INJF`n(<&z*a{gJcv(b~hs)1Uicy8t2Lr9K$r%(Mco6SEp7M<|5WnI)w zpQyLx+eWrBVyOG|kZLsv-g@*cVCC_gpViwajIIk6IalW0m%b`7tl} z1dtF#?2A2dqv)*e(AWqa?M2~`dLVL?|Bw+UZ7SeIR)5AO#X-xr5Z&2uMJW_;GCePi zc|k2yijRB+#GQ=sPf{O1Ogp!XJr-uv63?lNshdm?ue> z+`a~VN?2K93OI>|pLS`K+Lf5NU6)4JI@2!vC#n?kdYmf!pO32^K@}vK31nuBC4OYQ zm-rplk>TN|TrQ`1_}vRoz;75o8={rrXH$Xcj7Cx%ddxr$(o`as6cY^O4ktbU&SVb! zzkJU>!Mf}Z31MEN0Z-rNa>4Y6@Bn6i$ReMy(>;62^>-qt@^^AhmsNbBBoJgQ8?5v@!G}uzJrWfCqGtvuE)l)AY)@%m6A{KIajyQYS4?16o zu5ds$Qm)Gt7T5fb?waLWh@`Ar6N2RTxFtVPY1PuVr4}Xb1P-ebLjbmk2u>@+R2{(K zw(4MMIQ5**68dgE*f+`JgE4VdQd&~H0LL9G`x+YQ`i##BY8GT5*#DlNQBu!`p)!=Y zJM=V6I&zn*CZsxg{YWJwAc++d8uvfsSLR|hiQzaa2}n|0l%G$F1YV5r@>+=mcWTr) z`5Aoq9@<^j1b;p)MzHOy6jNIb{-qNs59`pM>tpc4IrKTF%i!0!4!n5{t z&F8_GzTo_3dzX*L$2lt!lYyFZdAP+{LVH}YgQeK1k$`cP;3WP?a9(~LjK}7?bDay- zK4uC_;8p!3)p@O@2p8aGy}ubv*damDPZa};?7>$EoKplGxgmHFHc644!LcL9-_{Fh z3o9_J98d>wH`@m%Hk~)URUWrTXY%SPjKd24^q^ zSZe7QdU19^)wDjN_GhYqXSt*~R&;KOj~0}$b_=KrkcVT*$BUCPEYR`!RW7n0MhQ|~ zB|Ef^v8UXF5eYCWUQ=@7cdBsAo-s*DObtPb}nw6M> z0noAkis*{JVO(_Vzcso7T#SEaw=M42e`DKql7#5XnxwtdWJraj0sJc-@PKSoXK%D~ z6eM`wVra6lx-mK%{4ha@z$>K)bZG`gJz2>>qMe*<8pYW^E}*XJ|7hougX*waEeNL- zWJZN5`k55{ceMb^e0SUvO?gL5YyL;FCQ{E1}PBL5qzJ0I#sk#3Fl1T094vFE<`%=1908*!yTS z;`r9t_ZAW&h-D$hvn!5uV&hMwXOOx4)&p?x%)^J`VH{G-Bkk9pa~pg=s<+gBZD>h+&iVNMqwbZ&*ZGXaN2V-}|4 z_UtT&InBTqhIl175%z8#;(N2`RjS<*m%$k-m7(Lna0w=+H`kJs0QFgA_<+{~T-Kal zzxjQ)k7f1}&I0K@0|(SH(|8lTB_8x=x1^69S`fG|p+?Fq565rG><~j|0bT;%GB};Y zcSkRYZ>m&QQ_ob@LiHfhN-OgvJ81`p=&xbd+o-ubiXj-tu&-@vnXJlr%@VH$v z`*I2I=l<-z8YRH*`g3q;d7v)ZUWtB6sF648vu+=K3uVwb)oSz|ZQsAtKmV`M^FPVE zk3hem@i#%j7DxMQq`^ldh;|-=RKb20e{vocPc3(`IEk=;SG`r%pKNw^iaSs+s$cPdbu$fk>Xm6hFAbZO<4&Q%?#zeUpMSxcsTt z5n>Dg*+Zo*UB@mtJ(u`#2c*%~nP5>^56;9t;6a4>;~z94Fi?Sipuq+P)b5kXhNz>! ziUa}yE)Qo$$-oKC4U*H-;{D(85!dbgW76Uy{v^o`YK2~OF)Zbt>K|TbwN6NjpR~Iz zk4uP3vc{BT{i2uQ4f0qq+qDwM=#vlW@-iSUgA2-`qo7$aIc?ry4%;~>uCym^ry91@ zi`V*-3MWh+IVh!#eX=pKpPK9t5!DwI>^r$U($_QocFdFXv|~QJBM_UjJP^C=v$*G^ zBM|#8o{8v0zWI+Y{lnFMq40=s8C~%=vgaY>U5{rYo*(0plP3;4%(I^spFA6&!+2Kh z!`V+cr#pH2?5CscDj2R(B6oZKV8~a(cxRNo!W5Km8~K`dSAi_L zx!?bc+uSm0u3<5jZFVijX~(n}mlBQHVk~KOtx*G6jOi^|jF%hll>j%i!a^o@`(c8I z*bNc}FJZ9Im$dM75vHCrh-jxSSMRAnmU#Lb2BENmVf0Q!Yt<=3-s}Z^!N@z@7Avk> z-dA^o`-!IbM#tey#+=g~9qqUX0V7szKU4>?iCwql50A9H%N!o&exmKSqOS?6B__%? zcJ}7)C!*v=@t^Q0vEYK%h-3D+FKMgQkKFgF6J%fd1d+Qq^{ng#`{h`09`fWLd!-V^PfAkK{+9;lXfE&Wipu(AP zR3IX4Wq(wO!?wk1iCk5vc67q(X&O2Ef3y2mO8r?n zHbii;Kr-DZF1ZB_r+k*k%BJNtd;+Ip|D&(rR6_3ZJKlXiEGNrde(zvB9vC&mc>Hn( zSW~Jco`WwDtWO6zc5Yv=>~^4kjN~tfRTW&r!&AC9xD z2xK{1<&kiQcJI-R&T2cgT|?tWpZvlIoFt1g1~S=;GWq8Hd041>av6$_Z?VL~D%-H6 zHdw5H-t0}xmw)V0dJbA|G~C{G3M)*%|Xo{BLD3v+G?!3xpca4@@{jutDA-Z=+zJua=XzktY0 z)^XwyIDPi3sGL4Tc(dH=2(?ING#z zBpjK%#}9{a{Pwe8-<{Zwlzls=W7*PnhmSB&J6aJ?YKd>%OwAnlm~10eNjC$zer%jG zS|X)gUPtmVr#Ofr3CuqsVN6hBY8Gm$&1nH2=H5(;rC()s?Chn}*^JH5V>mr22EW4T zax*klhEQ}IQgMtdwxDk~8Hg>xxlP@H*q8DA>GR$L51spaJ^rT|FUbci@Qrf*Gjn}j zaXMgud03Fl(Ci3_m%j@brx+-&IOlYy1bv)Wgt%7j5^NHOK1Br2`i}G30H$~81c!K3bK)Bb75?f${p<bb#T|q*yjb498ravgc5v zSd)S*1e;fYk;~JK*1)wAJAEv$%Un|&Y65qf+X=TYCyUYlaUV_d>z zM}u#@H{6Jc(_O6ibjLL+IY84Lg-%h8(`AkS1tXhmq@H|WpHMOc z*Az&R@=}OSq$fJR)XMbvs0oYEqK!>_QKx}c z1lN=nMJvK+eV#y>+f->+5~~X)Z`Zj@;=>2>i8<|JiO)CDIW8KRJ^DLh7djhem@%$a{zlHB3*;B;+L)`gNP7_n5@74g{HX^$Eg(dWAQ$q7y0sHSF zVi>ZS?i}H5M4Z>9auL}~IeCobL5(zu^@UKCtn@>jjah4nn^$W%O*k{vL&0M{byWZj zAm7yjO|2v3qSlW{eYxDXO-%VU;w7aFHQ~tpcnkx?k4t@px6NB!Bf(-Q)r4a=SVVJv z7oB#s{e+L*(snQLNid+=exj_V_5tv$7S))1ZV0tx4<6NZeIkxSx3ULE@u6D@jH1B6 zqJ8z1!Hk~!n)D3|{${mT8um8avw^K0X|b5<#abawL4Q(wrtK|Mv0g**d0&un2?v+@ z+*rZKZ8-~LKqvbBg%Rft$SmB75y8qT=Cqdsy~=Jp*{yW8Gp?10$qSkL-|FAb2RQSM z1XG&&2NCFv5jPFz`nEt#Ayh3fhr5(!t5Nc(E*b@-r;7+e>->!GY1vT-Yb)M$q1h+P^?p;ShRQqHYa2vt!xKA*V6K*QBJIoA_LL$R?{% zJaRR}65)gMrMPhDE7Vna3aYw9jQr|bL;Ma9R%n3>lG2M$Ivl8bJ6-dk<@HITWRtTRzfgS zOrTKa?xhED2uT)aQQvv3TngP2{yHy(UVDI+LNr|T62{c-mHo_z5^_s24ZY-l*uXZXsuSk=FskeIb&*@LE~%|MT?GX-imhhJPPYh55~m3Giev93EQb5ZwFz|}xc@B>v+ zw}XHh))WHT*d*c-D4lr#V`>dA6F-pGj>RZyd+mVJdot#l-M_$sK+>3P7Vh{0n`=uY z6WUz5$<|=qCH`{()366XWdACs0R^AHL+z*J0n(Zb3^>*o_sEA^1325Cx@49FH$5L5 z1(y_nv!jOr7b0*6uVn20fj;+P$J%W^cC6tZ7Q63BaO+KQB+@Bv!oSi$#G{Lxo&_Mk z%0XxjsA-+hB+39yh2C7#1qK4cL&8C+nTpFD^|>6C1{2YF&6sG>z&3!nW8L7v0|m1X{DM~!f$c(DKx1s8!5x7Q4F}} z(EWi}W*zLWcw%1*#FniO#Gb+PTl{|pzUM*`3>Ba84(IE~AYI-0`mpv`&go9uK6|VT z$bdF7pIAjIUvj=_vRA(!6(}P~xWFDuHXmneR+L6pOa{MZ1tK#xgEbmFRct;0m^RtZ zNWPYXzMcnt9SwRJk^oif1J{8O;3bV^4;hlAn(%NZZEWxWqm-wty>LVUZVH8fg|Sg3 zM&rC}X>A_06~Do&0o*XK5?NB>??3RR5yIGJBz*w(9Axn(IVc!Q;sm^ofYTi}xM^`F zZaTEobvHE0%#2~3nZUZJ1vWwGA{BgXkXYqbQwEf(2WHt-T>Z`NdqS<6QLC}zoR;#Z zF>1=yXYcVzge5q;6c@zX_oBfHyt)(;&*R;?7WcP3g9oG58&sD?o^Zh12ZzQ60!mcZt55*UdN$AkG8+;s&` zb%IqE-Kh8n+~u-R%HyeW%2q8tg0qe#>4~SR25Rgoz)Oiq?t72jHQ($dj&^5~C2{*T zykNc&-_y_(mz-|zWH$V{PH1!a<^h7D`33@=_=a|s#h6?8BnbMCZ7bCX`oq0gI3hJ* z6FDq#2=2K&mWe5rIhM0DiqFU_vbQO*gcHCrxHIYV{zS>l!z^MjlNs>>WN##MV>3ix zIrpC0q-n0ln_TI4ugNW`wB(o1gq)FH@W6>}#%&pri6LR_7ttX$7x$QFD=w2NX@A1G zkWBK@#~``JUqEw>b0Mw4Wj-|t0<(|-S}&fQadO*bxjY#9VxHD7>|PwUdzmlFaHO-O z`>~rI!<+2(9IRyVe|+y>{TGAHVgsjYxv&MY1~g$OPsg39%u7_ihEDn zUM(!vAYRdWoYy49wPsg7xTLx{MO<4&Tw6o)^rA+vD|MVDE^l{dX{@(Pz0DpIoTE8Q zQapP*XVFO|{2J@+agE|tGpS&HmIS9+n$Jj8=D!~AI0fIOc;;~myhomoQ&??sC)p9q zi(EK>z+g?DeR6|*Gs*8)3_dvnkCzpcAHRQt-nht$nIUvl4$ z{2w*xux69CrzF5!tVEL4goH;KUjb9}{+LD$1`83MlE_#c5RRh!4u?(g;U7hyeDo$RY66#zZuC3Bn`uu{@s>VeSh}zmW#O==A7YE+{3HGu5cOdrA2JB;dG!Q!h zBlLfBzjGys?@IZ1a=$Yd)N7&tv-_QIst4y$Rk$zoW+i6|?{}sQjpE0j;tYK6GtRCg zuHyThpL5?ADwmS>q+;^E5qZCJc2Ag>1PBgBz__VbnhRE55?B<-6(bsIQgC?82Nn}5 zB;}7wrPVUT%jybw+CKqKj;M=!D@e?i(??bRAZ^}TauHfj&~g458bQ~{(kb6ZevK@G z5ToQzV);i7(Ze2*tGr*R!8?3b3z)oXWN|yAx&T%mXk%t5a*Zs2;&#|(+T}A|HE9GB z34$Ga<*{1=JAJ6B88r4dUy8*3u)BR2f~!KlLw`cR*L_Azhv%(V&Qs25szlxnwvl$v z5{jsqG{c*Cr4=Y`KT9K9TYOD@MDN^>^_;7BZKSLV>P-9yEc z`z>7imw_|))rZa41Z6MxBXwg49`6tgEfo&!Hj9z|Ux@`DqApv5Y0-57I7%L~@cNDF zSen*|d)hgb0$9ezY^5~_9W1L(OTe*+R&EV#GN*U2@O0IOErfog#V-jcp<#(N z07_j=zH;p9(!O%6K#-ggV`Z{Vz(K{--7bqexesg%#LTAwzv;PIeQSn* z{hcG-3Pv)8QYzb{=TF~zlwTq)&^O)>;NE(7$w*h;E5f*UwsT1>2WDoUgiE}v{b`&| zHUan9I}744DLSoeeuVv}60Qw0ELPAB?$h!1;xLRc<?{J`WR%L&Xc@tK49Qg8M>unZ$>sg6<2=)&X%!zpwIW|y(T<)L~_<#FJ!pU0!vUxCY3iJrhTc8|Jpc2pDdIJoG zIqgk^V8@=Aw7BJ5P=< z0NKN?Wf@D-mVAkI9QGE+eI6uCNmQ0YNFu6SR8Ipv37jSRxT`Rm6@)6v^b2LWlsNQC zhAPh2uZJ5SO5!AmKt9v6J3tEdU#~q<0;!-lcXHx_egcII0^t&=B*pB;Kp>inAdNsY zq79rD6_~%+u}XBqxvMk>aX4=!oADbtZY~LDrFiok5Ra;|#OGR=l_c@7@tO58_ zghO)r9~N=CW6BV|Z0|(DCUGy7LO@EKt~z4r)nv!0kf((sa-Ei6X&kZAjD1&0QI9g*Aly{T z4JIwte`hpqrUP*r#icUcoigbylp~xdakY^$EcdGE@tx>L*Hh=b8~Mlub+2m5zbpBe z_$cT^;4HEJ<3sVUOg~AcOa7%-l7FY^*GI^|8^ST1>i-SYOFo}Cevr?HzRgLcxVx@x zxW%1&q&4T%q{S{jySGfaa;AO3vtF|+=Y#exq@~44MgkNz&w6dSyoOnrCTmPY7qE|k zR`<#uga5GDUz?!A0ks87Jo{n%AXF@I(bZVFOEa6A?(7@lji6GAV4n&X-wjKyS$4-?-ktnQ0?I`k9f{1r412Ib$ z3F}uoia5W^OL|9i>Rkk>T8u8`K+txKl`dBUBeG*eH}&BpXo{=P4&Jn+ z1sC6}w04l=pt}KI*@NM>iE@Zzvjs&vwsF0{3{Aqu0bJnpgZa8&J(`S^n*sbZsW0yz zq!sW$7-Xmd1cWQbX<;2gbU#+rDqM%-{4wMZ+E1${4)9S@CfT2p;e%L2(*Pk|2Mcm2 z(-e(?aau*nOa-r{IRr~Cps{vFsQ1(lVOSDImiXS4O6YmJlynFdwyq!#=T96?25KO%{r>A`f!OSy!{!tS@}K^ezy2Mc3a|o2zXFhJ?@WJ~OH-7d zX}tBY=V5e%7dfXlO0X9F$HxlUp;W3Gey|YFp6xAUFXr3mzgFY%tjp^wPBnO)PgiTl zNq6XVimKk$pUb`)%*^13m-7_J?zv&OHF{W)xST+`>IW~wn(Vm*QXA%+X5Q*Ha2o=0 z6C98$kA(rt<6JJ}v>9_Pp#~bEQnBd7+7?TWT+d{TTRFmY%tg5YpBS{<`PK5@leKW_ z6Su2V2wyXXA}KPMN}!NWmp47)+~Tvqu2ioja!k@ zLknbJqt=&~$g3JUpI`P-wx~za-5(2fPyXUSnF0u%srym7XvIC)#>(NI#c=kop-VHb zz%)#2Z<&|1{O-_?Y3y6_SVvMy_qEeO(BZVR?erbav{Bg510VJ5u3Hae{;rQDpy0Cz zO+b-U+Bvv!%Hm+`^xw2N^(8H!Tn6k$2R6>i;2w%ptaf|n^X+GL&v-mg`W6;S<<5Cd)pTsVcFv#rw6p9B z2fA(#I7<(7Eh|5;>@{{KTn}~Nsq*EA4%`A*8=cYjO)ZIS48e5Ved`tf8+dC00`NGH z1AQso8BD#N9%eT?a2mL_=RuO3(jB_DswCF3{$7}Tb8GlD7q)lt>u=NRyXbYx`W5(J z!gvvBJ{Vg#^B41BJi@QPYQR|Q!gw$r#(kWb)HfdgL*9T)7zozYY8U|U(C5);(7}+g#E$eA#y&aEAvOE%G=h7>#A8)9Ob3L4inFFt6r~1mt4t2|+wa7<3n^#o!rLU;$N4F@- zQE%pzll|u_C;QGUM?IKVPWG8sP9i3|%q&VBmsgZJE4Rig3dCd|ndPXb^2*7+@s*=4 z%H3s_quw#gNxZxcfuJM#M&=WFY7{Kb>7*UONbP?3G5BBHqci1oW|+2OTSv?QRE*2O z#t6o|llmw3Atn;K1cIl6xVj_>noF){5546+g*>ArhqDu&p>GL#J^KKiDx4ITzQrny zmCiLwhtD9qI-kQ!S+EOHjtJC5)-)`^uTja=Af#A!OBJLe%}?VAr>^?Fr8|}%x(`@& z@r&qcDAYO0Vj+849x*V-UPZ4=;)iUTUKvCT*;Zk>MTO-$+;Z71H8h#&%@;&pBJ0)> zBx;#%b4YgA|5G;3%JGqEP$dT?AzK4Qs1_?iwekCXRI9{shiPHqrAf7_A*qJpOc*Ju z(G<|dFQTil&~mA^7FkRd0@d0ITmJy%@=>j)u-vl3at$ukbT8dsSZ;1!IpX4wy|kd{ zEP7+gkdQq&uPDmZ6qLKZu-v_bg`Y7N7nG~cD<|=)qqqK|^WCBt0(rav_ULhk9~6mD zD%n_c?77|{^Z1sJ$=afQJM4{*bkqMgH9uAkEe*73gt|_ zDzhK%3dY3#Q@mFr`5-s(y75Y0b|zlHD>PD|vFR?q8SgFDUcA#fKM8KvPsoW&U{eJ(Q+zhcRoxtzF}=9IQXJSD=AlPU4T19x*1A~73)rSUMyf|}mhnU?3(+b73ko{r zWci`1p#OKxIOo8!7apfIz^1u0k1Pz;?(2M|9lM}pc_;F)AH-#)Nx zXLf7(@?4m-^(~C}rWpS3wy)5DPIaQ(1}FXlJ*O-DeQ;i4IQJ8rC+%1bMA3;jVcHTi zW~$XB$+@<%wuL0Sl0?-t+%sWrv#)!4@?Sx|(Vk@Goo)>p@oQX=(o<>dXF*&^Z7*#E zIeov=@B9l3oXF^JBIvur*A3Kq7x)(Ly8Ykc zJH@mIq+EM|GzLUBm04~KtTqUgT$*`V8U&cWOwy?vn7$YB3O|L-s420qL7R}YIfZGf z%r&9@LoHpkYNXx~1}9DZDS^oJEtt1ZGet4_o>Ls(+TIpu(`>;2#(5+L#ybh)!{VEp z`G11%G!tLf-tv+*w;;svHx-H8nz%GRX&S@m@=IlOkwZz2CsuH1R83vZ^rpC}5H@zf z*z%hT!Y^HMKoPVqJoU3o%|B>T%JN0*K~qiqeyRK4nE+!~nO_y6r|d&T z@e2dL-&`?xc>K73ND0Ko)@J8HYC-q(9IlL8{Tlv7LV0(*w{%-mT`Jw(mMkGNbaZ2V zuJ(BtyiwIOIx(@~*XPpa+)m(!4V)%U3N=(_OIg_82!$vP+TE3pPY9ksj1GB{H6LFWY8ojhkOo9 zT}cQ>SJ))BQ69@_RpYEG#PFZ zEl@vT2-LKAl+($Dt))U6WzbS#Umx%JoO+Ub07nBQD;G(q`?~PP4KO7+Pp*pL;`^u1 zc>x#SZ^y;=7GHc%zsF>I`QrQSzKieMF5URZyDFzz!C1J{0;Wfe=qc_7y@=TkY(?Ef zYuu?@aax-+=e8}42lbb?4g z@sbN>XWjt&NZ!hB9Y;|nJ;Yg4p9cHH(BZfg^+5#Clj`Cwp1_lu88JR1X@^C=8lRmg zO&r-BuWL$SY=*k$2BVu&2jplV;aq=+N2f)hEmA<&J`awGw>WZ_3fPdOwlkhq)oMId zc;l(mH=fdJJY~03WdB-rsWX_l3)2Ro$NO;m4}Hl2#Q3tlGnIu&bOmhpglD)35|hVH z+-VMx0|02jdO~$4F>Wr2KsR8P-@A_S;j<0m`7G~@rbK5DqpHS9R^*MS6fVK~*mUaP zDudmxI^AG*!~t^#IUXdRR8a=aCr!e3GbmQvYYr&zMZEt|f3E-SmafGITDq2ERxNjK z2xoiCh`3Au)%MP@ENSLl=}iek_a~oOm)D=1yY~4OSnA!*qNC<&x3@U6523o4if>b9 z7YJUSmCeD)A`!@tyQ9RiEF# z3MHIfQKWw<@o@e7^!fSy8?N^C@3%OE*}psd{kzi5p!)Y-N_R!gzpH<7L!mide=o;D z!r8I;_aPdwqy85o)@1^kkt_0sZSWz0^Rkq{in?2rV6DRR1YMw96b zzo%h%C7ff_=o*P4Jh8Ga1VOMyGE8;$uQ3RMXy-@4=FBt|QW#Wt{Eqks&GHrIeA+7K z({h?myFbN;Bg^Tu8o6+_9wCx9ozg32j48#YQc8tXnc)cERO(KnoIWRE6`4leX3s#g z=R3*jJgMT0SHNwMW)8qlRvJeTq#%)n*NfIsp6r$e47F;fVVWLmda6znmBq$s#Je$X zs($edgY%ljUpd{Js_&%?da7;`&lwq{?3zy*wCp0;g!>$gOx$I5r3r;5w?>h5GpRwa zi$;+<2(URIDHghU^o)8xWio23LNv(n?D>`V1KQWSP=E_gK~M{6^h{+EGf2T=s?N<% zd4WEripu`MmackfUB}ebH9O2ND7gZ1_hA3q^t&Ch_eRLxNysZX+qnb>GsS2=Ra#r; z*WDQvq4@k~^5ex)8|~bVz6nHE|Ct6TS@ipxnlVJDlg3+8#_TxzEj3p3IHB=}QY>xj z519k4GH-T8t|~bKatr{hwWZa;`~j?`c>of0ELzbnskMtSOs5r zS>|`^$cPR0(lXP5t6oWR5KZ5H1tQbvM70St28wSSqm&fi>S*U=j8nX1J1`Q6Bv32# z_@r16SKsXg432#$hu@fDM4(>)Ace9BApfz0B#`NYI@ayzBjMtvqHrX_M&3?2`!Nk=`?t>t{hJm3kzO z5Z3D%Qnq+4(|rM!chuF<)sGTTFjRNsN&FXRI(=I+t@El^5%)wlT@<3rwFog(hV{iQ z=fO%x; zDPZ-qG8FSp$%1+RQb7=)9b@~8!Ms?vZH6T6L+}DQav-<^=!8J;KjCc%I>&&z5!wwD zr>%s8pa&L!ECG<8+&nse;LRfWw;A~X1INj;tCHmh%Fi9HzLf>#wRTMY&e2Pa@6Wwf_l7+;gBUB{O^n= z|JmWn15Sh}!EoZOA%as$a5f$wN+i_WK@7m{A@7@pM|2>1xOhYidbD$SKRwVM^3xS7 zPwjE>Fx&GHh9lbpdXiI5m#2EEez%-i|Dm@Df3tomU8T(shr@KwIF6JUHcBrIVZ_2J zjZp)m{>h}|!z3L)v(XNnMG?QxjG_rEQlH&gGWCsRf22OYvcMvRx48DYX4z5M!L#qc z$k~Ai!0Gg>o_=k|udC@-3;p_5Uu~~JS{`30ABIXu=iMz0IZvL9X{h7Y5e?aGhw9vA ze>Ko?bs~5m{?gv0?B~ZeianzVOH!efIFC?nEzYAGaS$B#>F0WPg=Ve{O^R+r5m-%g zt0I%o`jTxkS4Jk0b^S-MuG6wj(u**{hB(k`rb{kF#$j8plL@s~bM2@9wqsgtV8a|# zml?6a!WZ`B-*Xh(u<9?*{C?g-=ShH+pWIgZp!QNIW*wr`+O^@*+3)N;{m`n=N2k?f zMm$x9i+HDfkp2nki+JanZK}UC^P<}idNPN-AaDIa)&@x61T^mM$xqawniim8KknV?(|PlYqDE)j%*Q zzJyte0U{?R>{z;$Zb0e2mlPEErx--U%8hddL569dXZEjQlJ=9MomZnz5X!ZcObq6# zV%=ll{ZwafI@*cD;v{sZVX|~vWBgt+C7H8oQ+ zYx%`?>SC>06 zVn-Ct^;2!?{2+P`gGUYQch8R>IvPZ9`LV$zHS;6?e8>EFRN23sA2FKHfw6RLZdF9MfM(-1J^%{EW>bgtjIvvF?_LN1K~v!yzNKu(OS~jbv*skHF^U+-vMho;|ZO0gocK+ zo->2Y90!@10*^F(79-?4iC;c}kyLI8P5gnqOT1 zQ%c4oci&71o+WG1z9*};cU5RoabMo-TVF9C9v0u5{tfufNQBmtOxqBE_r9+uck;71 zwk>z^HvZhgpS}F~7=Lcy&qw(4Vg7uGKOf}J2l(@T{=APr@8!?6{Mo~wtNC*!f3D!q z4*p!mpG*0(jXxLj=k@$)^XDS|{D17dePC4Oo%ekvGl79jm;pnL3K9h^8nn?s4IR)# zG9f6zU?3sN>zc%nBBbFAU^l^`leC!}M%lgXuD#d03pct;x9*mGYL&KD6T&7zsfL%f zQBk8y^~6DqnkE4v^L&2SIRnwvy`SfPdH#7CxaRjgzw7<|x_;O1TxYHNU8#OosNZGk zw^;oyR=R=@pgC8wv=?|$|Bl=|JLexFvqht%%@_4}OqZB@Tr z>ep1iN7Qe(`aPk3d(`hq_1mj{PpRJ%D&B7O+oOI56n|L#j;LQv@m=cIt$sb~*Qb8d z)Ni`_ouYm-)b9-SJ5&A6QomXJE;mja0bdDw%x!U_$m9K4Lz?qUq{!ocW$T?r&(WA( z90~Z0_Hd=o5p;4ti1%lKG-tqL^q0ni?)dWb@}|~ueP)9%Gnf``@M*^RU@ER+;|-kk zM}i)seQtwi%P+Ed2^^uj(GeSB1pYW4^jO}9dah_KAL^bS@RY~iAT8n38AiZe8VQ(@ zKyNhQ>kOQ}o$;wS8tBDOXW$ea{-I*?N8HZF^cXKXW%O_3mFnJ5h89c3QE`oC-p`y; zUT$=(KHPqUzoql#9TgTq?z*%ceS&Y0pC*UmZ$6#bWgKd97;hVL)n0KsiP&*^m^e8S z4tmPC63Y8M`COUg&f9o{pvn<#iT7u`maxhl4TK^AceKe(x}2XzD3}JH(UIAneQanb zH$3d#`VC(BEaOu0Gla;RD_%4be!$}jKj3zS8%EghpOn!TZ|P*)$cnWdHN8LUEOWM( z6q{)h*C9`2)v)ut5g2v`eEyC|V0ddvNpXC6niTwYGqb_xKer{N1YKFhY4|W6^!Xcx z%j#0&!C~{Liq#WqEipS(M8n1_nJ*c?C)h=q-ToKrvy38NG%dydhs~E7%RS+M$A$7t zkvkq32?yM+$mNl_{tj=rfZQ29eHjpc$L7hj6Xn3;ia1ENa+yUda<=c zzJ3O8s{OE(DelUQ29JMu%Y33Nakf#%9tw~$_782HR8pGAQj+neGw6%GPd>PcUXBk5 zOqN0o?yavN(xwqHAju%_Z!6_H*eqg=PwwE=!AT|2I!DW8ExzXTTuUIss7uVWZQ7a{ z;FypmWb~U=>_-F*m)1DMCS!v2+*4-usI5vycB}tQ@1r!?LfY(}Pzm#WO`6>BF!q4# z%VJ~v9SviRj=f^T-qgH#A}wz3h6PE;k;{Wu)o}Ir9I-Pm`<#Wl=5q6IIprzOK72rw zq>RbpCE}VGZp}dGG=JC4Nxu5`vyc5ULo5#(pR^4phu@uMxSH194#U+S9**lW_c+7j z;^DT8+jpD^;j;e3>UQ&rOW2mpFTNF}Vm-OO z4wk@2i0#(P9lpI?fX?J@exKm6Gx-GQ)MbKtKs&|BNkDse{^{AQnzv7=amDo+Zu8is z($B2wNbSW%iz_eO>$>1>Vs(fFD5wAUB~GsqTY6~dOz!5dh0bJb9^?Jz?&D|Mje~7x zr-k00c6_)UU>uYWD5=d}dLjW{?=xd-++4n>LXF9zaWMgG+jQr`*fH-jw=4{wzk!2( zpPn2(pBZ!sC;Rp64-(<geV+E43$I3x1IUs=Rq6OWuKzg$!WN{mm;64Fb% zOLul%@`>@P@u374`+1lZ)(u8`FlDI6_+9vzHuPF7$@rZJ`^weuqw+WTLjK+-f7!<* zdnSAB>|^am)P56rZb}z{dxGPnc@MpP(5ICQy^WqXyV0QvR;3nt+j;z6tcaA$m$t_z zKgNVmqwSqSy_?T|jZv+&+}rrqBy^9kP~S+M3cW^7eA{jimT&J2ej}+f`EBcUJKOeV zfZ~%MC!oC*G)MF6m(yT|rNKnmf0{2*K4z-?TqQjyc>tRl$BKgHd++~j2h7)&;^aBlvI4rSg$!eTFFx5i$S?ntLsBP%0i(_nC1c)s}3V%KstpVU)Q z@ajF)swe5=7&znI)P_e!P#I!r`*Q8?5_$et(up62k)Q|uEoFQN<`g3iLjl1!gV&0q z zs--C7llRlyY5Qt;VF=@skH%`>zVCS(KgD`quD2;B)S-VZT;SE6LS7iWHFG#x=!i@(mZUFgibs~Xw)>#*H;Nyd`56Jtr# z)fG!V&`Kr-b6pvFYE2T~O*2z0e}vpp3oeoCcMOx5%V&r ztELrmdooCWxGOG`JcY93v}^|%c^UGv2V15sYw}*w&8++!e)l<=OZcl4Pn!*Pb)0c zC&?#Mn#!>b7mc|4iY?&kTWA4C->ra9(MYIoj>Sppnfy1^#S=>s@AEH3U7=`xUU#f7vb?|VgJjG5mCE}w3Ge;h=y7Z${e3S2qOOSe z#9JiL-*-THTBP3?I#;b{gwAcyCxy;!^)~Gme$i*{zQ0v|M|^z`TOgyaNvv-BW-u-E zkYjdm!or2P3sLTU8?cBh@3w|Y3dj3Q`(S>aBcxvz4V*4!CZwQ>&4+N+GK~p$A$~?% zR7nJfJbl+drAUYG_dYU(S`H6adZT|s^9~QM@IE5#-rKlM_~rs{I|HOr5SC;@0Tw0a zt z+EJ4{5|f?HzF$abR-V+PFkaC5_VT#rX(@@oaB<(m1RnH+&fOmzORgj;R$}qs5spY$ zxyOV3M&WRz=zx(s5(zvfHEic78aTiW+%oqY!IAKxv>oq;@T;?m@7ID8Y)A3QvKT0r z&?hliUu4VTp**CD^@d<773qln=9d%{C0u5{M!}W$jgXeGx!&6-g{;0y^kV?U)F?z> zs=itD8GZ`k{i||Ak35X8&cF#?O3`BTGTV+0_dN~As(qE`qG7w*b$2L7)1A4ok2Bl) z9#P)<<+ZSz(|O)mj$H0swHruBk+EfYbiSjN>6JJ#A1cE3-P1-$wE?Wj;fa{ zs6p&9%Jp$oM$zf2h&z@HjkxVv@0%|5L9-%wWJb9CETq#_7!*FhraYD>zV)m4%~egw zV|EGO`$FrFV%M0@Dg10}?2`))+~z+jkG-aRfVw>UnAqr7G#z{B(t1`Sn?sTp?!3HE=G~ApX z`vn1J@(>s%{v=u{%JD_Rp}AQ>S(&EdD3|9BM;2D$h91q^G(Z^{t40RfbMyAvB`E);=uvgUH!_krLtW5=v02k_SN9AW}eu~4VW9l*gipj^02~@UNi(K0#7!z9p?&hSp!~0BYEJYG# zHV?()<>hPz=;y)Yusgo0J+7^4S4(7{O6m5i5P+tavSvxgq?u1Kwla2wZ;k6?m4k== z9buP}HyQ1BmX>kOaV>`_Q$%cvY_zNZU)+YlWzfpoZQ`x{P8!cUBwwxf!~!4Ru?s1&&(8rPzy{`&doJlT8+ZvbOO!f_I1K zHMv=PX(eS*3;kL)?7@r@GiWVwBV&V?L<`btlDPCUGG;}jAf1;&`LgD1k=5yu?e55} z5$+7#vBZ-!k+4Nnmfgy&KlL1umg-lNCeL6&s!zYJ)Qm7vg{o3N3|FOV;cK;Um0K(4 zo38n|$i)TUo4H@cGPRFfYAt7wkoZ{lL>fj|aj|EAD>yd0wePo7xe-jWa-h4p)FTo| zi!manNz(bs=Z?4Cv{L;#6v|o9UhVHO&ebIu!?HDvf747SU)ODSIc}wzGT(AExMKzW zRcUnvObaQc=D%ALMexCJLzxVdA8 zZW?(bxV^dYlsxB>}Xd!b0*!mWQI;9UgF6=m_beref-Xgq3h zAGuX-uOAay;>wMA!^6(tc%VDx;y1J)e9l?_cX5^Q_~b_k#L{xfZ!djbirE-LYR4Cw z5755pU*%|@@ZuUJSN}%_ASGlk^Ztx6Dtx}zcyntimFcW;tPUe{dbdA24tMMI{;9j> zB>A?c^3hV(V8(Dcx2R>7qO>(9ml)!c8&%R_ULBrakCviXD6)ftkcbV<_n zL|I;5JyRGngmIZ-G`)Ur&?iwxR5Id|LsG}q!0spIn^P}@+u@3Ru-dYbeSN9nJMzU-W+ZlUvb+60{Pq3jK>M37+MXMU1t@e=pdYSB|`Hqn@bS5cyOVv-@4*e#3 zx7!roel6Or_&tMcf+F&Fa!Vs0whrkNW_-pLG&WYotnf?nAye65N5-r%c$tcVHCb6{ z_LP;al7V=M%8?dQRo?L3+q`FEjxd2v3a9RfihlBT@brmxLWX%!L}rQ0=Jvm zR>7o{;Y1Tq!XSsyt}|dtL#x&_Czq+w*Ufy{yeol0_;mUk$+dss@V&8W_>JUh1^V9z z^q&k4pDY?a`9S|0tIRh7=EtG0hVSS|&7)X=!VjP{8X!pQ^dh)iPPxx_Rlu^Q{+kcT1ro7u$grH$=a_MJ!T7 zXDV5tp9#nc{R5+`FqD&}pUv?F9fd6ubMqRHHT!~tYWeVnc5>=&E30)bvPw=xgs^mJ zxWUb$)Tdt&WuIgI)m3zUjtRE_^E(H|3+*&M)sV^;26z@vWu0+F>vM6vl+bu(p~xTGel%&cM=MO;c(=U!W^Z!}1ijg>09m89&Ie6g2aMBPPFCA+Gk zi%YDkHa;#jcV{qii!*`}mvfaf@8fOFsny~+*HsuE9@#5?>#y>+H%z4^k8c@+Eao!NXB!zJZo_l(H+TB(K58l*r|+pKReyfHL6w0&=22p z(V0gcP0=#E;KU=DX5IWRbEJ?Kl}6ywAGw zxGt=#)R-fWZD-uxXO0f$mpVeL^$DTM^ICJ!NORz`nxxpcP~~Urut(_2(W3Fzl(v-p z)Cku$ZLiGn`egGp&S>!C zO-%Y5uw|T(;i4q_^|@1XaJJmIVJ&PX^LaAwl^OFZc#PI^pUL`MYpO+5*1{sQ%?OtK)Mdkc+mXBSsfQMOvt$K|(xxCcR{i$jn9QiUgL>s&I3A`0tP-oT%eLn~qRI?mkDhdX1wgpe~$pS!%w z{2P24W_ciV+kE}%lZM=Vv+7f`?bdRU*vuOpfJ| zsS;e|$~CLGq=%GJmzwH1OP78=^;;0OJimdYRJ(A4$bIrk%59Gv21Mo*!Z*(6q%)-r z%Q!66SVG4vA~a+IjKfh^bFq1nE+C(bPWOLG3f<;@Q!;M5XA2Q^eZQD%7dS@1mx!AR zBXhC{dd=#+vmo{vVG*aGX(grMtJq8VM0VUMEf62_wGMaW7M9BhB||w^2lIK^F*kJf zYW=##WBN7TXO0bi@2b2cpG)_|9UK6R;S}&|1-T0UPT|cJJdRx6MI3UXr$6en3( zxA=0s&%8Dm9vw(>OM3H_1;mn}k0X|Gp|j(HM;ea>orN*Es?-&#iX)aw*APQ_8+%D- zi%;Api#riZDSj9H(TO*fr^S;x1F{*^vR@D7tPHwx7sQ4nNwY+&{Tfy#4e3mu+Zf}m9VvOb_tArq<>^Ob#_>Cwj_DH?NJ2WstSpE-?hJm~;v=1Rgd5T| z7U?AAHj<)$OXgAiMjT!?DvM*R^0CT>6SNBj=%m!*j@&*`$yB+dz~YX+OXV@HJHub6 zI?@>FMCPz`>7H6v+`N@=Lm^FurPb>!uHwus+40{Q{r*pNPiL~Ykle;*#wRbvl`-r; z=WTo+j%COEtMxs?4@WQFrX2vFVuk`U-4E4cbA0c%Mll~L^53Q$@w^ADEs0W)b)uo zsH>_+CRY%FKFaX@3sO~Gm6zzfMW0Z}Tcc7)!>Kfu^=R$}!we#~#QX(bbj8X!=yuto?xTw?Q^ zD_Mw|cay;Ka*I_~9Q}=WF@O6JlMF(Kd0VctZ1_GJEJhO*WZ3lAIGw}Qjf7BU?ozXZ zFWMxRPE}W{P)8UvEJhjkM_zcSu28lg!iYcPB2ShZh9WrCz6^)$sd}Dr_s?pzHfv4n zT8^}$%0rD-%n*75i75xv3|PBhrk-4?1LYCcL9P{SXQC-o@2J3DUk)pXdQuJe`kFP(?w>$ z;}7`iTCx#L!Sgm5Bw=oYTVGR?ykc&^9b9~|g!W2_^@VU?6)_^ZSZB0opbXh53pP*u zVk87TK#q`($Nur6EwRqYvWMMq?=;$?;ZY5-C7)|Xdvm2($W+PFY86TtM;Iuy;3SSPJXJf+#I>z+ zYuJ^nSk=zkOyNqmwp123qS3*e?%`UU>I~wH&pC;=_+%MbsfRIY?nt$=EFuCL;3`Y4 zK~$^MAKP}`J4k5_rjs#wFUf~^@?)jB;DH{G<C!Fy0$vgsIl*Lk#Vf`8cz-&S|sSU+yJIF@7|LzC;?gFfv-eB#uO&Ie{*BpOkZ z_*hgcV#O*tAJKV)`-SMbM495R`0?3sd5CKQak;m+GfDduynF?9Lp?*UaqjY(CXvVI zh-is^>^7Yg13P&}a#!!xt7QN;r7`&)viM zlvqvqoVcs>!eUd2v{omInOZFqg$dNA*znN5k2*X2=eM~1!`|<0qdg6&Ph$nsxa%nV zjx&75U3cB5PsV5baQJ#go6cWJa=G%L&J*r+I=eV6_rd2*Yq5VYwM4+nTfAIh-hoxMbLenS#l}&{bBiIo!TWayuGZIk!2a@pGj?Q6$_( z^_xbb^>at;@}F_B{8K;s^vMz8-8G9?;zO@e%DF(oO4P?0t3EQNJ{}`2xDdy?_JO-F z{g{>l=k%k^3!O^{_%12AXGR4p>9XxF*3pMa;g3}5?;PcF*C=Tj_^=!5 zhPt4x&)17pKD!BTALan&h=iS}mjWlbA5{x@$K4H^Oq zrc#kZ%YvpHndHT;COgIpT}=%!YT%F|`k1~DC2V?hnQU`I(5na~b$8~`=CKPG z1XqR^)SAlmgt)6Z zmwtRPO(M~5YTYXv(4eC|e9dft7QROIxCo5*WC>{r>#(5-z-XvGjj=JF9ZDut2d z!;9`g>!ZlCB{@Q#Uv#b-G0qWyc=w;(l4P9qzoLH|fgKU z7gIk`rQWtqr2g1dkA5!oOI<2RHy?B1LO?5c`Jmn%Ze#gyxZ$)G9ETQ_w=qI2C_qI$ zXA&+2<19i5ceo-;-TeCRa0l;eSv;1{_hmE}dC#{sgEwCjYVe|_@oPz^@yhWSg*NW8 z3s2Gf{rTh4W7jE1zUW=O%Eoe4?&3L7JB=#c<8llNHPDZ`@5)O?;%;vf%|_cJ%}$QM z-jZad&f>|EsIpHJE;ccAjZ{XY}Uh9efL9ybs7iBS%rO&EHZ%mdx5_N^zdXtPU z6ZYB_KRy14?;tFvh{XHB@-zdB^{B}S6f~K~JCf_h2{Br#GhvA~(II34L2SAr?w_B8*h5iIK7g9aZoUi0^e zv&o-xmW;F5yZ)YFIgU0@4F9ED3vy>%8ZKiWh`(zS{!*2la{nRjCzv^OXrrg;b)4#H zCFW~9mK%5aP~TqQ3+KeuKEMkzGF7E=fsYs4&!SH^!W*7DcS+AQ>UZTQ(tC?xv1;?D zFCU&B91w;0XkmWJ?~UL<@KWQi8gb8V0837Pjq}szru;$gGw7EuX2-3;B{8rR4H%0F z_hr7sV?|SwK_qLM4%a6ieS2YS$iTs}GcIF%Cgab?j6H4VT}#5}Z`)4CU+o|AHl{K> z*_~t^9i$=iLLXodh}P%0hK@&8ou0n3IX{9q?+wz_IXpOhRZ8rp(fvZXjqX$}bm;h1 zm!0?GEtq0EzSBh$!5pylyJs(HDORxVAUAUrU z@fcV5JY6`Y;kxr}p@tN#8BQ=obw%Ul;~$OlUx1{2TzzwX>>HyTrbd?}y6w2XWKbE2 zKBrO(`+4FI9sh9LEetiHF%TIaSv+xsBr~uD`<+LlOB}+wd4&2gCNv$6KIn+t8ob;; zRhoQo5@GpO_YID<=NdQ>cl36b>IhaBNR{~p0Z-iD7R-v~M~dlk#g>q?EFl}sqF?$u z^>txua#9nR?OQrq^`SgwIXAt?@(`W9!#ch7cSZ_)`t@ALtYz4OT4X1)RcN9Xo5q3P zg-E3HbAWqkc!@iXqQ`buJX!V80v`wL@|9Ohf-Un~neiPTd#LQ!xdJTtXfI+m&QWe# z-zwAFJ<-N2HMg;=&2>j|dHLCW2gP%)#?|(o*ZCkqV`f(+E4I_ZzRFFH?)xv4cJyzx zTBJ*7x6X?$^o0wDuxKbFqdQm~+<>wFt;B%%zoWI@n5ZktOD zv&Kuu-yb@5Rk7P>S9PV9J!RonIR5nP%T))iv2X1Q>$6MEAM?$QQe)U0L2W_~Q1hS+ zjA%0^<32Wt58$vkNhvnlI28z2O<{oO3|DzH3Y0~R%i4Wzp3mm0TcjZGOtUwigZW1h zfLv2-{v7=W1SykeQ9)8xpA&IRQv33Y+jI(2)l=!;z1lDm5004MBAY0i1w6bA1aWgL zkkVgj{sJ~Swx04=AMmI*dSpR$O*}pn7jd53JiyYG&6pg6yR%!DBS9_Goi)A{sDbH8 z9=E83C3$#}*9S=&Y|nr=MB6MmRYRY{`|L}l#?j|B#N{t=Qmak>{cq&`4t*NyCYR{9 zKoM-~ZvXFtDJh+?u_^x+bB2yMroXaUPx1dY=phtN%p|ZRZOy8|PT##MWS5pmQK>}j zM7DP!C3d=!NQqBW;F3HUL+z3nNulx5uT(l-d|stvs&xdTPx8O4kMqBXqU8}!%pE%7 zmQ=Wmmv+1@2h6$$XQU%ICIwMr%E8qVo=dw|$B|E!vMmgtNALwr=ELDU@6LasWW&Sv zcpup#pf#iKM^Xc;+%FIk&C&nX>V|9PD*3?n6cp+I_(v(|*m(Oji51g3sACaQRT`7! zJjiHo8|Fl)YcT%~M@aXED#vRzNzF9ZRpVC3iO@K$nE|weO>VSkq{b=dL2hpNpCeKV z^S?}zwwOWt`xk#laE$jEbdFN_{mlCeOSxWmN}FokQuk;9{-}KDOwBYJ3)}S{4V@_$ zcIJ!W7vsm@89LUKwm&$f0R8`liBZ>nbb^Bu3b>;MM*SyLgQW^4J}8Wu43SGna4N7g z0*lW3d0EZ0a$IJ@B`x`bp{1G30X?TzHsghnw3npZg z3u`jU)x5aIK{V~F37a%`S;x2RaB5^F&Cv;MJM)u!82{gC^66JC;5^Z7rb(j~0l@_I z=F$>*MEX`v*yK{&);Pu+Q6z1+>JXWsX+TR;6NL&}As5;;?8jWe_B9wRF< z+d(PZ5&Y9?bqYvd`RPx8YHdv9kW>q%=1D1?u}aB4g6Ae8D?8+%!F@05n;#i3bp}R6 zq%d>_{Z4Gjm%PPbymUbL1EURrzRSnUP%+t!hi5pnI}uwv*sHRG3`^p*~0P0 zt2F%(Lu?UOHH?Wc_ZB93pVfG!gb$fNgy=dJzfEk1*_!P*=V)aR4zNB#uHo zDPC{WQ8EIr*ff#rmDeP#=xeh%(STWOJ_|R#m3RDbF%2A+d%|?b0zQY$_kHei`(G6e zc`Sb--edFpJrCWM+0Ly>cvk!^@Bv7N|7BEACpZZ<7J70mH;<}-GqMN!>WR%it$wER zTBQtyW{?NXP?~~ewgRHpQb6=46cGP&-NWhV9$x+vQl{w>Ahzz| zgK^#*eeitD9ewb#m^1pIC>wh0@Gonbh^mTS(R}GbJBklu$&pKG&PvD8aM)Uo#>5MH zj&I|BcH^M_^`V0*rb$9oRGpDaW#C!UUS)xfg-jZWhc)fZwyj8Umvg1ZDi2aW)|`B$ zYP+LjOjgtDM(6fvtl+a>Z<$CWW4zBF%ZoW{vhHd2<;IKLL6+FQPzFkz^^-z#=hUa7 zax<4ZO0=xlpU!KcTe+_!e!D9+sm%P=@8#T|gQ}Yt>S@$eyLxMf{$9$k%+ZZB>bppG zc{DgsUL9hLMlWrmj0Yo6K3Vmoxfcz%z58Hu;_H1r`Fo(fyZKq;eIZ#~?|p)w&g7@~ zZNwZ9J5E%{+ERoMbmA)G_AxKSk%Jmt*GNZh>vK(iMc&4`-DOPjKKrU#(lXC`$xb9V zqF>^FOLs?qsm+sf#22KC$F9nLorA_ner~&EV2G@6Mfkwp3U}pDPJ`+UW&a%XGnRaiglRk z5DCGvP07UnlsvXM7unXA$YXckrsRK*VJ-65DMI(dJBiVFxFBQw&*ZTZIC8rSZfzOg z7v!dWP^w*QB4umMwnS&3POS&YfY%)=nZ``;jsRV5LZ4DZG~g=v+r6LP=*WAfOH z+lj@J$9Cs^r95^fR@8$y-jxGhfeB#}a@7AIj}@1ceZu}fk;keqN4fhS%VX`ZPZ0k} z%qh%i%m8Kt<09%yC0GAjYOoRKKue} zjY`wtWyh0cC8g%SpsK^99ZO+J*=|&tq9MV%LveH?u8RkIxkW(|BQK)cp%SDdvRK`( zpmHmx#L>zlND3<=>@+mCWC{6{6ql?Rn;FPO31LpZq?;KpCVIdu!Hx0 z|0ALgHGHUf8%59(E&52NB5&ir@ZfzWFOD9G|Dg8=vPBLxD_xr0*oPN`{Pd^M*>_W3 zZST7NDf(lR6ovc@xcaP?r4D8^^musB<*dJRDQ>_e$=~4oTQEC-M7&hRu^tmhY9cKN(w201w7_AxUl* zqdKeT7jq2kwMgjxPop8xxr-5oEWj&{#FcQs+*6nuzoX=EHa}|1W+JNI2Qj zs)}KbcZIJJ7c{E#L8d{$6s;D&CQTLfXP;-LE9OYht6JSf=W5@5!xOBw^{d0COTRR1 zrs|$TT~2@xxY(bz9}pE@FniSY0}}<8)#S1ORP{%#*@;%=vR87UN4!T`r=h#T zD@~;ca-`@+HHEK9qiKC!_JYlg$){QF<@!7723i82bTr9R2Cs75!uvVPKlMH{o_CY{ zZCj_Z33*OA%{!36pYbY_5Id5W|S#(TfnB%e0nE7N9x6jx)>J0 zmWqntt0)X8H>{H_+tLfxrIsg?V{r~l@PuyT7u{6L-r06H7kA-9E9pQ{iL%O=ICzk^ zvaPE3wLF@9nn;>=Wl%P;DT4=-bf0CFAy$MP`}fdpvD9+&@+g28VvFojVGmt*8T)4z z;HshfTDn4Q8O_Zqq-or#S9eKx_`6#tB!cS-^<~6*6M+%b^Q?!$^F@V_L;9M}%vr=% z-kB^6X)Bh7;Q?xeP5bTDrx@enlYO)lQJ>Q9H|B`acXbc!viR>gEE1P`adnr)sD4`L z-shxJf4{dCvPUqxm#@XUMG&k{*dtsR$-H9EeR9^jV)DLNIzy?1Mq_3l7#o)5a2aC7 z@0ONu>jCd-40Xr`kX5-aIF>37Zi-!nimaT8>DSOKuCwfeG1UNqOT+)})Ke`7*nR^w zHF}8eUQ|u3lT&??c=a~65U72Y`l01@0~U7%&)&P*S~jb7_agmg*3x@SV(I-g^dGHP zjNW7nnZ?rkN_*+;v6kM!j>x64bnBb7pa~$N0=c+{Th{W~t&8;W*{zYW;6=e<5*%zw zq)|4}I7<~xj|1Hdn|`;RfvoWM`8hc|&UWxR!XGX)>ASGP2I$~G?_rNlGuf)dYIrIO>&Z$V&>POyDF z!L;nw%r4!xNOvy^UQ%2$5OWvT{3+%vt{IF^_DFLX8}?+ysmHHSCK@f=oAL#{l0o!J z98p)B?lk!L`j_Y;wc9syr1|HI4w5(gee%M)Nkjip14$HV9Qt~c!s)Q;m5O=cxC04g zJSq4!RtNI3A=kv3<_18y|KG~>DP^W;fr&`bO-2wmjkiRKhRKZhL7CabfMGbxMPo{9 z`amDI+`J1;d2I4m=N8RfB_b8^Xjq@R&#hk;-{Ll3ew(3TN0n#j9Fre+jqz4tflCRJ zS*!HZmA-VXGR0b}pied5q`w3U$`B3RTcQ>!YUE^Yo~)^)qr5s*+{CUfD=V=UEZDh} zowxC7I(%oc*fVgU*p#+iRsgIF%pYS@j_fCGkJ!p$W@H#ygGU16A7kEq@gi$hBMqS^u((JR-d@{1CSEYH6&`*;z$J)iQhI+&b^HMhRVP0}uDeTYD!o}2wI*17yIZx-1w z7QWSy@mA9mafh!oehaFJFA=^H(d(B+3tUW%@htP%3p{7Mz%A_fRu}xg{{o-I?N&GZ zA6R@_iqDZqmfYg{vU4z!6`g%sTi>*lkGZhg_(P=D)%O0hqi?6Y$U%hLlKJDBlLf9q z{lqxa_U^Q!eJL-qe>U80?}3lLpYqC@NU=MDV-^$P(=;z`&0K}{m;YcX6|*Fl_H;?4 z#1$!VZ&_L<*NA-@ZRmgU$&x3{T2fVF*6-LnKd*&Qx!UXw`bx|Jg2Gnz`sJ}$6%y0cRgneb6HDrq^lIdY(ZCakXptAT-V+IM zr-&))kAZ&r0?YnL-~{)NL;|Nc*Np_Y)Wp}~<%S=`-e<DMLfC(qqf&z%i(9~xWZ?3)VzTT|tYnBdr&z3QOOCIN=do~vt~O`&r) z=(9rSvh=${=N5P$ju2GnTwpsFiQMOX_%GE{rT39KK+TxGF8b45H7R|qP)X%D!t_2| zO3fs~Ee8{tw@H*4je~ttc_#L`lSP+s`$TRPLEibyZyAXZqu&#oV81@{Ogq;@$*F;U zC2RM~Hq%@NSjvZDS@FOC_X;?~731JL(7qP0RN)wTmT5F0OLKS5f^ zxSDY*?&_0ENW?>atS#J-q3PEXa`dh^jfBYbG_KHSdK!P>A~Rkyc12$V=R$V~9e>w~ z@bGwV;}3Drw+Rl-yRVst&Ok58(b$mMH+%6OK)bvdILyc+Zw8L8I_qAnDe6|6XQFx@ z-&QW>4CEn|h3B7N3XTL%eKDke`O1)#zwWzuxBLtPhg@M1$?-P6N_uM2QR*GpGC9=n z>*RXp`M|H~demJZ4TLjoxmALT^S=KiE|GAe0>Qb0SbY)=v?95Dg44uevqsdD1E)CK zIOLgIWHuxX^*95=bBlU|PG=x}Zqdo0Gczz{zT{wgR%hUZl!LtTCzGTPIcm7!gr={} ze*J)m8kI0I`xti-(nqw|>iPR)@wi;L(JkI$ow8k*$jyl&&|KbXtU71}JB+}Kvhn`~ zA7*QnS59L;O&|hdTcX7#ha0*z-8+h{l2PPN3G}Rqd}mCgJgF*@$5o1_8KEXJKsDaw z@EyloUyNuD^E1q~OA*sx{sGg38Gkq8A!sW`jmuNW5##cdQlsm6bvB|-PNsKMH61SN z2%I|75%?qKUCetJ6Vr!z9}~lz#(aSJ@LWgWqucEH*68Nujs;0K#9aJxHsq;lIu^W= zSFkTfD?2#3Dm+~ii;e|ON5=wJR-atpQ^gtTcMp*5P*tbXq4|e{mU6Los1s&xaBOu( z6&mpcBuk&XLssbWJ_4_<1aGWP7aK2LrYpwOY9EZ~0$S=@@6l3;Cs`e~^=%}gYInl& zplvy(JodKt*@MO_%n*I)>sx(A2%JB3SA{G4Iq8ggmQ+QSpZ)gXqDaGF^l69ZgXctz zy6rpyo=?0lbPV-Sx&6iFY&OeOXw{B}v+>*Nm>^CSSQh7K73JlFfpiBSbJQmq4Qcq| zeaHAi?!J#1N??TJlTlfjyvF-%@a&Ec&)-IIge%X|0jJ1LKn1^Qn4za=N_p^O&J!;k zdUMCSQU=?()RMS2V!5O|_-XVm2ifNHD1j;4iz7v8(O`eH!Tscu;^;~9a$G6r6BTe< z$@>TH3sKy2fR?~Hqi9N~@*G)7b20Qzi5I0cJA%(3BWo$-DxT1pIng^^^;!P5I1ibtqqRn6A!x57{Yw;d0?J2+apbM?_(ginXtyqwir8=V=V4?`Mii1`6 zP_D|Px9NLCsqW~Z#f|XNTx7wBvDst%rCV~aF6!A5u7AX(>4DPa(Qo_W%N}v9T1^Nk zt$OyhdAKT3=a1n-d>9ZpsQIQ$nupwYV?TxNttl6`8?Hwp3q1IB;{hvU_9L-9(i^$S zUgab~>Q00pY60P&9D&tPJ(yaDQ zCzeX5`0U+ydCQ@c#T+*f7N9~kcT8|>-zFSqw^sSPf>(+)tHZC& zUEm5%oa+pxS{u5^n7(i0NUbSZ!i{tWJW|^zJ~~_Fa=`72oE=drPi{-{aHh;9wCWAV z0Zx{^&yMr{tPQ=WaN7u9O}fea2JdHDYx6O50eKTJFq{;AU?3@8WCpv!fsrKMf{CLH zOTZ63z9ZmHYL!mUc((nT!N7Z=V0tuglIvv%21~UVRkjbkW0AQwS3Nak^63}%P>+L4 zTY3h${7h%HbXo;M8#CI}~}tyL>D$g#xSU47{s_ViT(3fp=rv|N4$B$lj!tN;Pf1g11QC zOzEuRs==b($dV+Z=u~9M7(VkfK6XXb&|6oaFyzvxRz~+7omwdV5SM*$5s#9Gs`lY2 z`E@t_g!wqOc5abJzfUgF@%%dLTS-2-G|!{hK9qlnFya;$eC$cq1?|hwaBzlu$NJm! zuSXe!cFYTFq3G;zohRBb@Z^(E#)}3yq!eknS;yLj^Y6oW4_f+Aa%303W;YwRi-&lm zhr1u;g^C7uH2IM1tG6-B`1i++`1n@+MnqLDUtgGWNdIJ3-n`2%KOA~HBdN`m_x;|_ zJ?8Z4$1ZQ35@#HY%|0MQb@uDZ|JTL;w1qi6`X_8`wx6W$_0Ts>9R$s3*I(n(m7X{P zFzXdFRAJlk{^!3xm%yJ(;Lj!Sf4l@{GYQVXd<`=OGsscl`^w7 zQ;jLb6kxuExe~+6E86Mx4(<1t=P>^rvlA1-)L|+xrI_0>S(qspH|A`$L;DbO67w?V zdCXIoA7gf6@=25Yu{8_bgh8z|^mPm>C!s}{J1{q6?!+v{WMgJySOkW?iQ)C%&~+H( z>Y*&mBuowl4O31Vwa`4we9WyF7UH2?OdjTT%mPe4rU0`LQ-}#*zJa+Bb1miu%q+|` zm>HPqn5!|Fn2DI{F&P;2d_&VPUd#l{l^9l&ArB@6Gakd`JfU$Ib^)AiYN08Zv6z{d zD=?R1Sfhk4!?-Xke?z=v9ZJGbN};PTOE9-!STKhuHf=3sD1SVU(SSb9IYt}9-3Wm| zAX)zAWNF3XAY*1u@rto-?Ut;pvSMP*$dJv5=3ZO9mOo9at=-0-8yDJG&FzM``6rLs zOl_kU)Hd*sl9uO-aWWayH` z3+cLPuK2r{?@hIp1iWeE=1r7CMdg=m+RFR%$_iC77fVr-^0`TsPmmaG zHxC3i=t-pZstucnZsYwK zwVT#&)KxQpQ&CxAm1oiV`|37r-c+S$l&;?_Rka{9GvjW%fi7PE7j^6E9+Vb5o<^Bq z2c+FzHGVv;Uo!PAny_}`jW=rZ61m*Cj@BLA`0b6Gwr*rlO8l|aiEmxt@ckubVWqx! z-DW+HX0fHRcvEe#R@2~F&t>a3R&3g;716cU-Cue8rfqpzaC2o{_RTj|Y}mlgmcMT; zcKB|^2>uZI3FfBhOPAy^c-%C7(GtcxMH%~`C5peo9!DfSI=FY8L(90|8e4=Hg12ui z^F!4|Ua^eb@V@Nt&-2dzKjxhz2Q4$da`U(KO|^E@)Rvb7?oPDFyYg>ekif4=D_*ea zfd|%YtXRB$V`ZN9u=p;mtlP}^r)iHRl~n45SZ=6Xu!(MlbWiL{^a_i~%p=bQ>o-&` zd$6`rtFmm@F^<+Q+E}$IPkY)?$mpK8fsskusRbAx?O8~BDQTHKyf6`|iAmGOiT?$` zx;jRN1hYhV@{m_i!GyJ$!y4ffZK?=vsI-!iC!#8ehivP0n;z7jQBMmP6ZJ|>`#7o8 z8rci#Dl4^LDLVzVoQokz9+of?5LTNewt-9=Wsdj^e zAY+mm-ZbrpQd446ECXj{ou+-5$hB4Y+HX|8@2<2Sf2kF02yU(xAGZgqs;F?@p-H-s z@@1P6+0oWZOjZd<9aBCVKF=Z5uc&rZELE-@RwLsAmN*6C?yf+Q;I|x$8OQDH5XL@9 z@2GZkrM6(hrp63zuPo_qeZ%sNTN!yTtX-_p)*AWx^y^s8 zY1%(99y*|`+mvbM`BBVn87JS;v@C3Q_iEaHo)2Q)5I(#l?Sb!BJh)K>x%s~8$_Faf zTwJec|AB)gMZR&}hJ;mJrOa9c_2<7om%yJ(;Lj!S6(x|Bj7rNwhc99MJDw9bLAxhw zzS$E*E776(z%#)zMrmAIG{xrchVM~)P3!%d<{L@1+!y2KG&qUTFXM8}chcs!g1Z$z zN$b5r^BqdKzgqJ>ZS!{#&J#9&_syE`QH7JVwK-UoBoxW&j*%pax2(A+x*rl&DZa- z_@ND&uNN%g7jGml30$xFT5a6DQ}aD#yYK&N&G$IirMa|Sk7>T0V7E3-+x>T%uikc( zwOjLTuyO89q#vxxoV*u)eOlK0*_sV}g&?_R9=PS|cjMVjx3jr;G?e9zf< zcd_Q%Z{xLhQ+HtTyS7a8?XvOido*9jcC+hVjSK3m^w-vEz6#q-@n+4pLSd)2D@^s- z{Qci2zc%jv0eJ*V`Rs0{9oje)(R^vPo7xu5=eF@$gEl$d&f_EG5iEJssFxnFq_g(F zkuPvE?JDC*@|AG2k9q`4d+Yuu&9@tjKtn~`NHox{))E!vrasRKWJKIg|Z>T$kom%Jx+T=JZ zZ7dsoyd3~vOzH?M@y>(J#>~RZ#AIO7F=-eN#)TPie>J}!I}_83>A`ekBrFL>sDvd{ z!V~JTse~)f61LDpyn+*PkH!i23A;qP#El1&uutGbxCwXC7x^~1?@@n}Z>7$AIKr_1 z4#3yvC;2wOmvvv_?aTi1-}tKQn(9$yWrOo&h9USUk|?!{(kt>?uEZ< z_`3<`z!&(-;IF_vZ?1mMeJ=cM@Vmaip9Oz0{O&LC)8WsC-}43j$k-%b7W`iLqx0Jf ze*^r}U*I2t{}|~UhCjO8_Q9{ky*ucj9bWv~34a#+Dey;!Ukg7M{!I9z!zqTp5`NAX z+)H~DlZ*X4?1#5FXtNjpvfx+1ANc}*2K=?~FS@jl4}SHR@LlkWzl7h93^w#7{9gEy zj&7*rqZKOkx*sa}eH<#~(F|qO(R8TDU{^vRS|L>YXW29ZD*ioC@jskwg?kFhqjmx+ z?ho0|PutH=K*irqo4*Yz{#V-eg|>Z;Z9miId+cY;ejadH@$}mCh)oYbCEk5diRW>f zzteuMx9uySU0bcTx)|I8mU77g58M1SuzQ=;9!8w>cd)oQ4bBBi_}$=Qu*7))yu#-1 z23OnsMsO`y^0@)rY-1j^WjtT;b&;QI+C1>(HkR~BTv7*;KIyZ9C4C}a6D;XNLqcIm zpVXW1Gr*h&Fydms61K#BIw{FF)eipzc#4gm1B*X#vkxp(%%fn*m*9HvmADry`Io$l zpOx@AkI*zTesH1`>SqNQYvo4LlPK3hu#}znm9!RW&IQIrZPeDJ19)W%WeHt2rJ`Vj9+6a|2Z-5T)yaIX}%DvCNLFg># z2T&h$7&?63;rk5Q3;hs!2>KE9Dd-vKqtLU^dgwW51yrtxD1=IVXF(y_6sRgssFdZv zXV!do5;}|LE+}Vf+J2}APacCxd4`~zziHJ_DVN1iX}dYlh0qLW7Ssckc0DlSP-WQ* z<@``P0+n(*0G0Ok1XQ%TnxWF(b*Ln81yuS=K9sXOEekpmnhxb`Q5!ku@XdyrP|g{( zBhW(V(@+uHKL))88iLBK)($)lLfQ5?jfF+HB z`-iQ16?_6b4b@$s_B2@PP5zz$OTUr7U0_MC{A~kYg?mXyHCWn}{4E1#*!*0ubI@v!Jx~d^3o2!H04nkAhD!c++0XS*39kYw?w8s8eET^I zD(T9ALbNoSx}g%@$e%3Q50!NELZv)TKt%`j5EM<(_pYlGK?dBwSJy^m#1g^31KJd4}67MeX2B@S{{_1&7^wG88 zUlOs{Ee1>dxVx68?pU=W>8u?6vWyN61D*bkNd@HkY; zr4cG+QVW$bSP7Lp=R+mGv!IeE4^;Bg|B;oKZm5*seyEh!E~u14EmX>;7%F`x7y2IQ z%7Xq8It6+j>Vy6X>Vir;9RAR%^V3in7kZ&G9&|&ceI0^Izdit!{+r0(KAt7K$Dv$L zuI+@Lg@&N=>Q*iEW9V9_=)y09ehAHnegvHjJq4X%^S^4`u*Nmg!T2(Sduv=vj3Zw) z9+F#0lpe4`?7gpX}j{50TzGq>;}skK+-H}llejB@YC;euMAY& zoB&U>aVuE%6tZ8Fa*%z1xPJ`3@Z>K97M}c7fTa(qG6BoJMAqo@z_Nyy@MnQ#f5Lw) z4J>;~;g9rjSG$dS!RX25j+E6}@N}r8vluM<9O37HrJg0OmH17Cir*RVy*6L!`hDCB-v@t!&6j$Y{gv=X zOlvHZ@TIP0JQ2S9nb-;Kfl8c*pi&P{L-DTa<;&WPq-R&;VtY%t8QtDSx2r_kAjk{t zLDl=H_At8MN4Jg9ZD4deNwfzE^Q-Fp%j#O(|DUMqM4d|biFy?L|3y9SroIyWxfz_O zn{D7k-K+&C`uSq8q)qg z%mGUpB+MD$A3!B>ZZJgg%~Pz8g@@?^{{vLwdJ6m_oBt^IzuH&_@3P$#ga6vbS>S)P zu?PHLY<&9PS##U?1h@_?>$6ty^-!tzr@*qNlz1Nlr;&c)H-mu+*McYUAZ=y^_$N?t zUkHxccs4j_<0;^WZR`O*V&j2#9KNkK?gd|Bhj|Em9ejy*KloAG&12xFY#ahVWaC=! z_ielayu-%%;4NS&&n)owZ2lB**v4*fqmBFD=7m`s_k#ZkEPjuGn{EEn;E0WPgIjF8 z3%t|D+rX2_i`4ZB@ZZ_|+2F@*>;wNd8*AVn+xT>^!}s59d<4AL#{0of*!WTKlQyme z|GkY@fOp$?Hh7PX)4=sM9(c>)`&%2I0RNSZ4}e29-Ul{p+zkFp8;|Z6qrj5u@NBgN=RQbzrHxfj1n!zp!x+ z_&ysy2d=R3Zg8cIcY>?H66Q8=wT;(;*V{NBTmzQyXMw+M<210W(Isstm-&`MBwxKJ z9lm>@!aoAO3o3cs50<^4xOoh`8Y+2g2CspNn+@OxY+MYMy@2rZ!E0?i3oL07zf-`H zb{X3}U>Q?o%pZQ;npNfQ2XS9tS7pik)ByPwcjVW#AKB z4NlAzE5M1lVjegRdkJR-c!rHVU|BN?f8aI7XB+o|XM!cnLtt6cO8M*q%i2}&qu^Ok zDF+=aYe3;wfNy|`-(}z%ZGH||*3uH!6mTI_+PMan^{wFkS1oz8_&ouZ^{TjU1 z!hZssSg$?`USzxZzuSBJ__(G#etgxkb3f;t&w2bjo^$WaLi!j{rVQz0MY;s(gG8AEq<0hPkw_naG_6@S())|_=5>Q| z_7&+hNKZwY`mhY?pul${eV|BpBE6qTHzBPdO>;^w#%y zES&20Abpg;uSPl|(o2!1csP|=h_ofrT}Y=ydKS{QNY@};AkveNj*7H{^jMM3LpmnX z!;wBhqytFDMY{K09#5xs*COo*{0gKCMS3yP36Y+M^mvi(K>A3Lu0a|}Hs>Ws4-#n` z>7YoDKw7R#7SeKkx4h%&&5cM)dAJhkgHf0E%o3yz5$Od;)1IO}&qexpk#0h|M5HGn zy*<*juNbj1X zAzjpSE$Jin=79@{nd@SJEVh3IrXJCEcPf$&3}E zJjsl8NK-#)Uu0j;>Cj#Xiu7dB?;_D}2N1;rV+4MLzz+qaK5TuH&sQ%X(OoB=SBmE) zfK=|^#gP|?db32m8bI3H#eg&iw#XkT^5wk)c@II}KOh^tM~sDRUKpU_CFc+``u>0 zVlX?f1d#eS50LtY-_>CKsR5+^6p8#XB7dmJ-}EZaUkwO?fyID9z%IZ7z;?h6z%oGU ze-S}6pb

hZ95tTV6pq2+$rt8pkSvLC_;u0D1&LsGT4PO$Ma?76DR!ZSkBZo<{(J zd>|W;`rr35@83qiAfDF%QvDSIzX*`%%m<`;oq$yD-|<;1$`PHks5c3a=okX#0ur4q zt9ZG!fJA>8AkEi2zz)DVK$@Qdz#yK70~P=V0EzzQmw3G%K%&1Aumf-rU;*GK3pyvg`W1j<3 zzm@?~f4Tu_Typ@a{Te_TUol`1Py;Lg%mM5G+`N*vvzj0XEFuU3a|nV!89@-R2?kM* zU;%94=K(=r10c1(29VlcCY~3F=Q)7XpE^M5PYEFP#|ET&K|rcE6p+eod5+^(15&w# zfI+}HfCYeMfE|FvfK=ZGr22V)R6iGx+Ua|i=l1|o{z^c~UnKAg1e`1KJ4AjHAl07? z$mR_&h-VG305BJj+TF5(=Whfg`fC7*{&GO7KMybnSO-`DSPa+!mp8E?@y* z9bgAw5#^(yF@V(GZ~^=N%%6J%TnR|+E(WA_=K)f??SRzoWI(E4DBwte&k@gf!HL!1 zvYglN0i^n?0jb_{fnN+r?Q{!#mw28fp6dXq{mBAfETAp&g8~i}_`auj`CdS3Zyg}@ zcNJg|a4BE`U^id~U>6|GM+YGFs|k?$QwB)wmH-kR2axFG0R{nc0Sf@L0XqP>w)1W_?a5Cw-4 z1c5D&^L91>QadXE8GV887WgiKp9M(m)BsZZlK_K&4qyS`NWc!j96&T5*!mc!yAhD+ zt^uU_%K<5Wk;v~7`LjfR4PX%YC4e1(4qyS`NI)7_HbHcF%cFoGyn!G(w2B}aSOQ4& zy8vlit$@^iDIm4)08;_NaJ2a5QIAciGC{}(VYxPbPE89-WWilHykhs*tdk!>jCV*^GZOXvxFcB z%qNIM2ZLFGG=tfJ516Tk!iSVfD5Da1;5=6#uzz*bR(K9M+et`F910c1(3Xte51Elhc2qI$v zLC~8k@@LU=2lNdf)td~6$3QV)5YPc+>i|f0OcsMVflc?*b5>v-L5zPDAV6RlU;*Gl zKokhfqkMF*gF(EfLNJJS2!e1iL3FeLkm?zL)bEjiL~l4?5HK5%`nPp4@6TpHqQ3!< z%C7>X@=F1!TsI)~yAzPgH30?zO949o3jwK~0Z8>m0#d!zKsvAKL7MzSIyI+3QhDxF#M zAx&lI9ApW~(_GS-Mc`IZ7k$VUX^P3`AWi+DvkY6{=`5o_q$&R2gfyEg;OC1p#R-=n zO>0Ky8mn&OW$0|82WeUhI^zi5&ig=T90ejxXB=fnQ~a0CI94G|u_`*_D7b@{r*n-m zk*0Hv4x}l*Oy?R)kf!m{xkhjyk3myRvI%L5jnX;Px;uFcn$E@K`qCMPTvIwDlXyB8 zlXyBWllV=bBk>gf%)z)Qc1-6BIoLBaw{%WXggrogqj+*V(lnnGN9abH%Fx|6nWpoO z%~%(Tk5hcU2y;l~DGuK$=96OeE0CsrMKRdyZXTPaxcw@m2~Tm?T#S*{h2pLn(lmC8 zyUH}hU1gf$t};z=SDB``t4veeRi-KKD$^8qm1&B*$~47YWt!ryGEH$;nWng_OjF!d zrYY_!(-e1=X^OkbG{s$In$DPHn$DqQnqs6mck%gLP4kH~%_qf6n~ii@rg_?ENk@>^Q++nVsbnW~mRKs=|b>Z<5tJHWWO@^l&>2U2mBm5uq0O|ALU z%j?=unbnoJ=EfP*@xcQZM<2nFw5SYy87IH7p>8Ip-_(-df;KB#^YKj~(H+?~@|qf3 zSldTyWU zRh6|EirYtGL3Ipl@|5}&wcb3*PRn_$sGZ7YgspW$e#=a3Q+)1-zM{nFS94r#HGPvz z&=k0I1uMn-1zc-7p9ZHs�=xrWLf2Pm{t{DP3D#JrJJQN5QvL;oDlksJOG*@Ie~- zB#KfFAA9mWv-wrWfVRCk=Y7St&fU^8&M z(aie&=B=`=S=leVf53@_^=JY|AJg&XQR%yyr}kIkIWeNu(tKtk1RO+i{+al`45Ptt z&9zf&TJsw*EzLZK(_wk|a9CS2_BN}b;OnZYGpcy>*rvxCwq~?b+t46eaQjn@{pD}k zqXXev1$7~s_VD!iu$Bzkm5rF9mL_Z)eB>v;vaTH4ST?@vY^4M(BF>&XfpeU2A} z*<3W`*VRtryodhQwkUkZpBq~RO14YlSEljFx|UW_zJiu-Py$y`)rzeuWOhr#^lDd2 z%6f!r#3$=o^XsY_rb1E)dW82_g11395;$NJtZD!9l;@$nIuJ?{&H6RHDxbzxTP@nc zb7fEBk=*v{>lUbrHWFkHWmk)-4JZNYkt&45K`VFH)=2bSN}(9Qa_QpQeKEN4K^C ziU6{PzF#H#AaMQ4;#+(WOR(uksK64F<+%yur-3D`#76+d98Jxif$tsWs|4INn(ED8 zzj;^k`pvtVH_*H*`M!AvzTdpNxQsDR9bn$4s`K2hyfW9yoKA&lkU7sTt{;v5^I1Ku z4Lxb~?PZC}-1CHo(F#^&o15)l!nrFV)}(q`dH|Xn*Pmv30Gbe|a+L+mmTK@$Z9Oqi zEsQX_W5e2)_&V729PP(fGaL_QBN4!&RgZDKmnKn4!1r;ZaFqP8|; zOzd;8nK<|f=_=tzh<=d0$OV|c4cBE-#^uvo3cjC~%E*)INbR$trQCUki-28>ugcPl z3K|SoE_5pTOwTQ6iTx#?rF?gvr*a)4o||dh%3Kf)h*j=S$}(UQFo3TwO=4@SeQBbJ zR{B=o=-Jgox2|z&NXuvoIA0yOA>=LkaL|pu=XBLnd|c7rpUOsT1f}iD#*F+bApn#z z_-Ji|p3xTJR66A?!d4Y?QBH(a8WmnUtu3|O84>yP>^cq#uAhC5ay~mA&oJ)Y@em#6 zB&al`Bcb42$3?+a!$yKwG&5cd@E%aT( za^BB2Vce5bO=ZM0rFP+cm`SjvhG}4d#%s$@*JB8+=sWw$vFtMhJ?ooloXEU#o>ksL%AKiO zHvg5VQ^~$$>N6!p9_(A;}?)DVWXAMbS&U64lbUw0ODrq(r9_%d8t z_4RNRWF*a{1HXpwWT;m)Qvl2@@68`V80sp!W%&9l-II02vbgpxZ9P6X#lzv|J8uu+ zzP8qy#^&0y`DT&h1dnoBk}E~qX#@;^Wr0~g{AGL#JV3s;aLNMzYB^foPrP9|2 zukUiDy?Wc8Y_|-b2q{k3yfvOl@jgt2bhzO-kRYHs$Yap~xo7Z8*;Ohn9B3C9;&QxNt>uRy5SR^20K9I-D!~YZk1vWmy^YMAM zg}OhcL(gKr%f3`jm$IAdbb79-LLiy@O}vl5agx((s}R&;?UeuOwi%#|Z`%xzKj60c z)pE+Vam(?3dJ>NMTI&P2Wt^+@y zTxYblA=i;Npj@w=2EK3MF<_)&xAJkMNsZM-b@Tw;r9f{zQ~mj^jXu5JzZ{tiYN>6} zljS&Fxo`T@V*zHjQJVK{mJy_WwG0n?vUTlGhXt%LLN9*Wzl^kMwl%JQHy+-BZT1lp zF>v0m^~sAxyZv>;&l&WT*sEJsiM^Klbnd`<*+$NlH}vxW;xfw^p_Kjxm0LPB#q3D43Oti6?v*E98gz-HqHYCUwft5 zUJ!W-*6l0R5#52uFqKYD2FmL=Q ze!Q=lKu^r;0xs9^}`0RUmJ&yC_^R%j& z#5QTT4HN-)@nqXmFOesfj zrm_{#J@fGA!Q(fVT515DUQR20KTG>x19m;QJMLaR-7U`;|r1rmnUUr@)!zy$q^TSsu!-Xseqh zZyn53E*|*u`P$@HCe1%o|T zG*{9=m0VUA=LRu^EluT`q0KOV^fO1STy4wre9~1yv$FFmIZiiEXi%9+{ii&B*yV;@ zh;3Y&N*KhCC#56$Lo~Rdz6}}~HVYAwZ4<1+eVaC%#rg0o_SK5$mseICw$S;kqNsSh zkoo{cAdLh$M7JHTu)MNDfq6QFP{uJuPsr?H#z>Y`Jy|#+e#j{ zSk%5T=hEweI%htIRjK28a{@Ot4I!Y!rRkY5fS7AMmp9Dh{<)lgf#X9F<qL)FR#q6u5D@w=~lkZwJ#Ib%<1;g!?g)I5GGtxc?%s` z360^yRnYmq90!$?2wo4&go^!e0zqXOYb$Y%Fuke{(QMx{*V!x|flycHm)BFEkDntT z?Zy~oAArLGHbA|4F~mkp1didW5Z`p=DB)DP^bD^H)D^yLIt?GPb}D{+j|N8l5I7#QRB-i(42gVqo+>N6peE(v z*=Hl-S*kEr7tg56mr0aow;CvoCB%O6<_OQ2U*0CtH8^8rG>~@ZwHncM7y_!j1_lF; z32k1NJ!i}ewa1NUcU@t6@$!x73dYs62r#Vi^JL1M4&32ku|U5amCx#wH`NYQN9txe zNXU%IGril2U$zqRi(jBj*ES0dqJGj+)14oLWbm71ypJBPfqa>kD%{m6Z}rZ<@N0r7 z@5x;L?A3S22;(omwhFgcI9=GYN_&hp?#Os~oQ@w){sXSI^c$PNd-6bx5ePcV_TQWI zaPrC@-!B4BAuRXKp}_g>R0^E$E}~m55=s6aIvD~aC&YXv7fyQh}h{_Ck4n3qr${RnT1SwRYBDs#jUw#KJYy z246o<-iUQ3;aO1*x1^$~rhGcP-Obx=;c}IqEJ!)Q_l7t-^J)-%@Ft`_(`C2h|4fzP`mp94!w8xd$0FMea^A@QtixMfcn2cBZ zLs29*BE-ij>eS%ZbJ@7%GgKgdR@Ph$h2hzCTrnnY}+#$(5={|IE*2CQrj9OmFlf!cRq~ytI7${G=H3Q{I8`R6gdf>1T%L?a|&5YMiu3Y@NG@o=SSnOWk z86^DJ8R(eHPi|vkFHNm#WedRk1t!jTTg-+No-ffC`_$dy3a+NEwu1Ft$b1-2e}(G_2|m@96RxqV^B zXx@1h#*R3z^jEMC=yJQ@yhi+dE6oir13i?kg=}Ua4+Sr+1Ab{a(-z=$d7h%nl=}S2 zq-tDvZ4y`Ux|mZGY^x+wSjn%N-iS-;Vvq5**bQE#3@rUBxIrw^A_9WV_>Es*9kq-I zD)uWw786N5wWl7xC_>DYF>Ia1)eGt~d&cIKirK?S!AL5J(`04cAc(+`L&vWqvhj(a zg%a-Kw1q8Bh=4M50nnnG^ina4cbiNo@qCB`mXTj9y^dJ@MfW|V_J>ATw_eB5pFy?Sso zkno`XZ;J*(F>D@wokoby6+hVO--L+gu&K!}$K|n^LRWK{qT-3m*0Y5nP+P>T1Z~$2qKg$`oKzkKF_-M6CT2-;&A{h@ z^2=LhHc({CE#(>ld^{}lCPOrW?zUvJoL^qY9X*@RT8vgYL$rNK!LdEa+Q;=-VM_>e z7v^1Ub7KR)4M^o++TvW1&918(+Zv$FMZAjmK#p4mbf_MSS14x+>^bAyfZ-6`f}&zC zn^HX)1fsM&{Gc=)tq@etK4iQ^wl91Gz754V1sEcUw>SfsfSb#Pa&5po>TmzK@n z4is}0xr!>SHc*+`fUuuJ1Mjrr5^ajG1%6oNkXbgX(-{aG={i zR!80KO52Px#Y>gU>{Rlw?s$!#u4dyVH3pAWb!iGNai2-tvL#aLGhAbJH51QlOL+B# zdW3z{hBo~BMdV37XX^|mX{_W8xNRz2>Ec{YQ~E(FtQNwFajSxFYoOV6&lWhJ5JxLz z6t;8QaBZKA{`6n(N>W}_kGvEphVt|b1jeeswbSt4w1`EsJcj4(x@8sqm&5XE^0H7( zl;!F@Sq?*B?YcX!zTb68f4;o_D6SJypWV7LkJIqi^IwM?Fi%t)Fi%{6^ydxKjwtBs zm;ZXCp9Xhn8Ll$(E=7Ku47ZE?wietZch9pRR9V24+M;6|@wo$0wk4x%i&EAtD%*AM zeV`BWGYTS){3^aiIJSbJ?WV;S2jnw91rU8<-Q;O6CJY;mMc_GpYFn*5r=wE|86*(< z0b`Tlayg!iXLr^4DkxWHIej-@?h5w;>NfJ_@{9J|`WZV%jyE&kt-g)=d}Cy^ov}0e z(cV^{-NrKLu|_g*?z>62Ip$tUW*?Vu=i0@y-N@@RHO3ZSd1f0xd8T~Wi0qRZ%6{P} zUQV8{$g#~}n}G88xf}bC2z^un=OMg|il;cBlo8TJ#7oxfCF1`0wEO*uv)XE5YkM|% z69V8sxHcIb!GT^Sl&%|Z!1Xi4S7=B$U66Al91qtp6?k9FUf^7s@|n&wxfkflJyK)x zkeB9w$F_M#>6z$a$Oy^eg%ManAjRgD@XhQ+PG%pGgjVo47vMzM3ACic&I|AkB6|-; zIh(G;H)9Yhc4^}o;Ttah-7(~Q-#Ack_#%f`M_g9N+6Z4R$k$%r$On}D#_(CW+G@Oy zQN=GKuyMQdz#GcMQA32I6=eD-pDP|e&ilp>(?y;~30o2qB>KwoxMkl&NY)nVxr{~h z@Ztr2Wupy{MTJ1 z0IV(L+dlHVRy|u*&!oWzuAfQckZ0PN=gI1s^9<2BuCe$W%#a`X5#!^MjOVGv#W-9! zr_zw79F>tq9i?G#(>wCG<-_T*=M0;U;b0@nyUOfY5N9+f)CC#e)W*KH0w8EHJY*Wf zs5n-ZtqmD~>}^=mqdWxd$BTZka*FN6o-@mH?WAaA-X<^0--M<9vgZu#+z&4_oe!_} zB||&AVp>vpRy3PSlW_jF-FGD^QUpy`K^H(&n;CYmm*v)Fv5w5* ztdA7J;VwJRMiqv~dztj*2z*}$@?6;J9OpLdmBV*<=!;*}Z&oIQqKl`Vss0hQA)0l| z$U_c!c)(Uo=@S=G-lb!;zc_5fyKwmY4qktRYW0l;4N!1N&L``qdN8ZffsMhwpVEpG zDixnW-0ia>?}S_G%|+&T1ii-T>^c!nZur>5b67rCHevSb%E`B8-{Vp6{LO2Draqu7 z7@1DH^4&9D1;@jjq8-9ZUB`3;XVd%!9Dfrnjw3??kqr?ja`C7vJLBQps4DJ0H?ps2 zusmFo0<6b@3qN6pMWW!Dqpn^kRq_zOqeB`B@%ie&TSnASjDxOWp$;FLn14A(BCp@s zy{scb^~_t{Rvo^D#hmcAI7;cX(q~}tF}#`m`i$M}kH3mOR8RhnV6kv!v%NP=y)MT zp@FsAc6s`qV8(bbJzP*IG^*OGD%sc36dW`Rw7mGnfM}n}@ym4}s+NU4TTT}sRUD}* zPQi!g`^vxnu$Fu)W0GjvR62-sd5fvg$2^f$LXmubd9epU%8$oj`0X2i+o02r25?eH zX6#e3tCW6J()~u-PzsLrldpY>w|W%)W$_AzdIdwJgSDmQCduKe13Zo-I69*|MU)WV z^!Eql36D#Vb==nw>q&c!GfID2wAXL~k#>D5xd&-a@$-YsK5dg0?wgXw=PQr42OL{v zW7ACPtU4}~9dNvuW9m3Ns?R7-TBzSVu%j5xEt!3x@&nD!fb)s|3^<=GVkjp~?guje z!z|+N?EuPSa!T=I**DBGd{#OWqjHib=vf{p5DjryDd!`Mp#y0u6T~&kX=eAWS{veA*Qf!w+ z1Vm(4tbxd52c;r1%jQnvUGDJW7JvV(nS|+Im<< zup=4wDg7ZlACJeEH2*xfBe$Cyt7o+MR-g}N;1G_v>fYSpg~I{cA^bq?WNd189GM$i z9Se;^*`#irjE(Q&dAmvtW&DCM+_EZjsBH?oJddP{N||-I+~i#1ZwenEbU5AC64|dxwI28(x>*jjgT@ zvNqX!vZ8%u+LRi+4xcv20MWjDmNv4OF5elnz=<8|KZBOjOZJu2ZvxlvTw1Py^hxM$ zj65Y~^VGmhIQkMO8&l@Gze6=16;fdoFhF6!D zBqi1L<5-A};r*<}=a=KWw+X2}$9ZoPdN}^!XYZMR^x1ocnJw;oaT@&X!zzklw$`%K zVlolwt9yjQJL>FZ2}^Mw<E>VUdw5pE&g6iy?vkEjn^P9gfuuQ>-We)skccM8en z4PYGj9+>M@WBlH&Mk0&7&)>u2jE1obXM+<91YnTT2ReM6296DqUnmU(xPwY!f_tdk zA@ZKtJK3&v&=Qai6O+qqAp8y-J43#LoG;VvtRqi2$I|&Fh#(twDfh3Xj8h#@cfBzx zqDlP{?{u*JA<6T7&=Qc&AzM39hhHmTZhU~Jc?Wq~Qs8UC=7IjUd71Ql&}rr_!Wn7QYiT-Dg3QJu7Xx&q}@+f!j~E20}S--NHGY z<`0e`dySXU>Go%B9XO9;GVh*MD2?Us;t!Sk9UK>PZfM0*8z-1kN z{>bzBV|_X9*^4ZOr%g^w)CRvFa{)JpU(G?AEMGyey2>-l7tR^W6KRIWyU^f|dfFr; zvqfN8hG+vP@j!DBbBER&T7zhoWEBEmLG~(hEI5kl%5vj^wDW@GpSg8Vq!dL0^gGei z1`UPZ734M!8(JGX4|4P69+&0$J;QWhQez|Dy>Fgc6_nm)AV70T=RWr|ok$`Z0?(ix23@Zu8jDz!uP2EuXv^S_rX4%m^uY=G+!2zqYzGSpFswLQr*P9{7T7vR(CgpXg&rZu+s+hZ(^%XKk=A$9zm5ov5 z2aHX5WNoWgs^t7BJQWMNqrtDX@WD{$VbUx(eHk%a$um2wKfK;Yg;i^ ziERB8nh3qfcPrI;)K}W$kZoXlCjMeUC{i3mxs73Q8!Mpzal}X+WinyngyJa^PZ~FF z{KSbDxRWLwef&{DCLcsgCwV@T4^Q=uKK|sf#YY!TDH?lxVexohHt)v?tQWovw)eR_ z>gN;C1p}2wGkpxID}4-wjypzvyvBwHsTizoZmegMMP=DR4(6kX1vj}2t#4~-4OUbI zao7`VtPYN5BTr+Xa#^@?{DnuSL29!2g33}!> z0WU?O1Rqv`IH2F_aTz&S+v01O^_Sb~UKt?~SiI=yhF~V?F~J#_mH&irLt~JA7|SD# z=Bbx6TwNf>gnsbx%bhQ;4f7x7fk=hr%Ert_FUms9k;NFpo?~8R5WCA`@E{qdw2kLrb-D|R(Y*dailW->8%<}S? zl!`3t`4gTY!%TfHHkrYBG=*y#U}A7a9}|SrGnz@$di?GO7#WInB7L)|id#Ok|BgSY zSg>^yUW7z_vG@J{gg0v5ruX)rm|9oflh1>&OFSEV5WpSW?om0SM3fz52bz+OJq!p zf6HNzYzG1bR?P;h^UaTk?-Nq z@cB7_H#`J{=*KhQ7f@r>6xW0#=Yu60h#9%Ry^F(A{4$D=MFY^{2gdkWhL(Y-@p=$* z_(2xB^?GyUXga)eNt(z!|a0p_u z^-b(Nh}P4k!5mLI)?!gX_s&R0K3flga|yA%Mc)W^rJ2GnF3#%<_tVrb0rR~ezV_kE zAlf`W?fbMa>xa*OSDN$--OTg2Snve$ep_cWx&qG)PVfi^_Z&yNvcP|y=gl)42eyRk zVe%mcq^=gB2WD5`JkqO3r~V43l6>{$4=`tZ&J`N`t3*ED^v*lH?_c7<-to$CT#L-~A z8(&0**Yz889$pQOD>TIUl2?xGK?tPA<|L=*byLuH&$7Ha%xMzkS?ouqDQqG7Md2cu z<^fT!zI#zX)T3uvR=DI;n9YrNnZ|pDaexQ@p`aM9bl|+F94|Yg{6zXDRC5XcI28O; zoR-r~cNT*>?ra_f7!w?alRoydJ;A)ngM*=HG@7q#nif2}@(u_uZ!108#@PrL@9^l%6!zwI+dSjYS`GP)&!U^#sf2?~*KVfJOjK;UHhIeS>j0~90st~@9R!KU+>@1%4l z;;3vJRjcs(s9>+rhr&t($PY}Uk4k7xYpU9Xyv2y22kE|oJnuO|ePk{#NkWR;a|MU(8lWE~mEURd%W0|kUBOO0#p|Io zrR?}LFsg-_am;q`*A>n*F%z>^a0VRJ^>EnIwQ$5X4a+iZ&8GJIqpiS!qa6Gt14m~3 zqw*n5KRgts6#v&TZg38z2o4$~kOUZ3c}8+D{?sD=T%J#5{`c>HGw`3zK-+xSVfg!E z$e^6ScH&Q|eAym@awb&_$|=Mjp?|@@zz%^x+Yy6u2KxI_ADlyffk3d|e|Z7_3&l`2p|0!Qj6CA4ATEMdbR|0MYTmkqC;1a;T-yuQ&ve3`1zx-k%xg-7x@b?Sy zIsj*5&r`e9=OF&h!=L;&XmA#x0}D~M?EIPM?=Ld$`iLiPyOYD&xAsuefr4{87+i$% z&)%{Ajv&wO_y4p1#Zd(UKKdV)A1lf~hVpORzVY_G0)M@|_x3+-oBp}Cu^JPG1OgM* zpRqm|n6m!N^>l;V|8Mr&>ptxH0s8A)*)yI`Yr8xCXkF)+#VDE?^D2ojDUtv}__+{-+oOLYnEfYHH~y&HGXj5wlD<+&cPVM~%`JbmlD6 z{nAxC-}ONEo}b=v6iTQ{?vP~?fd)aXKr70`Uf2i#V_AbakPe!YCo zuoUhSxAN(E*M9bL>gtsf<86hn4S)K^2U8zTeR5uO{Qdhr^v1l@$OB*e zWcicvQ2AwNr^-({_1SYDnmB9Mr>3Od`{wY=w|n~P3wQgeFf}rD=NHjCM}K+VqC-;W zEWT~y^7O1D*L-kNvhq*ctv+zlj0=9bYIfqPA7gu-T{&u8XvJb@|4ZJq&p+z=Wr3gH zi*M*G&EET=-cK*O>v!=N=Zrt%_mADsX1#w{EPU38w+?(?|K{kf)1r4>{Pc=b*57&l zUAI4~e^T@Cu)9yZweZx(bHPG`ceSVf35mmS`Xr ziX~!4#*U3mj?Ii+6DGtoZc!h4FduC*$A6{}une zGt`MYM>wA+zE1p*7@EvU4o~JLMkwK(-$YIW+9)FyiQB^U^FVT}f9ajixB zO3Mx%7%C2(5_&!KN$BU$VEq7ns@|f{(r4>$>Ff26_3!mScu06ec>i!LToIlYZVF!< zo*TY1{7m?r@ZZ8ijQtGLIKikg&NFT@9yi`L{$>m@_cKlN1gy+?=C$U7<_qRW=0D6` zBBLV5MNW?VG13}Y5VLBb&vJ3^%v_0>kszccGy17 zKFMyjud#2!tgoe?-&V9VIx{*udP($-=%1r6L_d#i#aw5_vSUMIIkDlf+}Ma% zFg7xl7aJ4PVn)o4IkAFRVXP=t94m=Uij`tL%3|qQO{^}~6l;yO$7aQX@q^=s#Z&Rp z`04Sc_$~2;@q6O|=O*WFXPNV{^R4qQXaB@Oi3y356E`JpPrRCVH}QGm$Hb829$1%S zlc!+r+cDoaChtzZo?M^&Ci!D>ht!DF0jUY8$*KBON9wZF&8d4+FJTonrh2gsn^Rj- zeW|Uq9vXZ^tVckbt#xXbYu9KufP3!L?$aIu4=vYLXe+f<+G=f$HX(F+s5&$)bV=yi z&|RTt!A+lmoBBfg=m+aD{Up6sKS#enzd~Q8KdZl}zpMWP+_ii7z_1>k5Uvi-311Sv zKKw-Z+3+jjH^Q64Tf;jUnsJ1YHl`V^#!TZz<1Vb9*V4tyc^jN>5c4e?Q4y;##qN#6RlFK z**e?0!0NPax9+tbv6g|WhTC~|(k`@5u-oj}_NDff_9OOk`&s(~`!oA1`}fhD=x))& zvBm|_@zE*K>S$xMHF{ba%Cu?H`zo~D~hlYnUUOOgyX1F6fKYUC0-tb?-ABVpLukC0I zH}*6RH7w&;V}fz9af7i65^)#vAajgqn=R&_%sE)8yCDf5HNQ89M*a}lKQbobMADJj zk=wC8e~;{J9c&$L#jUffbF7Q3%dCagv({Sc3+o%}N9$laYLB&#!MaSdTOsQ%1+$@qf?{J(TAf?MxT$aivBhF&*(4Ftl0iBJr)OlrDHR|N4H@`mc_n_ z{S-SSer&uwel=F(q4=NU{}i$<&j~pZ=QO9?nd{sR?s^2=^|kX)=O<@)B9tghoSHZz zac1JG#LbDj689xmCO%GVNo=3oIk^|4T}krP0=&(>Ml*Ss}5_$@p^#P>eme4SLq#o5%`my?S{apQGeXhPpe+X-}N?)t@ z>fd0s4h^TmCx!nQo*KR*d|!Ae`0JhUhv84dTfzaX);>lEt96Dk-MGkj)K~-F`lm6{ z)XY=OR`UvTp4n}_YQAUw0F8Bc#EcX~rbT8&E{H6GWc)C)G4i)awzU(aqh=YFZ8=r} zbXJj7Y?XkcF0;Yf>XdP%DV#n>H>{|PB`v&_d`(686`+IwE^dPKW zGFlluH+n<#*66*_*RgWLARF~qGInz8kFlw-j@X=7XKXI`>B-p3vA1IH#eRwH7!Spd ziC4sH;;rDR2jY*%m&ez~KaKas2Rl1Be{gag-HAEloFZoq_-dK+y0g~#2&*_EF)DFL zqKL`L=ER>89c(opPAp4&n)ovDyX3*i@yRoj)06X)OOu~t{YIv=)ETLU)Getev1UJ~ z0%d_fC)R9dZ8z-{tr5I*opzJgcE)9g`^Nrge1-~c9-MRl^pz2-$4WdHdo)&#(#+q zadMnP9L-5Nlblj#vQy@yojaXJo#&jlob}G9POr0FVwc2l@X)Npy@@|3zQBx+NFI

vB_IWu`KbkrS?X-_0yNd6`HQS$exogmqg;GB~o*{(|64enW%`Y`oPih@IPunxJ} zVOpVf0`$^N+CuFf?FH?1?QL+)W-TkULnuFV6s(79Lbrw@U7ZpRUO*1Yr zu7WMmZ9HW>YkX|{V2m**fLHD_UpL=8r@X4N-`4g?_nDfW1 zx2*SIJ!C=06xv5alFhKY?YrzZp8F#`8|Irw3?rBENv1XGw8$5Bp z`MmiTSa)BV+edV4RMU!;Ddwe1Q7)?sb8)ArJWkaVYO9oi+@71~nhrRTJD+TUO^ z>>C;#8WT#wI-eZs2rUTR7J3qP-@4F;u={q`_r+R|(Tm_sovi;!zd^rWf1YWkA>m=+ zy~6v2$HA+b5UvkT5C18AMfk?>BUs;F*b&UN&AgK7uvz zvk^8OtnZnScMq74n6H`t!rJZ{*&}jvH7<$ckAh zs{!`=`PRi)*(KHr>r=?RKiIkUNZW?@RDcyOvWx8!dy-vhPqxeKH00rZ!t(nFmi^cE z_R(FVdq6fOqvN6#kdEX{T@Aah8}`Pt(O05xM8AlBi~lC;^X6I#An9OjbF+vju+#v#=n9U_(OarXHTrS0a;lMtK(YdMrVohlJlDLxs#p9 zOT@9tCnw4imq1V5n7B2u6jJlK#0QDb5?{f--zm9!a_^)Gjy)1~{$xneb6|hGkX)1e zTe2_tb8>HR?ZK&7suFAdL~4EN+f<-C5LkqD-9gLIMnH0wXs2ptz~Z=Ao2zwei^0Dy zX@A##)P{xj3hfsPg^mfG5Sjs9_89DrH$%OlZ$bw_evZ@IpwBJ<2R{OP{wv{y#llC1 zPk^6%3AEZRusGI%S2u;f4gbM7%m^E&8B>f#<7#6O*7F5;&Ku!1Z!$J3elv0IG4RZ$ z!Ty+OUTR)v-V1B-EAv}(?}#3;;W3{XX^dP9fB6~Mi|gSre;*0LW;_hGN2ztXH5*#( zcIzqF9P6!*U^VV-A83!UL-5m1w*P3KV_yiX@iB1l^ROC+L=TAOfq&;<1(!#ki@qK0 zjShy7HXeT0Z1C&tvHN3Rfm^r62E|9h8xF-M$J6oJcxQYaR_(|5j?QS<7X`2sZ*rD8 zZ#eJ3Qrt7KKWvM`v0Al>hQ!ruy`F-V_%b+iFl@viY{Uv!h#ko%ldF?G$TGWsV`GM5&td0|FBM3+VU3>}b`G>0S?zzpD)nhOpk0K(=bnjWSwK)2+Qz3 zbECNl-qw$1F6{V&AX|@(lwgJGBj-mtBacL$jI4`%2k$xG(wW^sUe+S(erq+;fuCBt zVP#GLznzUWdC`8){?PtibiZgkIu@MO8GR6O3bNq$j~xW7!}E*J7t(Z9Y)$N)SV6oz z-Uj(ee$^}Sx8m=|d*Xwf?VKH*q%#p#d=2#81<-h_oG%>Gbz>7pB__I@#8+lLIO)ek zAbC(Sl(d8m-<7;6d2jN$<5 z5N~=P@r+ISu<$Bby_`U=7BtvDR^}pY^!) zjI|Q-Fl-+QJ}I~B?D?=u?y(<$rhCU;Z~qK#*&#YQ8itoO0hW4Qv?F>^^uFk;(T}4) zK;rG_Mv`X4&Vz;cHuz>c*ed&jZ>r-B@fq=1@%i!FV5dJGe>=Vj_DTpVR1drSY3DuX z1FX*8i31a3;9;GRC{3IWo4ga=E|+v05*ra~`VO(C;mLhqDTb3LCL5BMC9g`}o_qjn zv?{p?R{Fn^+o$rN-y*5m;GwT*J=O#Q3vig1rR@j)(ct?QLu>VDUufTGJB0oKzOh0D zq4A-ULluy3=Y;MFJsNriYx6Bu=9kc}`k}g}AFof;XTV0hUw;Aq?|b?`5wAERd?jqd zRj><(8zYSUnQcBBTIy=!dgEr}9^(OHDU)xnAXf1{?8C2NulE^Q=Jv4J_d?`p6s-0L zbXXCh7blu$n3ZO&*=C+?c9?U`t03`ihlhN>`Gonjxzb!?zGJS(I{wYvVg@2ZB0ECQ zjR3dhGig|eDB=l-SCvJoB4=TB&y8FP%Vt63j>vI*WmCSVCn7y`KvJxuf#dksdVa`>CSo1CC=5(toayc;XHBKAV;JJ_?S_=(Vr z=f|&%-x_}t>$4kdSRIkADe(R}oC}?9_<(OAN_kM?n8Yd2j8`OXNj#W%Ch0CKk+GkH&=KiUISVC2%=f< z>c0;UMKpg-_>*w1aWG_Rqj8OKD`LbS8Git$PJ|@A#=I5r;Wyz$42cYj>=_vk-|kds zxeLK*Hz0O@Pvo7*$C%gMto^}TA?qY?RjqY3=96^WIrjO8PCLeq7{ zZvZDe8h@5)y0Omj&gsrs&c)dEW7(cg!}6G&xD-*~ZbUSmO}quKU?aTj-Qi{LpF9Nd zc?aG>X|fzUd0Mh1c^-E1O|V8t)9ue9RF#Ou@;0pf{^p!=3$|E@sfYPI$j#J_|u{!e&>gG1S& zoe|60D-?uQ923$*HhhOdSePY{!jmC~YeEgslV`)1xF|F?baiMxqFoC^_lB0h`dl7* z4!ZMoc1F{~BFo<)w*0S9mcD}?GLJ>fYO2|6UIZz6qj`t96rRBbNX@~KY-qq?keho$ zZjOo^ib$3bi6cf*iKydpcz{{({Yd70Zv72DLBQV5&arn#bbpkcvL`Zacolfz7kjVh z!HD?Y61@wt{2gE$E=L?{FnsA36FVV#F&=Y>J()8oum#|J^#4+5`>R9OLF3;NIuF*@ zb^4w9gZc-sr3RV1n@5?)L-Jo`-efMv?)t{uEplLF63&Eb(5r_duSC|sGbM=~gRGut zO|i}dx6ZWAwH~tm3{AZj_U*^kSBN7FwdoA#0C+J;cqlp8Wfw-Tfczzk_SNWH(VwEb z!-6V=5Au0zOYBUX<;;Q%?L&<0Lg#u!WIl&v+&Qrav~N}7oWxx0nlOC-yP;X1ffw;k zazpadBy>4-7H) zHV;4)ay(|}Z1ZAh!=>h1@B(f|1pg!Gv%%ILkYB|(9Vq(r6^;$dG`(edQ+d};0 zW}Lh9VwHX$+eMtVjE_x=UC82x^J4R1+jqwn#uh zv+&FI=@&z})ai2OIrE(b@XB_E-dF&gaZlpm#1r7Mm%wN16PODyOEhjpI1}=y z&A8CG0(STl#xurShGE*UvdiEF&4`>6`G=K{J$j;jg}uLHIXcr&r8sG;0%teUIa{g= z(dJuI3sZ}5!uAe%6$OI=#aOG|;Q0l$kyx!Uu#61N*3QS-&Rne9Ja~RXz@OyTYw#;3 zg#HA7Vrgg@_-{pMB{*<3Y^1&PAS7xYy!$!&CD_-?^k*PX|Du0^6P=yHqr&6EH(`Z8 zfW?|+3^PW;`?HK%V+JB;_Zmy!`Mqy^hFJ68jUCM(bd`>XO`%y0?wy6zCZ4zrzQs4@ z-`Q#D?yz_+gS34xvLf;}&TqCuJad0Y+7od$+60cc+`7eDj7alS)=Tg$-nBlk{tC|c z&idZUhIb!4Rdsfit2w88{hs$s>r)^v3=c)8b}) z669?I&IZnhr#?Ua7%bMW;O$j9GZBLso`@zoFsq-W0wse2ld#q?_|MIdeXnSrYI%@m zyCJ?c1ydH4q75o0Cn!nueJMxcdHwc4>Wzl-f0 z2eGn2f#Cp);q`98=mU|gNT6v@pbQtzhBAMhR?E=}m^C{|D}^LZvlAUU&zXZYq!nBM zKYkHB`K36YqtiJ$n_CBuWFtH2*#b!%fFvFYNt}z79?4eP4ms$15hU>>Na8X`;yOs; zc1Yqmki=b(#0wya7eNv)WjlfP!CFLmdO{oFWp0Kf-U>;at>@^&;nM`!-Y^j7E6@w| zV)!_v`eZ$=*FYAuLK<}FosbCg^!bP%EYuh4OR$5M>njl*T7#2|4SEkwFE$}2+lRB= zEa>Q*a4zD5Bg1)NEo_9HZ~==F(s?|c#@FG@w;fSiiW7E)=Y3<~nG!9& z8Kl*65Yrq9`_9H0S^<3TNr*bvMCu|<@bl)t2cHjLpgXbzcHgqds>o{SlpaK*dlB*6 z8VOigRyH)>2rJ0WZ;BvK%dE83Zq0&CIN$1qKd=Pn11qdm)*5RaPH=j0=b#VzF&p|Z z*A60rtwHM)AZ}K|yaT#{&~A6wopu-V9v9k+?IrdycnmA;RrVTtt-ZnSK_qPxyoWxV z*=0qCLSN-ZM<5Dg;54-ur{-z+{%> zJ)ea*&OAu_#qnkFRq-{5>GVJ^ZiZ$IIN6A#=OT)p2miuGgr~?U!C6Kbq6tli_H-Z~ z+XX$)4KHH}VzMg`U04G@qX%ajo1H!7=meX|m=Y#oYH(uQj_5B*m-$S#EMbymm9`fC z^d>~1vO+nb5urTjivrl*r8uW-g5;PBsnN}3#xm#*ihGc}=w;F(@NZ;Aja~;y(GE#5 z2a=)-l41eQHkaxv^ws)0eIw4$w(8k9iw=gzgl#4dN|-dLVX~luNrL%I4lH3(U=@=A zJ%}%FMx2ZIKZkLD9^?H2#`&e-`x@|kJNUg5ygna%z6du69 z!OOYe<2>-N&G@&(EX6ro4dP?%;NDK~?|ekb7J+-0fqz%QmtP0&?FIk#L9S#P3RR{@#T1cZ!C0GtYk|B6u61bGN_(8w#&~ zWL%3o@gndi#aU~>qpjf54uwxwf=@SqOSgbWhk`>#f z21m|fXJ6fk#R@NO0VfUxAC6@H(yw#i)?{{SIQVZ2tm8s(-emAyE4Xehcy1v$ZaMgE zEx2tH@md$`L-1M_)8%>43pDjmXz7u##T;no zNzlx7(8_b5kr#lomV&QVgR3@zr?w*2I~g;ebgc$oYy?+qHL{`Ig6ytGA#~Yf@Iot#YRxwnf(w>|2iE={;{b=O1a66zK=O&%df%B8yxFN74xeR)66;8U=;UuLOy0A~thIzkD7j_Q{ z1b?G0T*IQvy@+-6G5b1)S=V{sTpL=k2$ppzv#Xn!Ro%&K>h53Fj=9W^)|eGt#BAs? zWzLiVnOV)*%w`TUi~0XQ`f&rZZ#PG_Fbg-^8VX;LwB$(K z_ai;|TcyNCcH_3s+KPxvHtgTw_6TMHkFgDA0~fNhV>&sebK@pN%4ac4c&YYHq)$ literal 0 HcmV?d00001 diff --git a/collects/srpersist/sigs.ss b/collects/srpersist/sigs.ss new file mode 100644 index 00000000..96b4210f --- /dev/null +++ b/collects/srpersist/sigs.ss @@ -0,0 +1,327 @@ +;; sigs.ss for srpersist collection + +(define-signature srpersist:odbc-1.0^ + + ; utility + + (make-length + read-length + make-indicator + read-indicator + set-indicator + read-row-status + make-buffer + read-buffer + write-buffer + + ; ODBC procedures + + alloc-connect + alloc-env + alloc-stmt + bind-col + cancel + columns + connect + data-sources + describe-col + disconnect + sql-error + exec-direct + execute + fetch + free-connect + free-env + free-stmt + get-connect-option + get-cursor-name + get-data + get-functions + get-info + get-stmt-option + get-type-info + num-result-cols + param-data + prepare + put-data + row-count + set-connect-option + set-cursor-name + set-param + set-stmt-option + special-columns + statistics + tables + transact + driver-connect + browse-connect + col-attributes + column-privileges + describe-param + extended-fetch + foreign-keys + more-results + native-sql + num-params + param-options + primary-keys + procedure-columns + procedures + set-pos + table-privileges + set-scroll-options + + ; implementation of ODBC macro + + len-binary-attr + + ; structures + + struct:sql-date + make-sql-date + sql-date? + sql-date-year + set-sql-date-year! + sql-date-month + set-sql-date-month! + sql-date-day + set-sql-date-day! + struct:sql-time + make-sql-time + sql-time? + sql-time-hour + set-sql-time-hour! + sql-time-minute + set-sql-time-minute! + sql-time-second + set-sql-time-second! + struct:sql-timestamp + make-sql-timestamp + sql-timestamp? + sql-timestamp-year + set-sql-timestamp-year! + sql-timestamp-month + set-sql-timestamp-month! + sql-timestamp-day + set-sql-timestamp-day! + sql-timestamp-hour + set-sql-timestamp-hour! + sql-timestamp-minute + set-sql-timestamp-minute! + sql-timestamp-second + set-sql-timestamp-second! + sql-timestamp-fraction + set-sql-timestamp-fraction! + + ; exceptions + + struct:exn-with-info + make-exn-with-info + exn-with-info? + exn-with-info-val + set-exn-with-info-val! + struct:exn-invalid-handle + make-exn-invalid-handle + exn-invalid-handle? + struct:exn-error + make-exn-error + exn-error? + struct:exn-need-data + make-exn-need-data + exn-need-data? + exn-need-data-val + set-exn-need-data-val! + struct:exn-still-executing + make-exn-still-executing + exn-still-executing?)) + +(define-signature srpersist:odbc-2.0^ + + ;; ODBC procedures + + ((open srpersist:odbc-1.0^) + bind-parameter + drivers)) + + +(define-signature srpersist:odbc-3.0^ + + ((open srpersist:odbc-2.0^) + + ;; utility + + read-op-parms + + ;; ODBC procedures + + alloc-handle + bind-param + bulk-operations + close-cursor + col-attribute + copy-desc + end-tran + fetch-scroll + free-handle + get-connect-attr + get-desc-field + get-desc-rec + get-diag-field + get-diag-rec + get-env-attr + get-stmt-attr + set-connect-attr + set-desc-field + set-desc-rec + set-env-attr + set-stmt-attr + + ;; structures + + struct:sql-numeric + make-sql-numeric + sql-numeric? + sql-numeric-precision + set-sql-numeric-precision! + sql-numeric-scale + set-sql-numeric-scale! + sql-numeric-sign + set-sql-numeric-sign! + sql-numeric-val + set-sql-numeric-val! + struct:sql-year-interval + make-sql-year-interval + sql-year-interval? + sql-year-interval-sign + set-sql-year-interval-sign! + sql-year-interval-year + set-sql-year-interval-year! + struct:sql-month-interval + make-sql-month-interval + sql-month-interval? + sql-month-interval-sign + set-sql-month-interval-sign! + sql-month-interval-month + set-sql-month-interval-month! + struct:sql-day-interval + make-sql-day-interval + sql-day-interval? + sql-day-interval-sign + set-sql-day-interval-sign! + sql-day-interval-day + set-sql-day-interval-day! + struct:sql-hour-interval + make-sql-hour-interval + sql-hour-interval? + sql-hour-interval-sign + set-sql-hour-interval-sign! + sql-hour-interval-hour + set-sql-hour-interval-hour! + struct:sql-minute-interval + make-sql-minute-interval + sql-minute-interval? + sql-minute-interval-sign + set-sql-minute-interval-sign! + sql-minute-interval-minute + set-sql-minute-interval-minute! + struct:sql-second-interval + make-sql-second-interval + sql-second-interval? + sql-second-interval-sign + set-sql-second-interval-sign! + sql-second-interval-second + set-sql-second-interval-second! + struct:sql-year-to-month-interval + make-sql-year-to-month-interval + sql-year-to-month-interval? + sql-year-to-month-interval-sign + set-sql-year-to-month-interval-sign! + sql-year-to-month-interval-year + set-sql-year-to-month-interval-year! + sql-year-to-month-interval-month + set-sql-year-to-month-interval-month! + struct:sql-day-to-hour-interval + make-sql-day-to-hour-interval + sql-day-to-hour-interval? + sql-day-to-hour-interval-sign + set-sql-day-to-hour-interval-sign! + sql-day-to-hour-interval-day + set-sql-day-to-hour-interval-day! + sql-day-to-hour-interval-hour + set-sql-day-to-hour-interval-hour! + struct:sql-day-to-minute-interval + make-sql-day-to-minute-interval + sql-day-to-minute-interval? + sql-day-to-minute-interval-sign + set-sql-day-to-minute-interval-sign! + sql-day-to-minute-interval-day + set-sql-day-to-minute-interval-day! + sql-day-to-minute-interval-hour + set-sql-day-to-minute-interval-hour! + sql-day-to-minute-interval-minute + set-sql-day-to-minute-interval-minute! + struct:sql-day-to-second-interval + make-sql-day-to-second-interval + sql-day-to-second-interval? + sql-day-to-second-interval-sign + set-sql-day-to-second-interval-sign! + sql-day-to-second-interval-day + set-sql-day-to-second-interval-day! + sql-day-to-second-interval-hour + set-sql-day-to-second-interval-hour! + sql-day-to-second-interval-minute + set-sql-day-to-second-interval-minute! + sql-day-to-second-interval-second + set-sql-day-to-second-interval-second! + struct:sql-hour-to-minute-interval + make-sql-hour-to-minute-interval + sql-hour-to-minute-interval? + sql-hour-to-minute-interval-sign + set-sql-hour-to-minute-interval-sign! + sql-hour-to-minute-interval-hour + set-sql-hour-to-minute-interval-hour! + sql-hour-to-minute-interval-minute + set-sql-hour-to-minute-interval-minute! + struct:sql-hour-to-second-interval + make-sql-hour-to-second-interval + sql-hour-to-second-interval? + sql-hour-to-second-interval-sign + set-sql-hour-to-second-interval-sign! + sql-hour-to-second-interval-hour + set-sql-hour-to-second-interval-hour! + sql-hour-to-second-interval-minute + set-sql-hour-to-second-interval-minute! + sql-hour-to-second-interval-second + set-sql-hour-to-second-interval-second! + struct:sql-minute-to-second-interval + make-sql-minute-to-second-interval + sql-minute-to-second-interval? + sql-minute-to-second-interval-sign + set-sql-minute-to-second-interval-sign! + sql-minute-to-second-interval-minute + set-sql-minute-to-second-interval-minute! + sql-minute-to-second-interval-second + set-sql-minute-to-second-interval-second! + + ;; exceptions + + struct:exn-no-data + make-exn-no-data + exn-no-data?)) + +(define-signature srpersist:odbc-3.5^ + + ((open srpersist:odbc-3.0^) + + struct:sql-guid + make-sql-guid + sql-guid? + sql-guid-data1 + set-sql-guid-data1! + sql-guid-data2 + set-sql-guid-data2! + sql-guid-data3 + set-sql-guid-data3! + sql-guid-data4 + set-sql-guid-data4!)) + diff --git a/collects/srpersist/srpersist.ss b/collects/srpersist/srpersist.ss new file mode 100644 index 00000000..e0988fa6 --- /dev/null +++ b/collects/srpersist/srpersist.ss @@ -0,0 +1,22 @@ +;; srpersist.ss + +(unless (defined? 'odbc-version) + (error "odbc-version not defined: should be inexact number greater than or equal to 1.0")) + +(require-library "macro.ss") +(require-library "cores.ss") +(require-library "srpersistu.ss" "srpersist") + +(cond + + [(>= odbc-version 3.5) + (require-library "invoke-3.5.ss" "srpersist")] + + [(>= odbc-version 3.0) + (require-library "invoke-3.0.ss" "srpersist")] + + [(>= odbc-version 2.0) + (require-library "invoke-2.0.ss" "srpersist")] + + [(>= odbc-version 1.0) + (require-library "invoke-1.0.ss" "srpersist")]) diff --git a/collects/srpersist/srpersistu.ss b/collects/srpersist/srpersistu.ss new file mode 100644 index 00000000..2612243e --- /dev/null +++ b/collects/srpersist/srpersistu.ss @@ -0,0 +1,67 @@ +(require-relative-library "sigs.ss") + +(define srpersist@ + + (if (defined? 'odbc-version) + + (let ([the-unit + (load-relative-extension + (string-append + (build-path + "lib" + (system-library-subpath) + (case (system-type) + [(unix) "srpmain.so"] + [(windows) "srpmain.dll"] + [(macos) "srpmain.so"] + [else (error "Unknown platform")]))))]) + + (cond + + [(>= odbc-version 3.5) + (compound-unit/sig + (import) + (link [srpersist : srpersist:odbc-3.5^ + ((unit->unit/sig + the-unit + () + srpersist:odbc-3.5^))]) + (export + (open srpersist)))] + + [(>= odbc-version 3.0) + (compound-unit/sig + (import) + (link [srpersist : srpersist:odbc-3.0^ + ((unit->unit/sig + the-unit + () + srpersist:odbc-3.0^))]) + (export + (open srpersist)))] + + [(>= odbc-version 2.0) + (compound-unit/sig + (import) + (link [srpersist : srpersist:odbc-2.0^ + ((unit->unit/sig + the-unit + () + srpersist:odbc-2.0^))]) + (export + (open srpersist)))] + + [(>= odbc-version 1.0) + (compound-unit/sig + (import) + (link [srpersist : srpersist:odbc-1.0^ + ((unit->unit/sig + the-unit + () + srpersist:odbc-1.0^))]) + (export + (open srpersist)))])) + + ; no ODBC version defined + + (error "odbc-version not defined"))) diff --git a/collects/srpersist/tutorial.txt b/collects/srpersist/tutorial.txt new file mode 100644 index 00000000..5a92799c --- /dev/null +++ b/collects/srpersist/tutorial.txt @@ -0,0 +1,185 @@ +SrPersist Tutorial +================== + +If you look at the doc.txt file in the SrPersist collection, +you soon realize that the ODBC standard is quite complex. +It is not necessary to master the standard before using it. +Performing simple data retrievals and insertions is not very +difficult. This tutorial provides some simple examples that +you can start with when writing your own code. + +This tutorial does not address issues of compiling and +installing SrPersist. See the README file in the +SrPersist source directory for such information. + +Allocating handles +------------------ + +Before you can connect to a database, you need to allocate +an environment handle, and a connection handle: + + (define henv (alloc-env) + (define hdbc (alloc-connect henv)) + +We bind these identifiers to the handle values, so that +we can refer to the handles at later points in the program. + +Getting a connection +-------------------- + +SrPersist provides three procedures to connect to a database, +two of which we mention here. + +When getting started, you can use + + (driver-connect hdbc "" 'sql-driver-prompt) + +where `hdbc' is the connection handle just allocated. +This procedure displays a dialog box, or series of them. +From the dialog boxes, you should be able to choose +the database system and a particular database to +connect to. This procedure returns a string, which +you can use in place of the empty string the next +time you need to call this procedure. The string +contains information about the database system and +database you chose through the dialogs. Using that +returned string, this procedure will not show a +dialog box. + +Alternatively, you can use + + (connect hdbc dbms name password) + +where again `hdbc' is the connection handle you've +allocated. `dbms', `name', and `password' are strings +indicating a database system (a "data source" in ODBC +parlance), a login name, and login password. Unlike +driver-connect, you have to know the name of the +database system, which may not be obvious. To find out +this information, you can call + + (data-sources henv 'sql-fetch-first) + +to get a data source name and its description. Calling +data-sources with 'sql-fetch-next gets the next data source; +you can continue making such calls until you've enumerated +all possible data sources. + +Making a statement +------------------ + +Once your program is connected to a database system, +you'll want to submit queries in the form of SQL. +Be patient, for it takes several steps to submit such +a query. + +First you'll need to allocate a statement handle +using the existing connection handle: + + (define hstmt (alloc-stmt hdbc)) + +We'll see that we can reuse this statement handle +for several SQL queries. + +When you connected to the database system, you +chose some particular database. The database system +may contain several databases. SQL has the USE statement +to choose among them. In SrPersist, we write: + + (prepare hstmt "USE test_db") + (execute hstmt) + +Note that some database systems, such as Microsoft Access, +do not allow you to switch databases in this way. You can +think of prepare as performing a compilation step; execute +runs the resulting code. + +Now suppose the database test_db contains a table +"people" that has columns for name, a string, and +age, an integer. + +We can make a query to get the desired data from the +database. + + (prepare hstmt "SELECT name,age FROM people") + (execute hstmt) + +Conceptually, the statement above creates a new table, +consisting of rows of data. We need some location +in our program to store the data. ODBC uses buffers +for data storage. SrPersist associates an ODBC C type +with each buffer. + +Assume that the name column consists of strings +no longer than 50 characters. We create a +buffer to hold results: + + (define name-buffer (make-buffer 'sql-c-char 50)) + +For the age column: + + (define age-buffer (make-buffer 'sql-c-slong 1)) + +There are ways to find out the types associated with columns, +but unfortunately, it's a complicated business. There are +actually distinct types (SQL types) for the columns themselves, +and separate C types for buffers that receive their data. +But 'sql-c-char is probably what you want for string buffers, +and 'sql-c-slong for integer buffers. + +We'll need another kind of buffer, an "indicator": + + (define name-indicator (make-indicator)) + (define age-indicator (make-indicator)) + +These indicators do not hold data, just status information. +We can safely ignore their role for the remainder of this +tutorial. + +Next, we wish to associate the buffers we've created with +the database columns: + + (bind-col hstmt 1 name-buffer name-indicator) + (bind-col hstmt 2 age-buffer age-indicator) + +Columns are numbered from 1. Although the people table +may have had the name and age at any position, our +query above created the name column as column 1, +and the age column as column 2. + +Now we can retrieve the data and print it out: + + (with-handlers + ([(lambda (exn) (exn-no-data? exn)) + (lambda (exn) (printf "** End of data **~n"))]) + (let loop () + (fetch hstmt) + (printf "Name: ~a Age: ~a~n" + (read-buffer name-buffer) + (read-buffer age-buffer)) + (loop)) + +The code loops through each row and prints the +values stored in the buffers. When all the +data has been read, the call to fetch raises +the exn-no-data exception. + +Suppose we want to insert a new record into the table people. +Assume that the table consists of the columns name, address, +and age. To perform the insertion, we simply write the +appropriate SQL, and run it: + + (prepare hstmt + (string-append "INSERT INTO people SET " + "name=\"Joe Bloggs\"," + "address=\"123 Main Street\"," + "age=42")) + (execute hstmt) + +If you now perform the SELECT query above, and run the +given loop over the results, you should see the effect +of the insertion. + +While there's much more in the ODBC standard, this example +code should give you the flavor of how it works. + diff --git a/collects/stepper/annotater.ss b/collects/stepper/annotater.ss new file mode 100644 index 00000000..08c78127 --- /dev/null +++ b/collects/stepper/annotater.ss @@ -0,0 +1,858 @@ +(unit/sig stepper:annotate^ + (import [z : zodiac:system^] + mzlib:function^ + [e : zodiac:interface^] + [utils : stepper:cogen-utils^] + stepper:marks^ + [s : stepper:model^] + stepper:shared^ + stepper:client-procs^) + + ; ANNOTATE SOURCE CODE + + ; gensyms for annotation: + + ; the mutator-gensym is used in building the mutators that go into certain marks. + ; (define mutator-gensym (gensym "mutator-")) + + ; the `closure-temp' symbol is used for the let which wraps created closures, so + ; that we can stuff them into the hash table. + + ; closure-temp: uninterned-symbol + + (define closure-temp (gensym "closure-temp-")) + + ; dual-map : (('a -> (values 'b 'c)) ('a list)) -> (values ('b list) ('c list)) + + (define (dual-map f . lsts) + (if (null? (car lsts)) + (values null null) + (let+ ([val (values a b) (apply f (map car lsts))] + [val (values a-rest b-rest) (apply dual-map f (map cdr lsts))]) + (values (cons a a-rest) (cons b b-rest))))) + + ; var-set-union takes some lists of varrefs where no element appears twice in one list, and + ; forms a new list which is the union of the sets. + + ; varref-remove* removes the varrefs in a-set from the varrefs in b-set + + (define (varref-remove* a-set b-set) + (remove* a-set + b-set + (lambda (a-var b-var) + (eq? (z:varref-var a-var) + (z:varref-var b-var))))) + + (define (varref-set-pair-union a-set b-set) + (cond [(or (eq? a-set 'all) (eq? b-set 'all)) 'all] + [else (append a-set (varref-remove* a-set b-set))])) + + (define var-set-union + (lambda args + (foldl varref-set-pair-union + null + args))) + + (define (var-set-intersect a-set b-set) + (varref-remove* (varref-remove* a-set b-set) b-set)) + + (define never-undefined? never-undefined-getter) + (define (mark-never-undefined parsed) (never-undefined-setter parsed #t)) + + (define (interlace a b) + (foldr (lambda (a b built) + (cons a (cons b built))) + null + a + b)) + + (define (closure-key-maker closure) + closure) + + ; paroptarglist-> ilist and arglist->ilist are used to recreate + ; mzscheme sexp syntax from the parsed zodiac form, so that the + ; resulting expression can be fed to mzscheme. + + + + ; debug-key: this key will be used as a key for the continuation marks. + + (define debug-key (gensym "debug-key-")) + + ; translate-varref : returns the name the varref will get in the final output + + (define (translate-varref expr) + (if (or (z:top-level-varref? expr) (not (z:parsed-back expr))) ; top level or extra-bogus varrefs + (z:varref-var expr) + (utils:get-binding-name (z:bound-varref-binding expr)))) + + ; bindings->varrefs : turn a list of bindings into a list of bogus varrefs + + (define (bindings->varrefs bindings) + (map create-bogus-bound-varref + (map z:binding-var bindings) + bindings)) + + ; make-debug-info builds the thunk which will be the mark at runtime. It contains + ; a source expression (in the parsed zodiac format) and a set of z:varref/value pairs. + ;((z:parsed (union (list-of z:varref) 'all) (list-of z:varref) (list-of z:varref) symbol) -> + ; debug-info) + + (define (make-debug-info source tail-bound free-vars label) + (let* ([kept-vars (if (eq? tail-bound 'all) + free-vars + (var-set-intersect tail-bound ; the order of these arguments is important if + ; the tail-bound varrefs don't have bindings + free-vars))] + [real-kept-vars (filter z:bound-varref? kept-vars)] + [var-clauses (map (lambda (x) + (let ([var (translate-varref x)]) + (list var x))) + real-kept-vars)]) + (make-full-mark source label var-clauses))) + + ; cheap-wrap for non-debugging annotation + + (define cheap-wrap + (lambda (zodiac body) + (let ([start (z:zodiac-start zodiac)] + [finish (z:zodiac-finish zodiac)]) + `(#%with-continuation-mark (#%quote ,debug-key) + ,(make-cheap-mark (z:make-zodiac #f start finish)) + ,body)))) + + ; wrap-struct-form + + (define (wrap-struct-form names annotated) + (let* ([arg-temps (build-list (length names) get-arg-varref)] + [arg-temp-syms (map z:varref-var arg-temps)] + [struct-proc-names (cdr names)] + [closure-records (map (lambda (proc-name) `(,make-closure-record + (#%quote ,proc-name) + (#%lambda () #f) + ,(eq? proc-name (car struct-proc-names)))) + struct-proc-names)] + [proc-arg-temp-syms (cdr arg-temp-syms)] + [setters (map (lambda (arg-temp-sym closure-record) + `(,closure-table-put! ,arg-temp-sym ,closure-record)) + proc-arg-temp-syms + closure-records)] + [full-body (append setters (list `(values ,@arg-temp-syms)))]) + `(#%let-values ((,arg-temp-syms ,annotated)) ,@full-body))) + + ; update-closure-record-name : adds a name to an existing closure table record, + ; if there is one for that value. + + (define (update-closure-record-name value name) + (let* ([closure-record (closure-table-lookup value)] + [old-name (closure-record-name closure-record)]) + (if old-name + (e:internal-error "closure-record already has a name: ~a" old-name) + (set-closure-record-name! closure-record name)))) + + + (define initial-env-package null) + + ; annotate takes + ; a) a list of zodiac:read expressions, + ; b) a list of zodiac:parsed expressions, + ; c) a list of previously-defined variables, + ; d) a break routine to be called at breakpoints, and + ; e) a boolean which indicates whether the expression is to be annotated "cheaply". + ; + ; actually, I'm not sure that annotate works for more than one expression, even though + ; it's supposed to take a whole list. I wouldn't count on it. Also, both the red-exprs + ; and break arguments may be #f, the first during a zodiac:elaboration-evaluator call, + ; the second during any non-stepper use. + + (define (annotate red-exprs parsed-exprs input-struct-proc-names break cheap-wrap?) + (local + ( + (define (make-break kind) + `(#%lambda returned-value-list + (,break (continuation-mark-set->list + (current-continuation-marks) + (#%quote ,debug-key)) + (#%quote ,kind) + returned-value-list))) + + ; wrap creates the w-c-m expression. + + (define (simple-wcm-wrap debug-info expr) + `(#%with-continuation-mark (#%quote ,debug-key) ,debug-info ,expr)) + + (define (wcm-pre-break-wrap debug-info expr) + (if break + (simple-wcm-wrap debug-info `(#%begin (,(make-break 'result-break)) ,expr)) + (simple-wcm-wrap debug-info expr))) + + (define (break-wrap expr) + (if break + `(#%begin (,(make-break 'normal)) ,expr) + expr)) + + (define (simple-wcm-break-wrap debug-info expr) + (simple-wcm-wrap debug-info (break-wrap expr))) + + (define (return-value-wrap expr) + (if break + `(#%let* ([result ,expr]) + (,(make-break 'result-break) result) + result) + expr)) + +; For Multiple Values: +; `(#%call-with-values +; (#%lambda () +; expr) +; (#%lambda result-values +; (,(make-break 'result-break) result-values) +; (#%apply #%values result-values)))) + + (define (find-read-expr expr) + (let ([offset (z:location-offset (z:zodiac-start expr))]) + (let search-exprs ([exprs red-exprs]) + (let* ([later-exprs (filter + (lambda (expr) + (<= offset (z:location-offset (z:zodiac-finish expr)))) + exprs)] + [expr + (car later-exprs)]) + (if (= offset (z:location-offset (z:zodiac-start expr))) + expr + (cond + ((z:scalar? expr) (e:static-error "starting offset inside scalar:" offset)) + ((z:sequence? expr) + (let ([object (z:read-object expr)]) + (cond + ((z:list? expr) (search-exprs object)) + ((z:vector? expr) + (search-exprs (vector->list object))) ; can source exprs be here? + ((z:improper-list? expr) + (search-exprs (search-exprs object))) ; can source exprs be here? + (else (e:static-error "unknown expression type in sequence" expr))))) + (else (e:static-error "unknown read type" expr)))))))) + + (define (struct-procs-defined expr) + (if (and (z:define-values-form? expr) + (z:struct-form? (z:define-values-form-val expr))) + (map z:varref-var (z:define-values-form-vars expr)) + null)) + + (define struct-proc-names (apply append input-struct-proc-names + (map struct-procs-defined parsed-exprs))) + + (define (non-annotated-proc? varref) + (let ([name (z:varref-var varref)]) + (or (s:check-pre-defined-var name) + (memq name struct-proc-names)))) + + ; annotate/inner takes + ; a) a zodiac expression to annotate + ; b) a list of all varrefs s.t. this expression is tail w.r.t. their bindings + ; or 'all to indicate that this expression is tail w.r.t. _all_ bindings. + ; c) a list of bound-varrefs of 'floating' variables; i.e. lexical bindings NO: TAKEN OUT + ; whose value must be captured in order to reconstruct outer expressions. + ; Necessitated by 'unit', useful for 'letrec*-values'. + ; d) a boolean indicating whether this expression will be the r.h.s. of a reduction + ; (and therefore should be broken before) + ; e) a boolean indicating whether this expression is top-level (and therefore should + ; not be wrapped, if a begin). + ; f) a boolean indicating whether this expression should receive the "cheap wrap" (aka + ; old-style aries annotation) or not. #t => cheap wrap. NOTE: THIS HAS BEEN + ; (TEMPORARILY?) TAKEN OUT/MOVED TO THE TOP LEVEL. + ; + ; it returns + ; a) an annotated s-expression + ; b) a list of varrefs for the variables which occur free in the expression + ; + ;(z:parsed (union (list-of z:varref) 'all) (list-of z:varref) bool bool -> + ; sexp (list-of z:varref)) + + (define (annotate/inner expr tail-bound pre-break? top-level?) + + (let* ([tail-recur (lambda (expr) (annotate/inner expr tail-bound #t #f))] + [define-values-recur (lambda (expr) (annotate/inner expr tail-bound #f #f))] + [non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))] + [lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))] + [let-body-recur (lambda (expr vars) (annotate/inner expr (var-set-union tail-bound vars) #t #f))] + [cheap-wrap-recur (lambda (expr) (let-values ([(ann _) (non-tail-recur expr)]) ann))] + [make-debug-info-normal (lambda (free-vars) + (make-debug-info expr tail-bound free-vars 'none))] + [make-debug-info-app (lambda (tail-bound free-vars label) + (make-debug-info expr tail-bound free-vars label))] + [wcm-wrap (if pre-break? + wcm-pre-break-wrap + simple-wcm-wrap)] + [wcm-break-wrap (lambda (debug-info expr) + (wcm-wrap debug-info (break-wrap expr)))] + [expr-cheap-wrap (lambda (annotated) (cheap-wrap expr annotated))]) + + ; find the source expression and associate it with the parsed expression + + (when (and red-exprs (not cheap-wrap?)) + (set-expr-read! expr (find-read-expr expr))) + + (cond + + ; the variable forms + + [(z:varref? expr) + (let* ([v (translate-varref expr)] + [real-v (if (z:top-level-varref? expr) + v + (z:binding-orig-name + (z:bound-varref-binding expr)))] + [maybe-undef? (or (and (z:bound-varref? expr) + (not (never-undefined? (z:bound-varref-binding expr)))) + (utils:is-unit-bound? expr))] + [truly-top-level? (and (z:top-level-varref? expr) (not (utils:is-unit-bound? expr)))] + [_ (when truly-top-level? + (utils:check-for-syntax-or-macro-keyword expr))] + [free-vars (list expr)] + [debug-info (make-debug-info-normal free-vars)] + [annotated (if (and maybe-undef? (utils:signal-undefined)) + `(#%if (#%eq? ,v ,utils:the-undefined-value) + (#%raise (,utils:make-undefined + ,(format utils:undefined-error-format real-v) + (#%current-continuation-marks) + (#%quote ,v))) + ,v) + v)]) + (values (if cheap-wrap? + (if (or (and maybe-undef? (utils:signal-undefined)) truly-top-level?) + (expr-cheap-wrap annotated) + annotated) + (wcm-break-wrap debug-info (return-value-wrap annotated))) free-vars))] + + [(z:app? expr) + (let+ ([val sub-exprs (cons (z:app-fun expr) (z:app-args expr))] + [val (values annotated-sub-exprs free-vars-sub-exprs) + (dual-map non-tail-recur sub-exprs)] + [val free-vars (apply var-set-union free-vars-sub-exprs)]) + (if cheap-wrap? + (values (expr-cheap-wrap annotated-sub-exprs) free-vars) + (let+ ([val arg-temps (build-list (length sub-exprs) get-arg-varref)] + [val arg-temp-syms (map z:varref-var arg-temps)] + [val let-clauses `((,arg-temp-syms + (#%values ,@(map (lambda (x) `(#%quote ,*unevaluated*)) arg-temps))))] + [val set!-list (map (lambda (arg-symbol annotated-sub-expr) + `(#%set! ,arg-symbol ,annotated-sub-expr)) + arg-temp-syms annotated-sub-exprs)] + [val new-tail-bound (var-set-union tail-bound arg-temps)] + [val app-debug-info (make-debug-info-app new-tail-bound arg-temps 'called)] + [val annotate-app? (let ([fun-exp (z:app-fun expr)]) + (and (z:top-level-varref? fun-exp) + (non-annotated-proc? fun-exp)))] + [val final-app (break-wrap (simple-wcm-wrap app-debug-info + (if annotate-app? + (return-value-wrap arg-temp-syms) + arg-temp-syms)))] + [val debug-info (make-debug-info-app new-tail-bound + (var-set-union free-vars arg-temps) + 'not-yet-called)] + [val let-body (wcm-wrap debug-info `(#%begin ,@set!-list ,final-app))] + [val let-exp `(#%let-values ,let-clauses ,let-body)]) + (values let-exp free-vars))))] + + [(z:struct-form? expr) + (let ([super-expr (z:struct-form-super expr)] + [raw-type (utils:read->raw (z:struct-form-type expr))] + [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) + (if super-expr + (let+ ([val (values annotated-super-expr free-vars-super-expr) + (non-tail-recur super-expr)] + [val annotated + `(#%struct + ,(list raw-type annotated-super-expr) + ,raw-fields)] + [val debug-info (make-debug-info-normal free-vars-super-expr)]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap debug-info annotated)) + free-vars-super-expr)) + (let ([annotated `(#%struct ,raw-type ,raw-fields)]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap (make-debug-info-normal null) annotated)) + null))))] + + [(z:if-form? expr) + (let+ ([val (values annotated-test free-vars-test) + (non-tail-recur (z:if-form-test expr))] + [val (values annotated-then free-vars-then) + (tail-recur (z:if-form-then expr))] + [val (values annotated-else free-vars-else) + (tail-recur (z:if-form-else expr))] + [val free-vars (var-set-union free-vars-test + free-vars-then + free-vars-else)] + [val inner-annotated `(#%if ,if-temp + ,annotated-then + ,annotated-else)] + [val annotated-2 (if (utils:signal-not-boolean) + `(#%if (#%boolean? ,if-temp) + ,inner-annotated + (#%raise (,utils:make-not-boolean + (#%format ,utils:not-boolean-error-format + ,if-temp) + (#%current-continuation-marks) + ,if-temp))) + inner-annotated)]) + (if cheap-wrap? + (values + (expr-cheap-wrap (if (utils:signal-not-boolean) + `(#%let ((,if-temp ,annotated-test)) ,annotated-2) + `(#%if ,annotated-test ,annotated-then ,annotated-else))) + free-vars) + (let+ ([val annotated `(#%begin + (#%set! ,if-temp ,annotated-test) + ,(break-wrap + (if (utils:signal-not-boolean) + `(#%if (#%boolean? ,if-temp) + ,inner-annotated + (#%raise (,utils:make-not-boolean + (#%format ,utils:not-boolean-error-format + ,if-temp) + (#%current-continuation-marks) + ,if-temp))) + inner-annotated)))] + [val if-temp-varref-list (list (create-bogus-bound-varref if-temp #f))] + + [val debug-info (make-debug-info-app (var-set-union tail-bound if-temp-varref-list) + (var-set-union free-vars if-temp-varref-list) + 'none)] + [val wcm-wrapped (wcm-wrap debug-info annotated)] + [val outer-annotated `(#%let ((,if-temp (#%quote ,*unevaluated*))) ,wcm-wrapped)]) + (values outer-annotated free-vars))))] + + [(z:quote-form? expr) + (let ([annotated `(#%quote ,(utils:read->raw (z:quote-form-expr expr)))]) + (values (if cheap-wrap? + annotated + (wcm-wrap (make-debug-info-normal null) annotated)) + null))] + + [(z:begin-form? expr) + (if top-level? + (let+ ([val bodies (z:begin-form-bodies expr)] + [val (values annotated-bodies free-vars) + (dual-map (lambda (expr) + (annotate/inner expr 'all #f #t)) + bodies)]) + (values `(#%begin ,@annotated-bodies) + (apply var-set-union free-vars))) + (let+ ([val bodies (z:begin-form-bodies expr)] + [val (values all-but-last-body last-body-list) + (list-partition bodies (- (length bodies) 1))] + [val last-body (car last-body-list)] + [val (values annotated-a free-vars-a) + (dual-map non-tail-recur all-but-last-body)] + [val (values annotated-final free-vars-final) + (tail-recur last-body)] + [val free-vars (apply var-set-union free-vars-final free-vars-a)] + [val debug-info (make-debug-info-normal free-vars)] + [val annotated `(#%begin ,@(append annotated-a (list annotated-final)))]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap debug-info annotated)) + free-vars)))] + + [(z:begin0-form? expr) + (let+ ([val bodies (z:begin0-form-bodies expr)] + [val (values annotated-bodies free-vars-lists) + (dual-map non-tail-recur bodies)] + [val free-vars (apply var-set-union free-vars-lists)] + [val debug-info (make-debug-info-normal free-vars)] + [val annotated `(#%begin0 ,@annotated-bodies)]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap debug-info annotated)) + free-vars))] + + ; gott in himmel! this transformation is complicated. Just for the record, + ; here's a sample transformation: + ;(let-values ([(a b c) e1] [(d e) e2]) e3) + ; + ;turns into + ; + ;(let-values ([(dummy1 dummy2 dummy3 dummy4 dummy5) + ; (values *undefined* *undefined* *undefined* *undefined* *undefined*)]) + ; (with-continuation-mark + ; key huge-value + ; (begin + ; (set!-values (dummy1 dummy2 dummy3) e1) + ; (set!-values (dummy4 dummy5) e2) + ; (let-values ([(a b c d e) (values dummy1 dummy2 dummy3 dummy4 dummy5)]) + ; e3)))) + ; + ; let me know if you can do it in less. + + [(z:let-values-form? expr) + (let+ ([val var-sets (z:let-values-form-vars expr)] + [val var-set-list (apply append var-sets)] + [val vals (z:let-values-form-vals expr)] + [_ (for-each utils:check-for-keyword var-set-list)] + [_ (for-each mark-never-undefined var-set-list)] + [val (values annotated-vals free-vars-vals) + (dual-map non-tail-recur vals)] + [val (values annotated-body free-vars-body) + (let-body-recur (z:let-values-form-body expr) + (bindings->varrefs var-set-list))] + [val free-vars (apply var-set-union (varref-remove* (bindings->varrefs var-set-list) free-vars-body) + free-vars-vals)]) + (if cheap-wrap? + (let ([bindings + (map (lambda (vars val) + `(,(map utils:get-binding-name vars) ,val)) + var-sets + annotated-vals)]) + (values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-vars)) + (let+ ([val dummy-var-sets + (let ([counter 0]) + (map (lambda (var-set) + (map (lambda (var) + (begin0 + (get-arg-varref counter) + (set! counter (+ counter 1)))) + var-set)) + var-sets))] + [val dummy-var-list (apply append dummy-var-sets)] + [val outer-dummy-initialization + `([,(map z:varref-var dummy-var-list) + (#%values ,@(build-list (length dummy-var-list) + (lambda (_) '(#%quote *undefined*))))])] + [val set!-clauses + (map (lambda (dummy-var-set val) + `(#%set!-values ,(map z:varref-var dummy-var-set) ,val)) + dummy-var-sets + annotated-vals)] + [val inner-transference + `([,(map utils:get-binding-name var-set-list) + (values ,@(map z:varref-var dummy-var-list))])] + ; time to work from the inside out again + [val inner-let-values + `(#%let-values ,inner-transference ,annotated-body)] + [val middle-begin + `(#%begin ,@set!-clauses ,inner-let-values)] + [val wrapped-begin + (wcm-wrap (make-debug-info-app (var-set-union tail-bound dummy-var-list) + (var-set-union free-vars dummy-var-list) + 'none) + middle-begin)] + [val whole-thing + `(#%let-values ,outer-dummy-initialization ,wrapped-begin)]) + (values whole-thing free-vars))))] + + [(z:letrec-values-form? expr) + (let+ ([val var-sets (z:letrec-values-form-vars expr)] + [val var-set-list (apply append var-sets)] + [val var-set-list-varrefs (bindings->varrefs var-set-list)] + [val var-set-list-binding-names (map utils:get-binding-name var-set-list)] + [val vals (z:letrec-values-form-vals expr)] + [_ (when (andmap z:case-lambda-form? vals) + (for-each mark-never-undefined var-set-list))] ; we could be more aggressive about this. + [_ (for-each utils:check-for-keyword var-set-list)] + [val (values annotated-vals free-vars-vals) + (dual-map non-tail-recur vals)] + [val (values annotated-body free-vars-body) + (let-body-recur (z:letrec-values-form-body expr) + var-set-list-varrefs)] + [val free-vars-inner (apply var-set-union free-vars-body free-vars-vals)] + [val free-vars-outer (varref-remove* var-set-list-varrefs free-vars-inner)]) + (if cheap-wrap? + (let ([bindings + (map (lambda (vars val) + `(,(map utils:get-binding-name vars) + ,val)) + var-sets + annotated-vals)]) + (values (expr-cheap-wrap `(#%letrec-values ,bindings ,annotated-body)) + free-vars-outer)) + (let+ ([val outer-initialization + `((,var-set-list-binding-names + (values ,@var-set-list-binding-names)))] + [val set!-clauses + (map (lambda (var-set val) + `(#%set!-values ,(map utils:get-binding-name var-set) ,val)) + var-sets + annotated-vals)] + [val middle-begin + `(#%begin ,@set!-clauses ,annotated-body)] + [val wrapped-begin + (wcm-wrap (make-debug-info-app (var-set-union tail-bound var-set-list-varrefs) + (var-set-union free-vars-inner var-set-list-varrefs) + 'none) + middle-begin)] + [val whole-thing + `(#%letrec-values ,outer-initialization ,wrapped-begin)]) + (values whole-thing free-vars-outer))))] + + [(z:define-values-form? expr) + (let+ ([val vars (z:define-values-form-vars expr)] + [val _ (map utils:check-for-keyword vars)] + [val var-names (map z:varref-var vars)] + + ; NB: this next recurrence is NOT really tail, but we cannot + ; mark define-values itself, so we mark the sub-expr as + ; if it was in tail posn (i.e., we must hold on to + ; bindings). + + [val val (z:define-values-form-val expr)] + [val (values annotated-val free-vars-val) + (define-values-recur val)] + [val free-vars (varref-remove* vars free-vars-val)]) + (cond [(and (z:case-lambda-form? val) (not cheap-wrap?)) + (values `(#%define-values ,var-names + (#%let ((,closure-temp ,annotated-val)) + (,update-closure-record-name ,closure-temp (#%quote ,(car var-names))) + ,closure-temp)) + free-vars)] + [(z:struct-form? val) + (values `(#%define-values ,var-names + ,(wrap-struct-form var-names annotated-val)) + free-vars)] + [else + (values `(#%define-values ,var-names + ,annotated-val) + free-vars)]))] + + [(z:set!-form? expr) + (utils:check-for-keyword (z:set!-form-var expr)) + (let+ ([val v (translate-varref (z:set!-form-var expr))] + [val (values annotated-body rhs-free-vars) + (non-tail-recur (z:set!-form-val expr))] + [val free-vars (var-set-union (list (z:set!-form-var expr)) rhs-free-vars)] + [val debug-info (make-debug-info-normal free-vars)] + [val annotated `(#%set! ,v ,annotated-body)]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap (make-debug-info-normal free-vars) annotated)) + free-vars))] + + [(z:case-lambda-form? expr) + (let+ ([val (values annotated-cases free-vars-cases) + (dual-map + (lambda (arglist body) + (let ([var-list (bindings->varrefs (z:arglist-vars arglist))] + [args (utils:arglist->ilist arglist)]) + (utils:improper-foreach utils:check-for-keyword args) + (utils:improper-foreach mark-never-undefined args) + (let+ ([val (values annotated free-vars) + (lambda-body-recur body)] + [val new-free-vars (varref-remove* var-list free-vars)] + [val new-annotated (list (utils:improper-map utils:get-binding-name args) + annotated)]) + (values new-annotated new-free-vars)))) + (z:case-lambda-form-args expr) + (z:case-lambda-form-bodies expr))] + [val annotated-case-lambda (cons '#%case-lambda annotated-cases)] + [val new-free-vars (apply var-set-union free-vars-cases)] + [val closure-info (make-debug-info-app 'all new-free-vars 'none)] + [val wrapped-annotated (wcm-wrap (make-debug-info-normal null) + annotated-case-lambda)] + [val hash-wrapped `(#%let ([,closure-temp ,wrapped-annotated]) + (,closure-table-put! (,closure-key-maker ,closure-temp) + (,make-closure-record + #f + ,closure-info + #f)) + ,closure-temp)]) + (values (if cheap-wrap? + annotated-case-lambda + hash-wrapped) + new-free-vars))] + + ; the annotation for w-c-m is insufficient for + ; debugging: there must be an intermediate let & set!s to + ; allow the user to see the computed values for the key and the + ; value. + + [(z:with-continuation-mark-form? expr) + (let+ ([val (values annotated-key free-vars-key) + (non-tail-recur (z:with-continuation-mark-form-key expr))] + [val (values annotated-val free-vars-val) + (non-tail-recur (z:with-continuation-mark-form-val expr))] + [val (values annotated-body free-vars-body) + (non-tail-recur (z:with-continuation-mark-form-body expr))] + [val free-vars (var-set-union free-vars-key free-vars-val free-vars-body)] + [val debug-info (make-debug-info-normal free-vars)] + [val annotated `(#%with-continuation-mark + ,annotated-key + ,annotated-val + ,annotated-body)]) + (values (if cheap-wrap? + (expr-cheap-wrap annotated) + (wcm-wrap debug-info annotated)) + free-vars))] + + [(not cheap-wrap?) + (e:static-error "cannot annotate units or classes except in cheap-wrap mode")] + + [(z:unit-form? expr) + (let+ ([val imports (z:unit-form-imports expr)] + [val exports (map (lambda (export) + (list (translate-varref (car export)) + (z:read-object (cdr export)))) + (z:unit-form-exports expr))] + [val clauses (map annotate/top-level (z:unit-form-clauses expr))]) + (for-each utils:check-for-keyword imports) + (values + `(#%unit + (import ,@(map utils:get-binding-name imports)) + (export ,@exports) + ,@clauses) + null))] + + [(z:compound-unit-form? expr) + (let ((imports (map utils:get-binding-name + (z:compound-unit-form-imports expr))) + (links (z:compound-unit-form-links expr)) + (exports (z:compound-unit-form-exports expr))) + (let + ((links + (map + (lambda (link-clause) + (let+ ([val tag (utils:read->raw (car link-clause))] + [val sub-unit (cheap-wrap-recur (cadr link-clause))] + [val imports + (map (lambda (import) + (if (z:lexical-varref? import) + (translate-varref import) + `(,(utils:read->raw (car import)) + ,(utils:read->raw (cdr import))))) + (cddr link-clause))]) + `(,tag (,sub-unit ,@imports)))) + links)) + (exports + (map + (lambda (export-clause) + `(,(utils:read->raw (car export-clause)) + (,(utils:read->raw (cadr export-clause)) + ,(utils:read->raw (cddr export-clause))))) + exports))) + (let ((e `(#%compound-unit + (import ,@imports) + (link ,@links) + (export ,@exports)))) + (values (expr-cheap-wrap e) null))))] + + [(z:invoke-unit-form? expr) + (values + (expr-cheap-wrap `(#%invoke-unit ,(cheap-wrap-recur (z:invoke-unit-form-unit expr)) + ,@(map translate-varref + (z:invoke-unit-form-variables expr)))) + null)] + + [(z:interface-form? expr) + (let ((vars (z:interface-form-variables expr))) + (for-each utils:check-for-keyword vars) + (values + (expr-cheap-wrap + `(#%interface ,(map cheap-wrap-recur + (z:interface-form-super-exprs expr)) + ,@(map utils:read->raw vars))) + null))] + + [(z:class*/names-form? expr) + (let* ([process-arg + (lambda (element) + (if (pair? element) + (and (utils:check-for-keyword (car element)) + (list (utils:get-binding-name (car element)) + (cheap-wrap-recur (cdr element)))) + (and (utils:check-for-keyword element) + (utils:get-binding-name element))))] + [paroptarglist->ilist + (lambda (paroptarglist) + (cond + ((z:sym-paroptarglist? paroptarglist) + (process-arg (car (z:paroptarglist-vars paroptarglist)))) + ((z:list-paroptarglist? paroptarglist) + (map process-arg (z:paroptarglist-vars paroptarglist))) + ((z:ilist-paroptarglist? paroptarglist) + (let loop ((vars (map process-arg + (z:paroptarglist-vars paroptarglist)))) + (if (null? (cddr vars)) + (cons (car vars) (cadr vars)) + (cons (car vars) (loop (cdr vars)))))) + (else + (e:internal-error paroptarglist + "Given to paroptarglist->ilist"))))]) + (values + (expr-cheap-wrap + `(#%class*/names + (,(utils:get-binding-name (z:class*/names-form-this expr)) + ,(utils:get-binding-name (z:class*/names-form-super-init expr))) + ,(cheap-wrap-recur (z:class*/names-form-super-expr expr)) + ,(map cheap-wrap-recur (z:class*/names-form-interfaces expr)) + ,(paroptarglist->ilist (z:class*/names-form-init-vars expr)) + ,@(map + (lambda (clause) + (cond + ((z:public-clause? clause) + `(public + ,@(map (lambda (internal export expr) + `((,(utils:get-binding-name internal) + ,(utils:read->raw export)) + ,(cheap-wrap-recur expr))) + (z:public-clause-internals clause) + (z:public-clause-exports clause) + (z:public-clause-exprs clause)))) + ((z:override-clause? clause) + `(override + ,@(map (lambda (internal export expr) + `((,(utils:get-binding-name internal) + ,(utils:read->raw export)) + ,(cheap-wrap-recur expr))) + (z:override-clause-internals clause) + (z:override-clause-exports clause) + (z:override-clause-exprs clause)))) + ((z:private-clause? clause) + `(private + ,@(map (lambda (internal expr) + `(,(utils:get-binding-name internal) + ,(cheap-wrap-recur expr))) + (z:private-clause-internals clause) + (z:private-clause-exprs clause)))) + ((z:inherit-clause? clause) + `(inherit + ,@(map (lambda (internal inherited) + `(,(utils:get-binding-name internal) + ,(utils:read->raw inherited))) + (z:inherit-clause-internals clause) + (z:inherit-clause-imports clause)))) + ((z:rename-clause? clause) + `(rename + ,@(map (lambda (internal import) + `(,(utils:get-binding-name internal) + ,(utils:read->raw import))) + (z:rename-clause-internals clause) + (z:rename-clause-imports clause)))) + ((z:sequence-clause? clause) + `(sequence + ,@(map cheap-wrap-recur + (z:sequence-clause-exprs clause)))))) + (z:class*/names-form-inst-clauses expr)))) + null))] + + [else + (print-struct #t) + (e:internal-error + expr + "stepper:annotate/inner: unknown object to annotate, ~a~n" + expr)]))) + + (define (annotate/top-level expr) + (let-values ([(annotated dont-care) + (annotate/inner expr 'all #f #t)]) + annotated))) + + ; body of local + + (let* ([annotated-exprs (map (lambda (expr) + (annotate/top-level expr)) + parsed-exprs)]) + (values annotated-exprs + struct-proc-names))))) + diff --git a/collects/stepper/break.ss b/collects/stepper/break.ss new file mode 100644 index 00000000..c8dd6cdf --- /dev/null +++ b/collects/stepper/break.ss @@ -0,0 +1,26 @@ +(unit/sig (break) + (import [mred : mred^] + [marks : stepper:marks^] + [annotate : stepper:annotate^]) + + (define drscheme-eventspace (mred:current-eventspace)) + (define break-semaphore (make-semaphore)) + (define break-resume-value #f) + + (define (break) + (let ([break-info (continuation-mark-set->list (current-continuation-marks) + annotate:debug-key)]) + (parameterize + ([mred:current-eventspace drscheme-eventspace]) + (mred:queue-callback + (lambda () + (current-namespace (make-namespace)) + (global-defined-value 'break-info break-info) + (global-defined-value 'break-resume (lambda (val) + (set! break-resume-value val) + (semaphore-post break-semaphore))) + (global-defined-value 'expose-mark marks:expose-mark) + (global-defined-value 'display-mark marks:display-mark) + (mred:graphical-read-eval-print-loop))) + (semaphore-wait break-semaphore) + break-resume-value)))) \ No newline at end of file diff --git a/collects/stepper/client-procs.ss b/collects/stepper/client-procs.ss new file mode 100644 index 00000000..85d73fa4 --- /dev/null +++ b/collects/stepper/client-procs.ss @@ -0,0 +1,14 @@ +(unit/sig stepper:client-procs^ + (import [z : zodiac:system^]) + + (define (make-client-pair name) + (let-values ([(getter setter) (z:register-client name (lambda () #f))]) + (values + (lambda (parsed) (getter (z:parsed-back parsed))) + (lambda (parsed n) (setter (z:parsed-back parsed) n))))) + + (define-values (never-undefined-getter never-undefined-setter) + (make-client-pair 'maybe-undefined)) + + (define-values (read-getter read-setter) + (make-client-pair 'read))) \ No newline at end of file diff --git a/collects/stepper/debug-wrapper.ss b/collects/stepper/debug-wrapper.ss new file mode 100644 index 00000000..73d9634f --- /dev/null +++ b/collects/stepper/debug-wrapper.ss @@ -0,0 +1,40 @@ +(unit/sig plt:aries-no-break^ + (import [zodiac : zodiac:system^] + [utils : stepper:cogen-utils^] + [marks : stepper:marks^] + [annotate : stepper:annotate^]) + + (define w-c-m-key annotate:debug-key) + + (define current-environments #f) + + (define (annotate sexp zodiac-read) + (let-values + ([(annotateds new-envs) + (annotate:annotate (and zodiac-read (list zodiac-read)) + (list sexp) + current-environments + #f + #t)]) + (set! current-environments new-envs) + (car annotateds))) + + (define (extract-zodiac-location mark-set) + (let ([mark-list (continuation-mark-set->list mark-set annotate:debug-key)]) + (if (null? mark-list) + #f + (marks:mark-source (car mark-list))))) + + (define (make-zodiac-mark location) + (marks:make-cheap-mark location)) + + (define signal-not-boolean utils:signal-not-boolean) + (define signal-undefined utils:signal-undefined) + + ; initialization --- should be called once per execute + ; (except that (2000-02-20) it doesn't matter anyway because + ; these environments are totally irrelevant to non-stepper + ; use of the annotater. + (set! current-environments annotate:initial-env-package)) + + \ No newline at end of file diff --git a/collects/stepper/doc.txt b/collects/stepper/doc.txt new file mode 100644 index 00000000..7829a9f7 --- /dev/null +++ b/collects/stepper/doc.txt @@ -0,0 +1,37 @@ +What is the _Foot_? +What is the _Stepper_? + +The Foot is a "stepper," which means that it proceeds through the +evaluation of a set of definitions and expressions, one step at a time. +This evaluation shows the user how DrScheme evaluates expressions and +definitions, and can help in debugging programs. Currently, the Foot is +available only in the "Beginner" language level. + +How do I use the Foot? + +The Foot operates on the contents of the frontmost DrScheme window. A click +on the "Step" button brings up the stepper window. The stepper window has +three boxes; each one is separated by a blue horizontal line. + +The first box shows definitions and expressions whose evaluation is +complete. This box is changed only when another completed evaluation's +result is added to it. + +The second box shows the current expression. The region highlighted in +green is known as the "redex". You may pronounce this word in any way you +want. It is short for "reducible expression," and it is the expression +which is the next to be simplified. + +The third box shows the result of the reduction. The region highlighted +in purple is the new expression which is substituted for the green one as +a result of the reduction. + +For more information on how DrScheme selects a "redex" and how the +expressions are reduced, please see The Beginner Language Semantics +which formally specify the set of rules governing the language's evaluation. + +There are three buttons at the top of the stepper window. The "Home" +button returns to the initial state of the evaluation: id est, no +expressions have yet been evaluated. The "Previous" button returns to the +prior step of the evaluation. The "Next" step shows the next step in the +evaluation. diff --git a/collects/stepper/fake-model.ss b/collects/stepper/fake-model.ss new file mode 100644 index 00000000..2d0d9697 --- /dev/null +++ b/collects/stepper/fake-model.ss @@ -0,0 +1,19 @@ +; this is an icky hack: the annotater wants to know whether procedures are primitives; +; if they are, it wraps their applications with return-value breaks. For the purposes +; of the debugger, it doesn't matter, since no breaks are really inserted anyway. +; So this unit is a complete farce. + +(unit/sig stepper:model^ + (import) + + (define check-pre-defined-var + (lambda (ignored) #f)) + + (define check-global-defined 'fake) + (define global-lookup 'fake) + (define constructor-style-printing? 'fake) + (define abbreviate-cons-as-list? 'fake) + (define user-cons? 'fake) + (define user-vector? 'fake) + (define image? 'fake) + (define print-convert 'fake)) \ No newline at end of file diff --git a/collects/stepper/info.ss b/collects/stepper/info.ss new file mode 100644 index 00000000..dcbbde1e --- /dev/null +++ b/collects/stepper/info.ss @@ -0,0 +1,7 @@ +(lambda (request failure) + (case request + [(name) "stepper"] + [(compile-prefix) '(begin (require-library "sig.ss" "stepper") + (require-library "drsig.ss" "drscheme"))] + [(compile-omit-files) '("test.ss" "testr.ss" "sig.ss")] + [else (failure)])) \ No newline at end of file diff --git a/collects/stepper/instance.ss b/collects/stepper/instance.ss new file mode 100644 index 00000000..191cd60d --- /dev/null +++ b/collects/stepper/instance.ss @@ -0,0 +1,46 @@ +; stepper-instance + +(compound-unit/sig + (import (model-input : stepper:model-input^) + (core : mzlib:core^) + (error : zodiac:interface^) + (print-convert : mzlib:print-convert^) + (drscheme : drscheme:export^) + (zodiac : zodiac:system^) + (zcp : stepper:client-procs^) + (shared : stepper:shared^) + (mred : mred^) + (utils : stepper:cogen-utils^) + (marks : stepper:marks^)) + (link [stepper-annotate : stepper:annotate^ + ((require-library-unit/sig "annotater.ss" "stepper") + zodiac + (core function) + error + utils + marks + stepper + shared + zcp)] + [reconstruct : stepper:reconstruct^ + ((require-library-unit/sig "reconstructr.ss" "stepper") + zodiac + (core function) + error + utils + (drscheme basis) + marks + stepper + shared)] + [stepper : stepper:model^ + ((require-library-unit/sig "model.ss" "stepper") + model-input + mred + zodiac + drscheme + print-convert + error + stepper-annotate + reconstruct + shared)]) + (export)) diff --git a/collects/stepper/link-jr.ss b/collects/stepper/link-jr.ss new file mode 100644 index 00000000..112fa737 --- /dev/null +++ b/collects/stepper/link-jr.ss @@ -0,0 +1,42 @@ +(compound-unit/sig + (import (core : mzlib:core^) + (zodiac : zodiac:system^) + (error : zodiac:interface^)) + (link [pretty : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))] + [client-procs : stepper:client-procs^ + ((require-library-unit/sig "client-procs.ss" "stepper") + zodiac)] + [marks : stepper:marks^ + ((require-library-unit/sig "marks.ss" "stepper") + zodiac + client-procs + (core function))] + [utils : stepper:cogen-utils^ + ((require-library-unit/sig "utils.ss" "stepper") + zodiac + error)] + [shared : stepper:shared^ ((require-library-unit/sig "sharedr.ss" "stepper") + zodiac + error + client-procs)] + [fake-stepper : stepper:model^ + ((require-library-unit/sig "fake-model.ss" "stepper"))] + [annotate : stepper:annotate^ + ((require-library-unit/sig "annotater.ss" "stepper") + zodiac + (core function) + error + utils + marks + fake-stepper + shared + client-procs)] + [debug-wrapper : plt:aries-no-break^ + ((require-library-unit/sig "debug-wrapper.ss" "stepper") + zodiac + utils + marks + annotate)] + [break : (break) + ((unit/sig (break) (import) (define break (lambda () #f))))]) + (export (open debug-wrapper) (open break))) \ No newline at end of file diff --git a/collects/stepper/link.ss b/collects/stepper/link.ss new file mode 100644 index 00000000..652740e0 --- /dev/null +++ b/collects/stepper/link.ss @@ -0,0 +1,72 @@ +; link.ss + +(compound-unit/sig + (import (core : mzlib:core^) + (framework : framework^) + (print-convert : mzlib:print-convert^) + (mred : mred^) + (drscheme : drscheme:export^) + (zodiac : zodiac:system^) + (error : zodiac:interface^)) + (link [pretty : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))] + [client-procs : stepper:client-procs^ + ((require-library-unit/sig "client-procs.ss" "stepper") + zodiac)] + [marks : stepper:marks^ + ((require-library-unit/sig "marks.ss" "stepper") + zodiac + client-procs + (core function))] + [utils : stepper:cogen-utils^ + ((require-library-unit/sig "utils.ss" "stepper") + zodiac + error)] + [shared : stepper:shared^ ((require-library-unit/sig "sharedr.ss" "stepper") + zodiac + error + client-procs)] + [fake-stepper : stepper:model^ + ((require-library-unit/sig "fake-model.ss" "stepper"))] + [annotate : stepper:annotate^ + ((require-library-unit/sig "annotater.ss" "stepper") + zodiac + (core function) + error + utils + marks + fake-stepper + shared + client-procs)] + [debug-wrapper : plt:aries-no-break^ + ((require-library-unit/sig "debug-wrapper.ss" "stepper") + zodiac + utils + marks + annotate)] + [break : (break) + ((require-library-unit/sig "break.ss" "stepper") + mred + marks + annotate)] + [stepper-view-controller : (stepper-go) + ((require-library-unit/sig "view-controller.ss" "stepper") + core + error + zodiac + client-procs + pretty + mred + drscheme + print-convert + framework + shared + utils + marks)] + [stepper-startup : () + ((require-library-unit/sig "startup.ss" "stepper") + core + mred + framework + drscheme + stepper-view-controller)]) + (export (open debug-wrapper) (open break))) diff --git a/collects/stepper/marks.ss b/collects/stepper/marks.ss new file mode 100644 index 00000000..85daf4d4 --- /dev/null +++ b/collects/stepper/marks.ss @@ -0,0 +1,84 @@ +(unit/sig stepper:marks^ + (import [z : zodiac:system^] + [cp : stepper:client-procs^] + mzlib:function^) + + (define (make-full-mark location label bindings) + `(#%lambda () (#%list ,location (#%quote ,label) ,@(apply append bindings)))) + + (define (make-cheap-mark location) + location) + + (define (cheap-mark? mark) + (z:zodiac? mark)) + + (define (cheap-mark-source mark) + mark) + + (define (mark-source mark) + (if (cheap-mark? mark) + (cheap-mark-source mark) + (car (mark)))) + + (define (mark-bindings mark) + (letrec ([pair-off + (lambda (lst) + (cond [(null? lst) null] + [(null? (cdr lst)) (error 'mark-bindings "uneven number of vars and bindings")] + [else (cons (list (car lst) (cadr lst)) (pair-off (cddr lst)))]))]) + (pair-off (cddr (mark))))) + + (define (mark-label mark) + (cadr (mark))) + + (define (mark-binding-value mark-binding) + (car mark-binding)) + + (define (mark-binding-varref mark-binding) + (cadr mark-binding)) + + (define (original-name varref) + (if (z:top-level-varref? varref) + (z:varref-var varref) + (let ([binding (z:bound-varref-binding varref)]) + (if binding + (z:binding-orig-name binding) + (z:varref-var varref))))) ; this happens for application temps + + (define (expose-mark mark) + (let ([source (mark-source mark)] + [label (mark-label mark)] + [bindings (mark-bindings mark)]) + (list source + label + (map (lambda (binding) + (list (original-name (mark-binding-varref binding)) + (mark-binding-value binding))) + bindings)))) + + (define (display-mark mark) + (let ([exposed (expose-mark mark)]) + (printf "source: ~a~n" (let ([read (cp:read-getter (car exposed))]) + (and read + (z:sexp->raw read)))) + (printf "label: ~a~n" (cadr exposed)) + (printf "bindings:~n") + (for-each (lambda (binding-pair) + (printf " ~a : ~a~n" (car binding-pair) (cadr binding-pair))) + (caddr exposed)))) + + (define (find-var-binding mark-list var) + (if (null? mark-list) + ; must be a primitive + (error 'find-var-binding "variable not found in environment: ~a" var) + ; (error var "no binding found for variable.") + (let* ([bindings (mark-bindings (car mark-list))] + [matches (filter (lambda (mark-var) + (eq? var (z:varref-var (mark-binding-varref mark-var)))) + bindings)]) + (cond [(null? matches) + (find-var-binding (cdr mark-list) var)] + [(> (length matches) 1) + (error 'find-var-binding "more than one variable binding found for var: ~a" var)] + [else ; (length matches) = 1 + (car matches)]))))) diff --git a/collects/stepper/model.ss b/collects/stepper/model.ss new file mode 100644 index 00000000..9ada3efe --- /dev/null +++ b/collects/stepper/model.ss @@ -0,0 +1,271 @@ +(unit/sig stepper:model^ + (import [i : stepper:model-input^] + mred^ + [z : zodiac:system^] + [d : drscheme:export^] + [p : mzlib:print-convert^] + [e : zodiac:interface^] + [a : stepper:annotate^] + [r : stepper:reconstruct^] + stepper:shared^) + + (define image? i:image?) + + (define (send-to-other-eventspace eventspace thunk) + (parameterize ([current-eventspace eventspace]) + (queue-callback thunk))) + + (define drscheme-eventspace (current-eventspace)) + + (define (send-to-drscheme-eventspace thunk) + (send-to-other-eventspace drscheme-eventspace thunk)) + + (define par-constructor-style-printing #f) + (define (constructor-style-printing?) + par-constructor-style-printing) + + (define par-abbreviate-cons-as-list #f) + (define (abbreviate-cons-as-list?) + par-abbreviate-cons-as-list) + + (define par-cons #f) + (define (user-cons? val) + (eq? val par-cons)) + + (define par-vector #f) + (define (user-vector? val) + (eq? val par-vector)) + + (define user-pre-defined-vars #f) + + (define (check-pre-defined-var identifier) + (memq identifier user-pre-defined-vars)) + + (define user-namespace #f) + + (define (check-global-defined identifier) + (with-handlers + ([exn:variable? (lambda args #f)]) + (global-lookup identifier) + #t)) + + (define (global-lookup identifier) + (parameterize ([current-namespace user-namespace]) + (global-defined-value identifier))) + + (define finished-exprs null) + + (define current-expr #f) + (define packaged-envs a:initial-env-package) + + (define user-eventspace (make-eventspace)) + + ;; user eventspace management + + ; here's how this stuff works. To prevent the processing of any old events + ; on the user's eventspace queue, suspend-user-computation basically sits + ; on the thread. The only way to get anything done on this thread is to + ; release the stepper-semaphore, either with a command of 'step, which + ; allows the user-eventspace thread to return to whatever it was doing + ; when it was suspended, or with a thunk command, in which case the + ; user eventspace thread goes and executes that thunk before resuming + ; waiting. The stepper-command-waiting semaphore is used to prevent + ; stacked requests from demolishing each other. It might be better to + ; use a queue for this. + + (define stepper-semaphore (make-semaphore)) + (define stepper-command-waiting-semaphore (make-semaphore)) + (semaphore-post stepper-command-waiting-semaphore) + (define stepper-return-val-semaphore (make-semaphore)) + (define stepper-awaken-arg #f) + (define eval-depth 0) + + (define (suspend-user-computation) + (semaphore-wait stepper-semaphore) + (let ([local-awaken-arg stepper-awaken-arg]) + (semaphore-post stepper-command-waiting-semaphore) + (cond + [(eq? local-awaken-arg 'step) + (void)] + [(procedure? local-awaken-arg) + (set! eval-depth (+ eval-depth 1)) + (local-awaken-arg) + (set! eval-depth (- eval-depth 1)) + (suspend-user-computation)] + [else (e:internal-error "unknown value in stepper-awaken-arg.")]))) + + (define (continue-user-computation) + (semaphore-wait stepper-command-waiting-semaphore) + (set! stepper-awaken-arg 'step) + (semaphore-post stepper-semaphore)) + + (define (send-to-user-eventspace thunk) + (semaphore-wait stepper-command-waiting-semaphore) + (set! stepper-awaken-arg thunk) + (semaphore-post stepper-semaphore)) + + ;; start user thread going + (send-to-other-eventspace + user-eventspace + suspend-user-computation) + + (define user-primitive-eval #f) + (define user-vocabulary #f) + + (define reader + (z:read i:text-stream + (z:make-location 1 1 0 "stepper-text"))) + + (send-to-user-eventspace + (lambda () + (set! user-primitive-eval (current-eval)) + (d:basis:initialize-parameters (make-custodian) i:settings) + (set! user-namespace (current-namespace)) + (set! user-pre-defined-vars (map car (make-global-value-list))) + (set! user-vocabulary (d:basis:current-vocabulary)) + (set! par-constructor-style-printing (p:constructor-style-printing)) + (set! par-abbreviate-cons-as-list (p:abbreviate-cons-as-list)) + (set! par-cons (global-defined-value 'cons)) + (set! par-vector (global-defined-value 'vector)) + (semaphore-post stepper-return-val-semaphore))) + (semaphore-wait stepper-return-val-semaphore) + + (define print-convert + (let ([print-convert-result 'not-a-real-value]) + (lambda (val) + (send-to-user-eventspace + (lambda () + (set! print-convert-result + (parameterize ([p:current-print-convert-hook + (lambda (v basic-convert sub-convert) + (if (image? v) + v + (basic-convert v)))]) + (p:print-convert val))) + (semaphore-post stepper-return-val-semaphore))) + (semaphore-wait stepper-return-val-semaphore) + print-convert-result))) + + (define (read-next-expr) + (send-to-user-eventspace + (lambda () + (let/ec k + (let ([exception-handler (make-exception-handler k)]) + (d:interface:set-zodiac-phase 'reader) + (let* ([new-expr (with-handlers + ((exn:read? exception-handler)) + (reader))]) + (if (z:eof? new-expr) + (begin + (send-to-drscheme-eventspace + (lambda () + (i:receive-result (make-finished-result finished-exprs)))) + 'finished) + (let* ([new-parsed (if (z:eof? new-expr) + #f + (begin + (d:interface:set-zodiac-phase 'expander) + (with-handlers + ((exn:syntax? exception-handler)) + (z:scheme-expand new-expr 'previous user-vocabulary))))]) + (let*-values ([(annotated-list envs) (a:annotate (list new-expr) (list new-parsed) packaged-envs break #f)] + [(annotated) (car annotated-list)]) + (set! packaged-envs envs) + (set! current-expr new-parsed) + (check-for-repeated-names new-parsed exception-handler) + (current-exception-handler exception-handler) + (let ([expression-result + (user-primitive-eval annotated)]) + (send-to-drscheme-eventspace + (lambda () + (add-finished-expr expression-result) + (read-next-expr))))))))))))) + + (define (check-for-repeated-names expr exn-handler) + (with-handlers + ([exn:user? exn-handler] + [exn:syntax? exn-handler]) + (when (z:define-values-form? expr) + (for-each (lambda (name) + (when (check-global-defined name) + (e:static-error expr + "name is already bound: ~s" name))) + (map z:varref-var (z:define-values-form-vars expr)))))) + + (define (add-finished-expr expression-result) + (let ([reconstructed (r:reconstruct-completed current-expr expression-result)]) + (set! finished-exprs (append finished-exprs (list reconstructed))))) + + (define held-expr no-sexp) + (define held-redex no-sexp) + + (define (break mark-list break-kind returned-value-list) + (let ([reconstruct-helper + (lambda (finish-thunk) + (send-to-drscheme-eventspace + (lambda () + (let* ([reconstruct-pair + (r:reconstruct-current current-expr + mark-list + break-kind + returned-value-list)] + [reconstructed (car reconstruct-pair)] + [redex (cadr reconstruct-pair)]) + (finish-thunk reconstructed redex)))))]) + (case break-kind + [(normal) + (when (not (r:skip-redex-step? mark-list)) + (reconstruct-helper + (lambda (reconstructed redex) + (set! held-expr reconstructed) + (set! held-redex redex) + (continue-user-computation))) + (suspend-user-computation))] + [(result-break) + (when (if (not (null? returned-value-list)) + (not (r:skip-redex-step? mark-list)) + (and (not (eq? held-expr no-sexp)) + (not (r:skip-result-step? mark-list)))) + (reconstruct-helper + (lambda (reconstructed reduct) +; ; this invariant (contexts should be the same) +; ; fails in the presence of unannotated code. For instance, +; ; currently (map my-proc (cons 3 empty)) goes to +; ; (... ...), where the context of the first one is +; ; empty and the context of the second one is (... ...). +; ; so, I'll just disable this invariant test. +; (when (not (equal? reconstructed held-expr)) +; (e:internal-error 'reconstruct-helper +; "pre- and post- redex/uct wrappers do not agree:~nbefore: ~a~nafter~a" +; held-expr reconstructed)) + (let ([result (make-before-after-result finished-exprs + held-expr + held-redex + reconstructed + reduct)]) + (set! held-expr no-sexp) + (set! held-redex no-sexp) + (i:receive-result result)))) + (suspend-user-computation))]))) + + (define (handle-exception exn) + (if held-expr + (i:receive-result (make-before-error-result finished-exprs held-expr held-redex (exn-message exn))) + (i:receive-result (make-error-result finished-exprs (exn-message exn))))) + + (define (make-exception-handler k) + (lambda (exn) + (send-to-drscheme-eventspace + (lambda () + (handle-exception exn))) + (k))) + + ; start the ball rolling with a "fake" user computation + (send-to-user-eventspace + (lambda () + (suspend-user-computation) + (send-to-drscheme-eventspace + read-next-expr))) + + ; result of invoking stepper-instance : (->) + continue-user-computation) \ No newline at end of file diff --git a/collects/stepper/reconstructr.ss b/collects/stepper/reconstructr.ss new file mode 100644 index 00000000..9c0e907d --- /dev/null +++ b/collects/stepper/reconstructr.ss @@ -0,0 +1,557 @@ +(unit/sig stepper:reconstruct^ + (import [z : zodiac:system^] + mzlib:function^ + [e : zodiac:interface^] + [utils : stepper:cogen-utils^] + [b : plt:basis^] + stepper:marks^ + [s : stepper:model^] + stepper:shared^) + + (define nothing-so-far (gensym "nothing-so-far-")) + + (define memoized-read->raw + (let ([table (make-hash-table-weak)]) + (lambda (read) + (or (hash-table-get table read (lambda () #f)) + (let ([raw (z:sexp->raw read)]) + (hash-table-put! table read raw) + raw))))) + + (define (make-apply-pred-to-raw pred) + (lambda (expr) + (pred (memoized-read->raw (expr-read expr))))) + + (define (make-check-raw-first-symbol symbol) + (make-apply-pred-to-raw + (lambda (raw) + (and (pair? raw) + (eq? (car raw) symbol))))) + + (define comes-from-define? + (make-check-raw-first-symbol 'define)) + + (define comes-from-define-procedure? + (make-apply-pred-to-raw + (lambda (raw) (and (pair? raw) + (eq? (car raw) 'define) + (pair? (cadr raw)))))) + + (define comes-from-lambda-defined-procedure? + (make-apply-pred-to-raw + (lambda (raw) (and (pair? raw) + (eq? (car raw) 'define) + (pair? (caddr raw)) + (eq? (caaddr raw) 'lambda))))) + + (define comes-from-define-struct? + (make-check-raw-first-symbol 'define-struct)) + + (define comes-from-cond? + (make-check-raw-first-symbol 'cond)) + + (define comes-from-lambda? + (make-check-raw-first-symbol 'lambda)) + + (define comes-from-case-lambda? + (make-check-raw-first-symbol 'case-lambda)) + + (define comes-from-and? + (make-check-raw-first-symbol 'and)) + + (define comes-from-or? + (make-check-raw-first-symbol 'or)) + + (define (rectify-value val) + (let ([closure-record (closure-table-lookup val (lambda () #f))]) + (cond + [closure-record + (or (closure-record-name closure-record) + (let ([mark (closure-record-mark closure-record)]) + (o-form-case-lambda->lambda + (rectify-source-expr (mark-source mark) (list mark) null))))] + [else + (s:print-convert val)]))) + + (define (o-form-case-lambda->lambda o-form) + (cond [(eq? (car o-form) 'lambda) + o-form] + [else ; o-form = case-lambda + (let ([args (caadr o-form)] + [body-exps (cdr (cadr o-form))]) + `(lambda ,args ,@body-exps))])) + + (define (o-form-lambda->define o-form name) + (let ([args (cadr o-form)] + [body-exps (cddr o-form)]) + `(define (,name ,@args) ,@body-exps))) + + (define (final-mark-list? mark-list) + (and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final))) + + (define continuation? + (let ([r (regexp "#")]) + (lambda (k) + (let ([p (open-output-string)]) + (display k p) + (not (not (regexp-match r (get-output-string p)))))))) + + (define (skip-result-step? mark-list) + (in-inserted-else-clause mark-list)) + + (define (skip-redex-step? mark-list) + (and (pair? mark-list) + (let ([expr (mark-source (car mark-list))]) + (or (and (z:varref? expr) + (or (z:bound-varref? expr) + (let ([var (z:varref-var expr)]) + (with-handlers + ([exn:variable? (lambda args #f)]) + (or (and (s:check-pre-defined-var var) + (or (procedure? (s:global-lookup var)) + (eq? var 'empty))) + (let ([val (if (z:top-level-varref? expr) + (s:global-lookup var) + (find-var-binding mark-list var))]) + (and (procedure? val) + (not (continuation? val)) + (eq? var + (closure-record-name + (closure-table-lookup val (lambda () #f))))))))))) + (and (z:app? expr) + (let ([fun-val (mark-binding-value + (find-var-binding mark-list + (z:varref-var (get-arg-varref 0))))]) + (and (procedure? fun-val) + (procedure-arity-includes? + fun-val + (length (z:app-args expr))) + (or (and (s:constructor-style-printing?) + (if (s:abbreviate-cons-as-list?) + (eq? fun-val list) ; that needs exporting too. + (and (s:user-cons? fun-val) + (second-arg-is-list? mark-list)))) + (s:user-vector? fun-val) + (and (eq? fun-val void) + (eq? (z:app-args expr) null)) + (struct-constructor-procedure? fun-val) + ; this next clause may be obviated by the previous one. + (let ([closure-record (closure-table-lookup fun-val (lambda () #f))]) + (and closure-record + (closure-record-constructor? closure-record))))))) + (in-inserted-else-clause mark-list))))) + + (define (second-arg-is-list? mark-list) + (let ([arg-val (mark-binding-value (find-var-binding mark-list (z:varref-var (get-arg-varref 2))))]) + (list? arg-val))) + + (define (in-inserted-else-clause mark-list) + (and (not (null? mark-list)) + (let ([expr (mark-source (car mark-list))]) + (or (and (z:zodiac? expr) + (not (z:if-form? expr)) + (comes-from-cond? expr)) + (in-inserted-else-clause (cdr mark-list)))))) + + (define (rectify-source-expr expr mark-list lexically-bound-vars) + (let ([recur (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))]) + (cond [(z:varref? expr) + (cond [(memq (z:varref-var expr) lexically-bound-vars) + (z:binding-orig-name (z:bound-varref-binding expr))] + [(z:top-level-varref? expr) + (z:varref-var expr)] + [else + (rectify-value (mark-binding-value (find-var-binding mark-list + (z:varref-var expr))))])] + + [(z:app? expr) + (map recur (cons (z:app-fun expr) (z:app-args expr)))] + + [(z:struct-form? expr) + (if (comes-from-define-struct? expr) + (e:internal-error expr "this expression should have been skipped during reconstruction") + (let ([super-expr (z:struct-form-super expr)] + [raw-type (utils:read->raw (z:struct-form-type expr))] + [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) + (if super-expr + `(struct (,raw-type ,(recur super-expr)) + ,raw-fields) + `(struct ,raw-type ,raw-fields))))] + + [(z:if-form? expr) + (cond + [(comes-from-cond? expr) + `(cond ,@(rectify-cond-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))] + [(comes-from-and? expr) + `(and ,@(rectify-and-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))] + [(comes-from-or? expr) + `(or ,@(rectify-or-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))] + [else + `(if ,(recur (z:if-form-test expr)) + ,(recur (z:if-form-then expr)) + ,(recur (z:if-form-else expr)))])] + + [(z:quote-form? expr) + (let ([raw (utils:read->raw (z:quote-form-expr expr))]) + (rectify-value raw) +; (cond [(or (string? raw) +; (number? raw) +; (boolean? raw) +; (s:image? raw)) +; raw] +; [else +; `(quote ,raw)]) + )] + + [(z:case-lambda-form? expr) + (let* ([arglists (z:case-lambda-form-args expr)] + [bodies (z:case-lambda-form-bodies expr)] + [o-form-arglists + (map (lambda (arglist) + (utils:improper-map z:binding-orig-name + (utils:arglist->ilist arglist))) + arglists)] + [var-form-arglists + (map (lambda (arglist) + (map z:binding-var (z:arglist-vars arglist))) + arglists)] + [o-form-bodies + (map (lambda (body var-form-arglist) + (rectify-source-expr body + mark-list + (append var-form-arglist + lexically-bound-vars))) + bodies + var-form-arglists)]) + (cond [(or (comes-from-lambda? expr) (comes-from-define? expr)) + `(lambda ,(car o-form-arglists) ,(car o-form-bodies))] + [(comes-from-case-lambda? expr) + `(case-lambda ,@(map list o-form-arglists o-form-bodies))] + [else + (e:internal-error expr "unknown source for case-lambda")]))] + + ; we won't call rectify-source-expr on define-values expressions + + [else + (print-struct #t) + (e:internal-error + expr + (format "stepper:rectify-source: unknown object to rectify, ~a~n" expr))]))) + + ; these macro unwinders (and, or) are specific to beginner level + + (define (rectify-and-clauses and-source expr mark-list lexically-bound-vars) + (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))]) + (if (and (z:if-form? expr) (equal? and-source (z:zodiac-start expr))) + (cons (rectify-source (z:if-form-test expr)) + (rectify-and-clauses and-source (z:if-form-then expr) mark-list lexically-bound-vars)) + null))) + + (define (rectify-or-clauses or-source expr mark-list lexically-bound-vars) + (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))]) + (if (and (z:if-form? expr) (equal? or-source (z:zodiac-start expr))) + (cons (rectify-source (z:if-form-test expr)) + (rectify-or-clauses or-source (z:if-form-else expr) mark-list lexically-bound-vars)) + null))) + + (define (rectify-cond-clauses cond-source expr mark-list lexically-bound-vars) + (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))]) + (if (equal? cond-source (z:zodiac-start expr)) + (if (z:if-form? expr) + (cons (list (rectify-source (z:if-form-test expr)) + (rectify-source (z:if-form-then expr))) + (rectify-cond-clauses cond-source (z:if-form-else expr) mark-list lexically-bound-vars)) + null) + `((else ,(rectify-source expr)))))) + + ; reconstruct-completed : reconstructs a completed expression or definition. This now + ; relies upon the s:global-lookup procedure to find values in the user-namespace. + ; I'm not yet sure whether or not 'vars' must be supplied or whether they can be derived + ; from the expression itself. + + (define (reconstruct-completed expr value) + (cond [(z:define-values-form? expr) + (if (comes-from-define-struct? expr) + (utils:read->raw (expr-read expr)) + (let* ([vars (map z:varref-var (z:define-values-form-vars expr))] + [values (map s:global-lookup vars)] + [rectified-vars (map rectify-value values)]) + (cond [(comes-from-define-procedure? expr) + (let* ([mark (closure-record-mark (closure-table-lookup (car values)))] + [rectified (rectify-source-expr (mark-source mark) (list mark) null)]) + (o-form-lambda->define (o-form-case-lambda->lambda rectified) + (car vars)))] + [(comes-from-lambda-defined-procedure? expr) + (let* ([mark (closure-record-mark (closure-table-lookup (car values)))] + [rectified (rectify-source-expr (mark-source mark) (list mark) null)]) + `(define ,(car vars) ,(o-form-case-lambda->lambda rectified)))] + [(comes-from-define? expr) + `(define ,(car vars) ,(car rectified-vars))] + [else + `(define-values ,vars + ,(if (= (length values) 1) + (car rectified-vars) + `(values ,@rectified-vars)))])))] + [(z:begin-form? expr) ; hack for xml stuff + (utils:read->raw (expr-read expr))] + [else + (rectify-value value)])) + + ; reconstruct-current : takes a parsed expression, a list of marks, the kind of break, and + ; any values that may have been returned at the break point. It produces a list containing the + ; reconstructed sexp, and the (contained) sexp which is the redex. If the redex is a heap value + ; (and can thus be distinguished from syntactically identical occurrences of that value using + ; eq?), it is embedded directly in the sexp. Otherwise, its place in the sexp is taken by the + ; highlight-placeholder, which is replaced by the highlighted redex in the construction of the + ; text% + + ; z:parsed (list-of mark) symbol (list-of value) -> + ; (list sexp sexp) + + (define (reconstruct-current expr mark-list break-kind returned-value-list) + + (local + ((define (rectify-source-top-marks expr) + (rectify-source-expr expr mark-list null)) + + (define (rectify-top-level expr so-far) + (if (z:define-values-form? expr) + (let ([vars (z:define-values-form-vars expr)] + [val (z:define-values-form-val expr)]) + (cond [(comes-from-define-struct? expr) + (let* ([struct-expr val] + [super-expr (z:struct-form-super struct-expr)] + [raw-type (utils:read->raw (z:struct-form-type struct-expr))] + [raw-fields (map utils:read->raw (z:struct-form-fields struct-expr))]) + `(define-struct + ,(if super-expr + (list raw-type so-far) + raw-type) + ,raw-fields))] + [(or (comes-from-define-procedure? expr) + (and (comes-from-define? expr) + (pair? so-far) + (eq? (car so-far) 'lambda))) + (let* ([proc-name (z:varref-var + (car (z:define-values-form-vars expr)))] + [o-form-proc so-far]) + (o-form-lambda->define o-form-proc proc-name))] + + [(comes-from-define? expr) + `(define + ,(z:varref-var (car vars)) + ,so-far)] + + [else + `(define-values + ,(map utils:read->raw vars) + ,(rectify-source-top-marks val))])) + so-far)) + + (define (reconstruct-inner mark-list so-far) + (let ([rectify-source-current-marks + (lambda (expr) + (rectify-source-expr expr mark-list null))]) + (let* ([top-mark (car mark-list)] + [expr (mark-source top-mark)]) + (cond + ; variable references + [(z:varref? expr) + (if (eq? so-far nothing-so-far) + (rectify-source-current-marks expr) + (e:internal-error expr + "variable reference given as context"))] + + ; applications + + [(z:app? expr) + (let* ([sub-exprs (cons (z:app-fun expr) (z:app-args expr))] + [arg-temps (build-list (length sub-exprs) get-arg-varref)] + [arg-temp-syms (map z:varref-var arg-temps)] + [arg-vals (map (lambda (arg-sym) + (mark-binding-value (find-var-binding mark-list arg-sym))) + arg-temp-syms)]) + (case (mark-label (car mark-list)) + ((not-yet-called) + ; (printf "length of mark-list: ~s~n" (length mark-list)) + ; (printf "mark has binding for third arg: ~s~n" + ; (find-var-binding (list (car mark-list)) (z:varref:var + (letrec + ([split-lists + (lambda (exprs vals) + (if (or (null? vals) + (eq? (car vals) *unevaluated*)) + (values null exprs) + (let-values ([(small-vals small-exprs) + (split-lists (cdr exprs) (cdr vals))]) + (values (cons (car vals) small-vals) small-exprs))))]) + (let-values ([(evaluated unevaluated) (split-lists sub-exprs arg-vals)]) + (let* ([rectified-evaluated (map rectify-value evaluated)]) + (if (null? unevaluated) + rectified-evaluated + (append rectified-evaluated + (cons so-far + (map rectify-source-current-marks (cdr unevaluated))))))))) + ((called) + (if (eq? so-far nothing-so-far) + `(...) ; in unannotated code + `(... ,so-far ...))) + (else + (e:static-error "bad label in application mark: ~s" expr))))] + + ; define-struct + + [(z:struct-form? expr) + (if (comes-from-define-struct? expr) + so-far + (let ([super-expr (z:struct-form-super expr)] + [raw-type (utils:read->raw (z:struct-form-type expr))] + [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) + (if super-expr + `(struct (,raw-type ,so-far) + ,raw-fields) + `(struct ,raw-type ,raw-fields))))] + + ; if + + [(z:if-form? expr) + (let ([test-exp (if (eq? so-far nothing-so-far) + (rectify-source-current-marks + (create-bogus-bound-varref if-temp #f)) + so-far)]) + (cond [(comes-from-cond? expr) + (let* ([clause (list test-exp (rectify-source-current-marks (z:if-form-then expr)))] + [cond-source (z:zodiac-start expr)] + [rest-clauses (rectify-cond-clauses cond-source (z:if-form-else expr) mark-list null)]) + `(cond ,clause ,@rest-clauses))] + [(comes-from-and? expr) + `(and ,test-exp ,@(rectify-and-clauses (z:zodiac-start expr) + (z:if-form-then expr) + mark-list + null))] + [(comes-from-or? expr) + `(or ,test-exp ,@(rectify-or-clauses (z:zodiac-start expr) + (z:if-form-else expr) + mark-list + null))] + [else + `(if ,test-exp + ,(rectify-source-current-marks (z:if-form-then expr)) + ,(rectify-source-current-marks (z:if-form-else expr)))]))] + + ; quote : there is no mark or break on a quote. + + ; begin, begin0 : may not occur directly (or indirectly?) except in advanced + + ; let-values + +; [(z:let-values-form? expr) +; (let+ ([val var-sets (z:let-values-form-vars expr)] +; [val var-set-list (apply append var-sets)] +; [val vals (z:let-values-form-vals expr)] +; [val dummy-var-list (build-list (length var-set-list) (lambda (x) (get-arg-varref x)))] +; [val rhs-vals (map (lambda (arg-sym) +; (mark-binding-value (find-var-binding mark-list arg-sym))) +; arg-temp-syms)] +; [val rhs-list +; (let loop ([var-sets var-sets] [rhs-vals rhs-vals] [rhs-sources vals]) +; (if (eq? (car rhs-vals) *undefined*) +; (map rectify-source-current-marks rhs-sources) +; (let*-values ([first-set (car var-sets)] +; [(set-vals remaining) (list-partition rhs-vals (length first-set))]) +; (cons +; (case (length first-set) +; ((0) `(values)) +; ((1) (car set-vals)) +; (else `(values ,@set-vals))) +; (loop (cdr var-sets) remaining (cdr rhs-sources))))))] +; +; [val (values annotated-vals free-vars-vals) +; (dual-map non-tail-recur vals)] +; [val (values annotated-body free-vars-body) +; (let-body-recur (z:let-values-form-body expr) +; (bindings->varrefs var-set-list))] +; [val free-vars (apply var-set-union (varref-remove* (bindings->varrefs var-set-list) free-vars-body) +; free-vars-vals)]) +; (if cheap-wrap? +; (let ([bindings +; (map (lambda (vars val) +; `(,(map utils:get-binding-name vars) ,val)) +; var-sets +; annotated-vals)]) +; (values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-vars)) +; (let+ ( +; [val dummy-var-list (apply append dummy-var-sets)] +; [val outer-dummy-initialization +; `([,(map z:varref-var dummy-var-list) +; (#%values ,@(build-list (length dummy-var-list) +; (lambda (_) '(#%quote *undefined*))))])] +; [val set!-clauses +; (map (lambda (dummy-var-set val) +; `(#%set!-values ,(map z:varref-var dummy-var-set) ,val)) +; dummy-var-sets +; annotated-vals)] +; [val inner-transference +; `([,(map utils:get-binding-name var-set-list) +; (values ,@(map z:varref-var dummy-var-list))])] +; ; time to work from the inside out again +; [val inner-let-values +; `(#%let-values ,inner-transference ,annotated-body)] +; [val middle-begin +; `(#%begin ,@set!-clauses ,inner-let-values)] +; [val wrapped-begin +; (wcm-wrap (make-debug-info-app (var-set-union tail-bound dummy-var-list) +; (var-set-union free-vars dummy-var-list) +; 'none) +; middle-begin)] +; [val whole-thing +; `(#%let-values ,outer-dummy-initialization ,wrapped-begin)]) +; (values whole-thing free-vars))))] + + ; define-values : define's don't get marks, so they can't occur here + + ; lambda : there is no mark or break on a quote + + [else + (print-struct #t) + (e:internal-error + expr + (format "stepper:reconstruct: unknown object to reconstruct, ~a~n" expr))])))) + + + (define redex #f) + + (define (current-def-rectifier so-far mark-list first) + (if (null? mark-list) + (rectify-top-level expr so-far) + (let ([reconstructed (reconstruct-inner mark-list so-far)]) + (current-def-rectifier + (if first + (begin + (set! redex reconstructed) + highlight-placeholder) + reconstructed) + (cdr mark-list) + #f)))) + + + ; (define (confusable-value? val) + ; (not (or (number? val) + ; (boolean? val) + ; (string? val) + ; (symbol? val)))) + + (define answer + (if (eq? break-kind 'result-break) + (let* ([innermost (if (null? returned-value-list) + (rectify-source-expr (mark-source (car mark-list)) mark-list null) + (rectify-value (car returned-value-list)))] + [current-def (current-def-rectifier highlight-placeholder (cdr mark-list) #f)]) + (list current-def innermost)) + (begin + (let ([current-def (current-def-rectifier nothing-so-far mark-list #t)]) + (list current-def redex))))) + + ) + + answer))) diff --git a/collects/stepper/sharedr.ss b/collects/stepper/sharedr.ss new file mode 100644 index 00000000..42c972c5 --- /dev/null +++ b/collects/stepper/sharedr.ss @@ -0,0 +1,134 @@ +(unit/sig stepper:shared^ + (import [z : zodiac:system^] + [e : zodiac:interface^] + stepper:client-procs^) + + ; A step-result is either: + ; (make-before-after-result finished-exprs exp redex reduct) + ; or (make-before-error-result finished-exprs exp redex err-msg) + ; or (make-error-result finished-exprs err-msg) + ; or (make-finished-result finished-exprs) + (define-struct before-after-result (finished-exprs exp redex post-exp reduct)) + (define-struct before-error-result (finished-exprs exp redex err-msg)) + (define-struct error-result (finished-exprs err-msg)) + (define-struct finished-result (finished-exprs)) + + (define (read-exprs text) + (let ([reader (z:read (open-input-string text) + (z:make-location 1 1 0 "stepper-string"))]) + (let read-loop ([new-expr (reader)]) + (if (z:eof? new-expr) + () + (cons new-expr (read-loop (reader))))))) + + ; the closure record is placed in the closure table + + (define-struct closure-record (name mark constructor?)) + + ; bogus-varref is used so that we can create legal zodiac varrefs for temporary variables + + (define (create-bogus-bound-varref name binding) + (z:make-bound-varref #f #f #f #f name binding)) + + (define (create-bogus-top-level-varref name) + (z:make-top-level-varref #f #f #f #f name)) + + ; gensyms needed by many modules: + + ; no-sexp is used to indicate no sexpression for display. + ; e.g., on an error message, there's no sexp. + (define no-sexp (gensym "no-sexp-")) + + ; *unevaluated* is the value assigned to temps before they are evaluated. + (define *unevaluated* (gensym "unevaluated-")) + + ; if-temp : uninterned-symbol + (define if-temp (gensym "if-temp-")) + + ; struct-flag : uninterned symbol + (define struct-flag (gensym "struct-flag-")) + + ; highlight-placeholder : uninterned symbol + (define highlight-placeholder (gensym "highlight-placeholder")) + + ; make-gensym-source creates a pool of gensyms, indexed by arbitrary keys. These gensyms + ; not eq? to any other symbols, but a client can always get the same symbol by + ; invoking the resulting procedure with the same key (numbers work well). make-gensym-source + ; also takes a string which will be part of the printed representation of the symbol; + ; this makes debugging easier. + ; make-gensym-source : (string -> (key -> symbol)) + + (define (make-gensym-source id-string) + (let ([assoc-table (make-hash-table-weak)]) + (lambda (key) + (let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))]) + (or maybe-fetch + (begin + (let ([new-sym (gensym (string-append id-string (format "~a" key) "-"))]) + (hash-table-put! assoc-table key new-sym) + new-sym))))))) + + ; get-arg-varref maintains a list of gensyms associated with the non-negative + ; integers. These symbols are used in the elaboration of applications; the nth + ; in the application is evaluated and stored in a variable whose name is the nth + ; gensym supplied by get-arg-symbol. + + (define get-arg-varref + (let ([gensym-source (make-gensym-source "arg")]) + (lambda (arg-num) + (create-bogus-bound-varref (gensym-source arg-num) #f)))) + + ; top-level-exp-gensym-source hands out gensyms for the expressions which are not top-level + ; defines. these expressions' results are bound to variables named by these gensyms. Note that + ; this implementation depends on putting exprs in hash tables and thus on non-copying + ; garbage collection. + + (define top-level-exp-gensym-source + (make-gensym-source "top-level-exp")) + + ; test cases: (returns #t on success) + #| (let ([arg3 (get-arg-symbol 3)] + [arg2 (get-arg-symbol 2)] + [arg1 (get-arg-symbol 1)] + [arg2p (get-arg-symbol 2)]) + (and (not (eq? arg3 arg2)) + (not (eq? arg3 arg1)) + (not (eq? arg3 arg2p)) + (not (eq? arg2 arg1)) + (eq? arg2 arg2p) + (not (eq? arg1 arg2p)))) + |# + + ; list-partition takes a list and a number, and returns two lists; the first one contains the + ; first n elements of the list, and the second contains the remainder. If n is greater than + ; the length of the list, the exn:application:mismatch exception is raised. + + (define (list-partition lst n) + (if (= n 0) + (values null lst) + (if (null? lst) + (list-ref lst 0) ; cheap way to generate exception + (let-values ([(first rest) (list-partition (cdr lst) (- n 1))]) + (values (cons (car lst) first) rest))))) + + ; to perform source correlation, we use the 'register-client' ability of zodiac to + ; add fields to parsed structures at runtime. + + (define expr-read read-getter) + (define set-expr-read! read-setter) + + (define (list-take n a-list) + (if (= n 0) + null + (cons (car a-list) (list-take (- n 1) (cdr a-list))))) + + (define (flatten-take n a-list) + (apply append (list-take n a-list))) + + (define-values (closure-table-put! closure-table-lookup) + (let ([closure-table (make-hash-table-weak)]) + (values + (lambda (key value) + (hash-table-put! closure-table key value)) + (lambda args ; key or key & failure-thunk + (apply hash-table-get closure-table args)))))) \ No newline at end of file diff --git a/collects/stepper/sig.ss b/collects/stepper/sig.ss new file mode 100644 index 00000000..b4dc61d6 --- /dev/null +++ b/collects/stepper/sig.ss @@ -0,0 +1,106 @@ +(define-signature stepper:cogen-utils^ + (get-binding-name + lookup-new-binding-name + set-new-binding-name! + + check-for-keyword + check-for-syntax-or-macro-keyword + + the-undefined-value + (struct undefined (id)) + signal-undefined + undefined-error-format + + (struct not-boolean (val)) + signal-not-boolean + not-boolean-error-format + + is-unit-bound? + read->raw + arglist->ilist + + improper-map + improper-foreach)) + +(define-signature plt:aries-no-break^ + (annotate + extract-zodiac-location + w-c-m-key + make-zodiac-mark + signal-not-boolean + signal-undefined)) + +(define-signature plt:aries^ + ((open plt:aries-no-break^) + break)) + +(define-signature stepper:marks^ + (cheap-mark? + make-cheap-mark + cheap-mark-source + make-full-mark + mark-source + mark-bindings + mark-label + mark-binding-value + mark-binding-varref + expose-mark + display-mark + find-var-binding)) + +(define-signature stepper:client-procs^ + (read-getter + read-setter + never-undefined-getter + never-undefined-setter)) + +(define-signature stepper:model-input^ + (text-stream settings image? receive-result)) + +(define-signature stepper:model^ + (check-pre-defined-var + check-global-defined + global-lookup + constructor-style-printing? + abbreviate-cons-as-list? + user-cons? + user-vector? + image? + print-convert)) + +(define-signature stepper:shared^ + ((struct before-after-result (finished-exprs exp redex post-exp reduct)) + (struct before-error-result (finished-exprs exp redex err-msg)) + (struct error-result (finished-exprs err-msg)) + (struct finished-result (finished-exprs)) + list-take + list-partition + (struct closure-record (name mark constructor?)) + create-bogus-bound-varref + create-bogus-top-level-varref + *unevaluated* + no-sexp + if-temp + struct-flag + highlight-placeholder + get-arg-varref + top-level-exp-gensym-source + expr-read + set-expr-read! + flatten-take + closure-table-put! + closure-table-lookup)) + +(define-signature stepper:annotate^ + (initial-env-package + annotate + debug-key)) + +(define-signature stepper:reconstruct^ + (reconstruct-completed + reconstruct-current + final-mark-list? + skip-result-step? + skip-redex-step?)) + + \ No newline at end of file diff --git a/collects/stepper/startup.ss b/collects/stepper/startup.ss new file mode 100644 index 00000000..3ebadbad --- /dev/null +++ b/collects/stepper/startup.ss @@ -0,0 +1,52 @@ +(unit/sig (invoke-stepper) + (import mzlib:core^ + [mred : mred^] + [fw : framework^] + [drscheme : drscheme:export^] + (stepper-go)) + + (define (invoke-stepper frame) + (let ([existing-stepper (send frame stepper-frame)]) + (if existing-stepper + (send existing-stepper show #t) + (fw:gui-utils:show-busy-cursor + (lambda () + (stepper-go frame)))))) + + (define stepper-bitmap + (drscheme:unit:make-bitmap + "Step" + (build-path (collection-path "icons") "foot.bmp"))) + + (drscheme:get/extend:extend-unit-frame + (lambda (super%) + (class super% args + (inherit button-panel) + (sequence (apply super-init args)) + (rename [super-disable-evaluation disable-evaluation] + [super-enable-evaluation enable-evaluation]) + (override + [enable-evaluation + (lambda () + (send stepper-button enable #t) + (super-enable-evaluation))] + [disable-evaluation + (lambda () + (send stepper-button enable #f) + (super-disable-evaluation))]) + (public + [stepper-frame + (let ([frame #f]) + (case-lambda + (() frame) + ((new-val) (set! frame new-val))))] + + [stepper-button (make-object mred:button% + (stepper-bitmap this) + button-panel + (lambda (button evt) + (invoke-stepper this)))]) + (sequence + (send button-panel change-children + (lambda (l) + (cons stepper-button (function:remq stepper-button l))))))))) diff --git a/collects/stepper/tests/main.ss b/collects/stepper/tests/main.ss new file mode 100644 index 00000000..de7924d8 --- /dev/null +++ b/collects/stepper/tests/main.ss @@ -0,0 +1,22 @@ + +(define (send-string str) + (for-each fw:test:keystroke (string->list str))) + +(define top-window + (let loop ([window (get-top-level-focus-window)]) + (if (is-a? window frame%) + window + (begin + (printf "Got this value: ~s~n" window) + (printf "waiting...~n") + (sleep 3) + (loop (get-top-level-focus-window)))))) + +(printf "got a frame.~n") + +(send (ivar top-window definitions-canvas) focus) + +(send-string "(+ 1 2)") + +(fw:test:button-push (ivar top-window stepper-button)) + diff --git a/collects/stepper/utils.ss b/collects/stepper/utils.ss new file mode 100644 index 00000000..b73fbad2 --- /dev/null +++ b/collects/stepper/utils.ss @@ -0,0 +1,133 @@ +(unit/sig stepper:cogen-utils^ + (import [z : zodiac:system^] + [e : zodiac:interface^]) + + + ; get-binding-name extracts the S-expression name for a binding. Zodiac + ; creates a unique, gensym'd symbol for each binding, but the name is + ; unreadable. Here, we create a new gensym, but the name of the generated + ; symbol prints in the same way as the original symbol. + + (define (get-binding-name binding) + (let ([name (lookup-new-binding-name binding)]) + (or name + (let* ([orig-name (z:binding-orig-name binding)] + [name (string->uninterned-symbol (symbol->string orig-name))]) + (set-new-binding-name! binding name) + name)))) + + (define-values (lookup-new-binding-name set-new-binding-name!) + (let-values ([(getter setter) (z:register-client 'new-name (lambda () #f))]) + (values + (lambda (parsed) (getter (z:parsed-back parsed))) + (lambda (parsed n) (setter (z:parsed-back parsed) n))))) + + ; check whether the supplied id is a keyword. if the id is a syntax or + ; macro keyword, issue an error. If disallow-procedures? is true, then + ; we issue an error for _any_ use of a keyword. These procedures are used + ; to prevent the program from redefining keywords. + + (define check-for-keyword/both + (lambda (disallow-procedures?) + (lambda (id) + (let ([real-id + (cond + [(z:binding? id) (z:binding-orig-name id)] + [(z:top-level-varref? id) (z:varref-var id)] + [(z:bound-varref? id) + (z:binding-orig-name (z:bound-varref-binding id))] + [(z:symbol? id) + (z:read-object id)] + [else + (e:internal-error id "Given in check-for-keyword")])]) + (when (and (keyword-name? real-id) + (or disallow-procedures? + (let ([gdv (global-defined-value real-id)]) + (or (syntax? gdv) + (macro? gdv))))) + (e:static-error id "Invalid use of keyword ~s" real-id)))))) + + (define check-for-keyword (check-for-keyword/both #t)) + (define check-for-syntax-or-macro-keyword (check-for-keyword/both #f)) + + (define the-undefined-value (letrec ((x x)) x)) + + (define-struct (undefined struct:exn) (id)) + (define signal-undefined (make-parameter #t)) + (define undefined-error-format + "Variable ~s referenced before definition or initialization") + + (define-struct (not-boolean struct:exn) (val)) + (define signal-not-boolean (make-parameter #f)) + (define not-boolean-error-format "Condition value is neither true nor false: ~e") + + ; there is a problem with Zodiac. The problem is that Zodiac has not been + ; distinguishing between top-level variables and those bound by unit clauses. + ; this is an important distinction to make, because the variables bound by + ; unit clauses may take on the `undefined' value, whereas those bound as + ; top-level variables will never require this check. (If used before defined, + ; these values are simply considered unbound. To this end, Matthew has modified + ; Zodiac to add a bit of information which aries can use to distinguish these + ; fields. Currently, this information is stored in the `unit?' field of a + ; `top-level-varref/bind/unit' structure. There are cleaner solutions, but + ; this one fits well into the current state of the world. This may change at + ; some point in the future. For the moment, here is the function which + ; distinguishes between these two types of binding: + + (define (is-unit-bound? varref) + (and (z:top-level-varref/bind/unit? varref) + (z:top-level-varref/bind/unit-unit? varref))) + + ; Objects that are passed to eval get quoted by M3. These objects + ; do not belong in the `read' structure framework. Hence, if they + ; are passed to z:sexp->raw, they will error. Thus, we first check + ; before sending things there. + + ; jbc additional comments, including elucidation from shriram: + ; there are three `levels' of parsed stuff: + ; raw: simple, unannotated scheme values + ; sexp: simple scheme values with attached zodiac information + ; parsed: fully parsed into zodiac structures + + (define read->raw + (lambda (read) + (if (z:zodiac? read) + (z:sexp->raw read) + read))) + + ; divined notes about the structure of an arglist. Evidently, an arglist can + ; take one of three forms: + ; list-arglist : this arglist represents a simple list of arguments + ; ilist-arglist : this arglist represents a list of arguments which uses + ; `dot-notation' to separate the last element of the list + ; sym-arglist : this arglist represents the `single argument with no + ; parens' style of argument list. + + (define arglist->ilist + (lambda (arglist) + (cond + ((z:list-arglist? arglist) + (z:arglist-vars arglist)) + ((z:ilist-arglist? arglist) + (let loop ((vars (z:arglist-vars arglist))) + (if (null? (cddr vars)) + (cons (car vars) (cadr vars)) + (cons (car vars) (loop (cdr vars)))))) + ((z:sym-arglist? arglist) + (car (z:arglist-vars arglist))) + (else + (e:internal-error arglist + "Given to arglist->ilist"))))) + + (define make-improper + (lambda (combine) + (rec improper ;; `rec' is for the name in error messages + (lambda (f list) + (let improper-loop ([list list]) + (cond + ((null? list) list) + ((pair? list) (combine (f (car list)) + (improper-loop (cdr list)))) + (else (f list)))))))) + (define improper-map (make-improper cons)) + (define improper-foreach (make-improper (lambda (x y) y)))) \ No newline at end of file diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss new file mode 100644 index 00000000..fcce2515 --- /dev/null +++ b/collects/stepper/view-controller.ss @@ -0,0 +1,394 @@ +(unit/sig (stepper-go) + (import [c : mzlib:core^] + [e : zodiac:interface^] + [z : zodiac:system^] + [cp : stepper:client-procs^] + mzlib:pretty-print^ + mred^ + [d : drscheme:export^] + [p : mzlib:print-convert^] + [f : framework^] + stepper:shared^ + [utils : stepper:cogen-utils^] + [marks : stepper:marks^]) + + ;;;;;; copied from /plt/collects/drscheme/snip.ss : + + (define separator-snipclass + (make-object + (class-asi snip-class% + (override + [read (lambda (s) + (let ([size-box (box 0)]) + (send s get size-box) + (make-object separator-snip%)))])))) + + (send* separator-snipclass + (set-version 1) + (set-classname "drscheme:separator-snip%")) + + (send (get-the-snip-class-list) add separator-snipclass) + + ;; the two numbers 1 and 2 which appear here are to line up this snip + ;; with the embedded snips around it in the drscheme rep. + ;; I have no idea where the extra pixels are going. + (define separator-snip% + (class snip% () + (inherit get-style set-snipclass set-flags get-flags get-admin) + (private [width 500] + [height 1] + [white-around 2]) + (override + [write (lambda (s) + (send s put (char->integer #\r)))] + [copy (lambda () + (let ([s (make-object separator-snip%)]) + (send s set-style (get-style)) + s))] + [get-extent + (lambda (dc x y w-box h-box descent-box space-box lspace-box rspace-box) + (for-each (lambda (box) (unless (not box) (set-box! box 0))) + (list descent-box space-box lspace-box rspace-box)) + (let* ([admin (get-admin)] + [reporting-media (send admin get-editor)] + [reporting-admin (send reporting-media get-admin)] + [widthb (box 0)] + [space 2]) + (send reporting-admin get-view #f #f widthb #f) + (set! width (- (unbox widthb) + space + 2))) + (set! height 1) + (unless (not w-box) + (set-box! w-box width)) + (unless (not h-box) + (set-box! h-box (+ (* 2 white-around) height))))] + [draw + (let* ([body-pen (send the-pen-list find-or-create-pen + "BLUE" 0 'solid)] + [body-brush (send the-brush-list find-or-create-brush + "BLUE" 'solid)]) + (lambda (dc x y left top right bottom dx dy draw-caret) + (let ([orig-pen (send dc get-pen)] + [orig-brush (send dc get-brush)]) + (send dc set-pen body-pen) + (send dc set-brush body-brush) + + (send dc draw-rectangle (+ x 1) + (+ white-around y) width height) + + (send dc set-pen orig-pen) + (send dc set-brush orig-brush))))]) + (sequence + (super-init) + (set-flags (cons 'hard-newline (get-flags))) + (set-snipclass separator-snipclass)))) + + ;;;; end of copied region + + (define stepper-frame% + (class (d:frame:basics-mixin (f:frame:standard-menus-mixin f:frame:basic%)) (drscheme-frame) + (rename [super-on-close on-close]) + (override + [on-close + (lambda () + (send drscheme-frame stepper-frame #f) + (super-on-close))]) + (sequence (super-init "The Foot")))) + + (define stepper-canvas% + (class editor-canvas% (parent (editor #f) (style null) (scrolls-per-page 100)) + (rename (super-on-size on-size)) + (inherit get-editor) + (override + [on-size + (lambda (width height) + (super-on-size width height) + (let ([editor (get-editor)]) + (when editor + (send editor reset-pretty-print-width this))))]) + (sequence (super-init parent editor style scrolls-per-page)))) + + (define (image? val) + (is-a? val snip%)) + + (define (confusable-value? val) + (or (number? val) + (boolean? val) + (string? val) + (symbol? val))) + + ; insert-highlighted-value : sexp sexp -> sexp + ; replaces highlight-placeholder in the first sexp with the second sexp + + (define (insert-highlighted-value exp inserted) + (let ([recur (lambda (exp) (insert-highlighted-value exp inserted))]) + (cond [(list? exp) + (map recur exp)] + [(vector? exp) + (list->vector (map recur (vector->list exp)))] + [(eq? exp highlight-placeholder) + inserted] + [else exp]))) + + (define stepper-text% + (class f:text:basic% (finished-exprs exp redex post-exp reduct error-msg (line-spacing 1.0) (tabstops null)) + (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap + begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list) + (public (pretty-printed-width -1) + (char-width 0) + (clear-highlight-thunks null) + [reset-style + (lambda () + (change-style (send (get-style-list) find-named-style "Standard")))] + (reset-pretty-print-width + (lambda (canvas) + (begin-edit-sequence) + (let* ([style (send (get-style-list) find-named-style "Standard")] + [_ (set! char-width (send style get-text-width (send canvas get-dc)))] + [canvas-width (let-values ([(client-width client-height) + (send canvas get-client-size)]) + (- client-width 18))] ; 12 border pixels + 6 for wrap char + [min-columns 30] + [new-columns (max min-columns + (floor (/ canvas-width char-width)))]) + (pretty-print-columns new-columns) + (reformat-sexp) + (end-edit-sequence)))) + (reformat-sexp + (lambda () + (when (not (= pretty-printed-width (pretty-print-columns))) + (set! pretty-printed-width (pretty-print-columns)) + (format-whole-step)))) + [format-sexp + (lambda (sexp redex highlight-color) + (let ([real-print-hook (pretty-print-print-hook)] + [redex-begin #f] + [redex-end #f] + [placeholder-present? #f]) + (parameterize ([pretty-print-size-hook + (lambda (value display? port) + (if (eq? value highlight-placeholder) + (begin + (set! placeholder-present? #t) + (string-length (format "~s" redex))) + (if (image? value) + 1 ; if there was a good way to calculate a image widths ... + #f)))] + [pretty-print-print-hook + (lambda (value display? port) + (if (eq? value highlight-placeholder) + (insert (format "~s" redex)) + ; next occurs if value is an image: + (insert (send value copy))))] + [pretty-print-display-string-handler + (lambda (string port) + (insert string))] + [pretty-print-print-line + (lambda (number port old-length dest-columns) + (when (not (eq? number 0)) + (insert #\newline)) + 0)] + [pretty-print-pre-print-hook + (lambda (value p) + (when (or (and (not placeholder-present?) + (eq? value redex)) + (eq? value highlight-placeholder)) + (set! redex-begin (get-start-position))))] + [pretty-print-post-print-hook + (lambda (value p) + (when (or (and (not placeholder-present?) + (eq? value redex)) + (eq? value highlight-placeholder)) + (set! redex-end (get-start-position))))]) + (pretty-print sexp) + (if redex-begin + (set! clear-highlight-thunks + (cons (highlight-range redex-begin redex-end highlight-color #f #f) + clear-highlight-thunks))))))] + + [un-hacked-format-sexp + (lambda (exp region color) + (if (confusable-value? region) + (format-sexp exp region color) + (format-sexp (insert-highlighted-value exp region) region color)))] + + [format-whole-step + (lambda () + (lock #f) + (begin-edit-sequence) + (for-each (lambda (fun) (fun)) clear-highlight-thunks) + (set! clear-highlight-thunks null) + (erase) + (for-each + (lambda (expr) + (un-hacked-format-sexp expr no-sexp #f) + (insert #\newline)) + finished-exprs) + (insert (make-object separator-snip%)) + (when (not (eq? redex no-sexp)) + (insert #\newline) + (reset-style) + (un-hacked-format-sexp exp redex redex-highlight-color) + (insert #\newline) + (insert (make-object separator-snip%)) + (insert #\newline)) + (cond [(not (eq? reduct no-sexp)) + (reset-style) + (un-hacked-format-sexp post-exp reduct result-highlight-color)] + [error-msg + (let ([before-error-msg (last-position)]) + (reset-style) + (auto-wrap #t) + (insert error-msg) + (change-style error-delta before-error-msg (last-position)))]) + (end-edit-sequence) + (lock #t))]) + (sequence (super-init line-spacing tabstops) + (set-style-list (f:scheme:get-style-list))))) + + (define error-delta (make-object style-delta% 'change-style 'italic)) + (send error-delta set-delta-foreground "RED") + + (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1))) + (define result-highlight-color (make-object color% 255 255 255)) + (define redex-highlight-color (make-object color% 255 255 255)) + (send test-dc try-color (make-object color% 212 159 245) result-highlight-color) + (send test-dc try-color (make-object color% 193 251 181) redex-highlight-color) + + (define (stepper-wrapper drscheme-frame settings) + + (local ((define view-history null) + (define view-currently-updating #f) + (define final-view #f) + (define view 0) + + ; build gui object: + + (define (home) + (update-view 0)) + + (define (next) + (send next-button enable #f) + (send previous-button enable #f) + (send home-button enable #f) + (if (= view (- (length view-history) 1)) + (update-view/next-step (+ view 1)) + (update-view (+ view 1)))) + + (define (previous) + (update-view (- view 1))) + + (define s-frame (make-object stepper-frame% drscheme-frame)) + + (define button-panel (make-object horizontal-panel% (send s-frame get-area-container))) + (define home-button (make-object button% "Home" button-panel + (lambda (_1 _2) (home)))) + (define previous-button (make-object button% "<< Previous" button-panel + (lambda (_1 _2) (previous)))) + (define next-button (make-object button% "Next >>" button-panel (lambda + (_1 _2) (next)))) + + (define canvas (make-object stepper-canvas% (send s-frame get-area-container))) + + (define (update-view/next-step new-view) + (set! view-currently-updating new-view) + (step)) + + (define (update-view new-view) + (set! view new-view) + (let ([e (list-ref view-history view)]) + (send e reset-pretty-print-width canvas) + (send canvas lazy-refresh #t) + (send canvas set-editor e) + (send e set-position (send e last-position)) + (send canvas lazy-refresh #f)) + (send previous-button enable (not (zero? view))) + (send home-button enable (not (zero? view))) + (send next-button enable (not (eq? final-view view)))) + + (define (receive-result result) + (let ([step-text + (cond [(before-after-result? result) + (make-object stepper-text% + (before-after-result-finished-exprs result) + (before-after-result-exp result) + (before-after-result-redex result) + (before-after-result-post-exp result) + (before-after-result-reduct result) + #f)] + [(before-error-result? result) + (set! final-view view-currently-updating) + (make-object stepper-text% + (before-error-result-finished-exprs result) + (before-error-result-exp result) + (before-error-result-redex result) + no-sexp + no-sexp + (before-error-result-err-msg result))] + [(error-result? result) + (set! final-view view-currently-updating) + (make-object stepper-text% + (error-result-finished-exprs result) + no-sexp + no-sexp + no-sexp + no-sexp + (error-result-err-msg result))] + [(finished-result? result) + (set! final-view view-currently-updating) + (make-object stepper-text% + (finished-result-finished-exprs result) + no-sexp + no-sexp + no-sexp + no-sexp + #f)])]) + (set! view-history (append view-history (list step-text))) + (update-view view-currently-updating))) + + (define text-stream + (f:gui-utils:read-snips/chars-from-text (ivar drscheme-frame definitions-text))) + + (define step + (invoke-unit/sig (require-library-unit/sig "instance.ss" "stepper") + stepper:model-input^ + (c : mzlib:core^) + (e : zodiac:interface^) + (p : mzlib:print-convert^) + (d : drscheme:export^) + (z : zodiac:system^) + (cp : stepper:client-procs^) + stepper:shared^ + mred^ + (utils : stepper:cogen-utils^) + (marks : stepper:marks^)))) + + (send drscheme-frame stepper-frame s-frame) + (set! view-currently-updating 0) + (send button-panel stretchable-width #f) + (send button-panel stretchable-height #f) + (send canvas stretchable-height #t) + (send canvas min-width 400) + (send canvas min-height 100) + (send previous-button enable #f) + (send home-button enable #f) + (send next-button enable #f) + (send (send s-frame edit-menu:get-undo-item) enable #f) + (send (send s-frame edit-menu:get-redo-item) enable #f) + (step) + (send s-frame show #t))) + + (define beginner-level-name "Beginning Student") + + (define (stepper-go frame) + (let ([settings (f:preferences:get 'drscheme:settings)]) + (if #f ; (not (string=? (d:basis:setting-name settings) beginner-level-name)) + (message-box "Stepper" + (format (string-append "Language level is set to \"~a\".~n" + "The Foot only works for the \"~a\" language level.~n") + (d:basis:setting-name settings) + beginner-level-name) + #f + '(ok)) + (stepper-wrapper frame settings))))) \ No newline at end of file diff --git a/collects/tests/addrhack.c b/collects/tests/addrhack.c new file mode 100644 index 00000000..fc942d00 --- /dev/null +++ b/collects/tests/addrhack.c @@ -0,0 +1,53 @@ +/* +Matthew writes: + +This file, when loaded, defines: + + object->address : value -> exact integer in [0,2^32-1] + address->object : exact integer in [0,2^32-1] -> value + +Obviously, address->object is not safe. + +To Compile: + + mzc --cc addrhack.c + mzc --ld addrhack.so addrhack.o + +*/ +#include "escheme.h" + +Scheme_Object *object_to_address(int c, Scheme_Object **a) +{ + return scheme_make_integer_value_from_unsigned((unsigned long)a[0]); +} + +Scheme_Object *address_to_object(int c, Scheme_Object **a) +{ + unsigned long v; + + if (!scheme_get_unsigned_int_val(a[0], &v)) + scheme_signal_error("bad address"); + + return (Scheme_Object *)v; +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + scheme_add_global("object->address", + scheme_make_prim_w_arity(object_to_address, + "object->address", + 1, 1), + env); + scheme_add_global("address->object", + scheme_make_prim_w_arity(address_to_object, + "address->object", + 1, 1), + env); + + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + return scheme_reload(env); +} diff --git a/collects/tests/drscheme/README b/collects/tests/drscheme/README new file mode 100644 index 00000000..723b0aa0 --- /dev/null +++ b/collects/tests/drscheme/README @@ -0,0 +1,85 @@ +`(#| + +This directory contains code for testing DrScheme. To run the tests, +load run-test.ss. It will return a function that accepts the names of +tests. Those names must be listed here. If no arguments are passed to +the function, all tests will be run. + + +|# mem.ss #| + + runs some memory tests + +|# sample-solutions.ss #| + + This tests the sample solutions in HtDP + +|# io.ss #| + + This tests the drscheme's io implementation. + +|# repl-test.ss #| + + This tests various interactions between parameters in the + implementation of drscheme. + +|# language-test.ss #| + + This tests that all of the individual settings in the language dialog + take effect in the repl. + + +|# graphics.ss #| + + This tests the various graphic elements that can appear + in programs. + +|# launcher.ss #| + + This tests the launcher feature of drscheme. + +---------------------------------- +-------- MANUAL TESTS ---------- +---------------------------------- + + sixlib.ss + +---------------------------------- +---------- OLD TESTS ----------- +---------------------------------- + + menu-test.ss + +PR-based tests: + + pr-144.ss + pr-17.ss + pr-246.ss + pr-39.ss + pr-46.ss + pr-48.ss + pr-51.ss + pr-58.ss + pr-80.ss + pr-99.ss + +Ideally, each test should be run with a fresh invocation +of DrScheme. Since that's time-consuming, you can +run all tests by executing "drscheme-test.ss". + +A small amount of manual intervention is needed during +the tests. By intervention, we mean pushing buttons +in dialogs that popup during the tests. + +The progress and results of the tests are reported to +standard output. You should examine this output to determine +whether if the tests were successful. + +The code is maintained by Paul Steckler. The original code +was by Robby Findler. + +There are some other files in this directory, which appear +to be unused, such as tmp.ss, and line-art.ss. The directory +syncheck/ appears to be unused. + +|#) \ No newline at end of file diff --git a/collects/tests/drscheme/check-syntax-test.ss b/collects/tests/drscheme/check-syntax-test.ss new file mode 100644 index 00000000..e3399a94 --- /dev/null +++ b/collects/tests/drscheme/check-syntax-test.ss @@ -0,0 +1,52 @@ +;;; check-syntax.ss + +;;; Author: Paul Steckler, modifying code by Robby Findler + +(load-relative "drscheme-test-util.ss") + +(let* ([drs-frame (wait-for-drscheme-frame)] + [interactions-edit (ivar drs-frame interactions-edit)] + [get-int-pos (lambda () (get-text-pos interactions-edit))] + [check-check-syntax ; type in term, call check-syntax + (lambda (str expected) + (clear-definitions drs-frame) + (type-in-definitions drs-frame str) + (let ([answer-begin (get-int-pos)]) + (mred:test:button-push (ivar drs-frame check-syntax-button)) + (let ([answer-end (- (get-int-pos) 1)]) + (let ([actual (send interactions-edit get-text + answer-begin answer-end)]) + (unless (string=? actual expected) + (printf "Expected: ~a~n Actual: ~a~n~n" + expected actual))) + (let ([frame (mred:test:get-active-frame)]) + (unless (eq? frame drs-frame) + (error 'check-syntax "Unexpected window ~a" frame))))))] + + ; question: should we test for errors at different syntax levels? + + [terms-and-msgs ; terms and expected error message, if any + + ; why are some of these messages init-capped, others not? + + '(("x" "") + ("." "can't use `.' outside list") + ("(" "missing close paren") + ("begin" "Invalid use of keyword begin") + ("(begin)" "Malformed begin") + ("1" "") + ("add1" "") + ("(lambda (x) x)" ""))]) + + (set-language-level! "R4RS+" drs-frame) + + (printf "Starting check-syntax tests~n") + + (for-each + (lambda (p) (check-check-syntax (car p) (cadr p))) + terms-and-msgs)) + + (printf "Finished check-syntax tests~n") + + + \ No newline at end of file diff --git a/collects/tests/drscheme/config-lang-test.ss b/collects/tests/drscheme/config-lang-test.ss new file mode 100644 index 00000000..d8ed9b73 --- /dev/null +++ b/collects/tests/drscheme/config-lang-test.ss @@ -0,0 +1,76 @@ +;;; config-lang-test.ss + +;;; tests the toggle options in the dialog started from the +;;; Language | Configure Language... menu item + +;;; Author: Paul Steckler + +(load-relative "drscheme-test-util.ss") + +(letrec* ([_ (wait-for-drscheme-frame)] + [drscheme-frame (mred:test:get-active-frame)] + [eq-frame? (lambda () (eq? (mred:test:get-active-frame) drscheme-frame))] + [interactions-edit (ivar drscheme-frame interactions-edit)] + [interactions-canvas (ivar drscheme-frame interactions-canvas)] + [definitions-edit (ivar drscheme-frame definitions-edit)] + [definitions-canvas (ivar drscheme-frame definitions-canvas)] + [execute-button (ivar drscheme-frame execute-button)] + [get-int-pos (lambda () (get-start-of-last-line interactions-edit))] + [wait-for-events + (lambda (nevents) + (let loop () + (unless (= nevents (mred:test:number-pending-actions)) + (sleep 1/2) + (loop))))] + [run-test + (lambda (cb state code expected) + + ; click on menu item + + (mred:test:menu-select "Language" "Configure Language...") + (mred:test:new-window (wx:find-window-by-name "Language" null)) + + ; open sub-dialog + + (with-handlers ([(lambda (_) #t) (lambda (x) (printf "~a~n" (exn-message x)))]) + (mred:test:button-push "Show Details") + (wait-for-events 1) + (mred:test:reraise-error)) + + (mred:test:set-check-box! cb state) + + ; close dialog + + (mred:test:button-push "OK") + + ; enter code in definitions window + + (wait-for-drscheme-frame) + (mred:test:new-window definitions-canvas) + (clear-definitions drscheme-frame) + (mred:test:button-push execute-button) + + (let ([answer-begin (send interactions-edit last-position)]) + + (type-in-definitions drscheme-frame code) + (mred:test:keystroke #\return) + + ; compare actual answer to expected + + (push-button-and-wait execute-button) + + (let* ([answer-end (- (send interactions-edit last-position) 3)] + [actual (send interactions-edit get-text + answer-begin answer-end)]) + (unless (string=? actual expected) + (printf "Expected: ~a~n Actual: ~a~n~n" + expected actual)))))]) + + ; now toggle items and test + + (mred:test:run-interval 500) + + (run-test "Case sensitive" #f + "(eq? 'foo 'FOO)" + "#t")) + diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss new file mode 100644 index 00000000..b024cc74 --- /dev/null +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -0,0 +1,337 @@ +;;; util.ss + +;;; utility functions for DrScheme GUI testing + +;;; Authors: Robby Findler, Paul Steckler + +(unit/sig drscheme:test-util^ + + (import mred^ + [fw : framework^] + test-utils:gui^) + + ;; save-drscheme-window-as : string -> void + ;; use the "save as" dialog in drscheme to save the definitions + ;; window to a file. + (define (save-drscheme-window-as filename) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "File" "Save Definitions As...")) + filename)) + + ;; use-get/put-dialog : (-> void) string -> void + ;; open-dialog is a thunk that should open the dialog + ;; filename is a string naming a file that should be typed into the dialog + (define (use-get/put-dialog open-dialog filename) + (unless (procedure? open-dialog) + (error 'use-open/close-dialog "expected procedure as first argument, got: ~e, other arg: ~e" + open-dialog filename)) + (unless (string? filename) + (error 'use-open/close-dialog "expected string as second argument, got: ~e, other arg: ~e" + filename open-dialog)) + (let ([drs (wait-for-drscheme-frame)] + [old-pref (fw:preferences:get 'framework:file-dialogs)]) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (fw:preferences:set 'framework:file-dialogs old-pref) + (raise x))]) + (fw:preferences:set 'framework:file-dialogs 'common) + (open-dialog) + (let ([dlg (wait-for-new-frame drs)]) + (send (find-labelled-window "Full pathname") focus) + (fw:test:keystroke #\a (list (case (system-type) + [(windows) 'control] + [(macos) 'command] + [(unix) 'meta]))) + (for-each fw:test:keystroke (string->list filename)) + (fw:test:button-push "OK") + (wait-for-new-frame dlg)) + (fw:preferences:set 'framework-file-dialogs old-pref)))) + + ;; -> eventspace + ;; returns the eventspace used by the program in the current drscheme window + (define (get-user-eventspace) + (ivar (wait-for-drscheme-frame) user-eventspace)) + + (define (test-util-error fmt . args) + (raise (make-exn (apply fmt args) (current-continuation-marks)))) + + (define poll-until + (case-lambda + [(pred) (poll-until pred 10)] + [(pred secs) + (let ([step 1/20]) + (let loop ([counter secs]) + (if (<= counter 0) + (error 'poll-until "timeout after ~e secs, ~e never returned a true value" secs pred) + (let ([result (pred)]) + (or result + (begin + (sleep step) + (loop (- counter step))))))))])) + + (define (drscheme-frame? frame) + (ivar-in-interface? 'execute-button (object-interface frame))) + + (define (wait-for-drscheme-frame) + (let ([wait-for-drscheme-frame-pred + (lambda () + (yield) + (let ([active (get-top-level-focus-window)]) + (if (and active + (drscheme-frame? active)) + active + #f)))]) + (or (wait-for-drscheme-frame-pred) + (begin + (printf "Select DrScheme frame~n") + (poll-until wait-for-drscheme-frame-pred))))) + + (define (wait-for-new-frame old-frame) + (let ([wait-for-new-frame-pred + (lambda () + (let ([active (get-top-level-focus-window)]) + (if (and active + (not (eq? active old-frame))) + active + #f)))]) + (poll-until wait-for-new-frame-pred))) + + (define (wait-for-computation frame) + (verify-drscheme-frame-frontmost 'wait-for-computation frame) + (let* ([button (ivar frame execute-button)] + [wait-for-computation-pred + (lambda () + (fw:test:reraise-error) + (send button is-enabled?))]) + (poll-until + wait-for-computation-pred + 60))) + + (define do-execute + (case-lambda + [(frame) + (do-execute frame #t)] + [(frame wait-for-finish?) + (verify-drscheme-frame-frontmost 'do-execute frame) + (let ([button (ivar frame execute-button)]) + (fw:test:button-push button) + (when wait-for-finish? + (wait-for-computation frame)))])) + + (define (verify-drscheme-frame-frontmost function-name frame) + (unless (and (eq? frame (get-top-level-focus-window)) + (drscheme-frame? frame)) + (error function-name "drscheme frame not frontmost: ~e" frame))) + + (define (clear-definitions frame) + (verify-drscheme-frame-frontmost 'clear-definitions frame) + (fw:test:new-window (ivar frame definitions-canvas)) + (let ([window (send frame get-focus-window)]) + (let-values ([(cw ch) (send window get-client-size)] + [(w h) (send window get-size)]) + (fw:test:mouse-click 'left + (+ cw (floor (/ (- w cw) 2))) + (+ ch (floor (/ (- h ch) 2)))))) + (fw:test:menu-select "Edit" "Select All") + (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) + "Clear" + "Delete"))) + + + (define (type-in-definitions frame str) + (type-in-definitions/interactions 'definitions-canvas frame str)) + (define (type-in-interactions frame str) + (type-in-definitions/interactions 'interactions-canvas frame str)) + + (define (type-in-definitions/interactions canvas-ivar frame str/sexp) + (let ([str (if (string? str/sexp) + str/sexp + (let ([port (open-output-string)]) + (parameterize ([current-output-port port]) + (write str/sexp port)) + (get-output-string port)))]) + (verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame) + (let ([len (string-length str)] + [canvas (ivar/proc frame canvas-ivar)]) + (fw:test:new-window canvas) + (send (send canvas get-editor) set-caret-owner #f) + (let loop ([i 0]) + (unless (>= i len) + (let ([c (string-ref str i)]) + (fw:test:keystroke + (if (char=? c #\newline) + #\return + c))) + (loop (+ i 1))))))) + + (define wait + (case-lambda + [(test desc-string) (wait test desc-string 5)] + [(test desc-string time) + (let ([int 1/2]) + (let loop ([sofar 0]) + (cond + [(> sofar time) (error 'wait desc-string)] + [(test) (void)] + [else (sleep int) + (loop (+ sofar int))])))])) + + (define (wait-pending) + (wait (lambda () (= 0 (fw:test:number-pending-actions))) + "Pending actions didn't terminate") + (fw:test:reraise-error)) + + +;;; get-sub-panel takes +;;; a list of integers describing the path from a frame to the desired panel +;;; the frame +;;; based on code by Mark Krentel + +;;; Examples: +;;; (get-sub-panel '() frame) gets the top-panel in frame +;;; (get-sub-panel '(2) frame) gets the 2nd child of the top-panel +;;; (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel + + (define (get-sub-panel path frame) + (letrec ([loop + (lambda (path panel) + (if (null? path) + (if (is-a? panel panel%) + panel + (test-util-error "not a panel")) + (loop + (cdr path) + (list-ref (send panel get-children) (car path)))))]) + (loop path frame))) + +;;; get-text-pos returns the offset in an text buffer of the beginning +;;; of the last line + + (define (get-text-pos text) + (let* ([last-pos (send text last-position)] + [last-line (send text position-line last-pos)]) + (send text line-start-position last-line))) + + ; poll for enabled button + + (define (wait-for-button button) + (poll-until + (let ([wait-for-button-pred + (lambda () + (send button is-enabled?))]) + wait-for-button-pred))) + + (define (push-button-and-wait button) + (fw:test:button-push button) + (poll-until + (let ([button-push-and-wait-pred + (lambda () + (fw:test:reraise-error) + (= 0 (fw:test:number-pending-actions)))]) + button-push-and-wait-pred)) + (wait-for-button button)) + + ; set language level in the frontmost DrScheme frame + (define set-language-level! + (case-lambda + [(level) + (set-language-level! level #t)] + [(level close-dialog?) + (let ([frame (get-top-level-focus-window)]) + (fw:test:menu-select "Language" "Choose Language...") + + (wait-for-new-frame frame) + (let ([language-choice (find-labelled-window "Language" choice%)]) + (cond + [(member level (let loop ([n (send language-choice get-number)]) + (cond + [(zero? n) null] + [else (cons (send language-choice get-string (- n 1)) + (loop (- n 1)))]))) + (fw:test:set-choice! language-choice level)] + [else + (fw:test:set-choice! language-choice "Full Scheme") + (fw:test:set-radio-box! + (find-labelled-window #f radio-box% (send language-choice get-parent)) + level)])) + + (when close-dialog? + (let ([language-dialog (get-top-level-focus-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame language-dialog))))])) + + (define (repl-in-edit-sequence?) + (send (ivar (wait-for-drscheme-frame) interactions-text) refresh-delayed?)) + + (define (has-error? frame) + (verify-drscheme-frame-frontmost 'had-error? frame) + (let* ([interactions-text (ivar frame interactions-text)] + [last-para (send interactions-text last-paragraph)]) + (unless (>= last-para 2) + (error 'has-error? "expected at least 2 paragraphs in interactions window, found ~a" + (+ last-para 1))) + (let ([start (send interactions-text paragraph-start-position 2)] + [end (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1))]) + (send interactions-text split-snip start) + (send interactions-text split-snip end) + (let loop ([pos start]) + (cond + [(<= end pos) #f] + [else + (let ([snip (send interactions-text find-snip pos 'after-or-none)]) + (cond + [(not snip) #f] + [else + (let ([color (send (send snip get-style) get-foreground)]) + (if (and (= 255 (send color red)) + (= 0 (send color blue) (send color green))) + #t + (loop (+ pos (send snip get-count)))))]))]))))) + + (define fetch-output + (case-lambda + [(frame) + (verify-drscheme-frame-frontmost 'fetch-output frame) + (let* ([interactions-text (ivar frame interactions-text)] + [last-para (send interactions-text last-paragraph)]) + (unless (>= last-para 2) + (error 'fetch-output "expected at least 2 paragraphs in interactions window, found ~a" + (+ last-para 1))) + (fetch-output frame + (send interactions-text paragraph-start-position 2) + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1))))] + [(frame start end) + (verify-drscheme-frame-frontmost 'fetch-output frame) + (let ([interactions-text (ivar frame interactions-text)]) + (send interactions-text split-snip start) + (send interactions-text split-snip end) + (let loop ([snip (send interactions-text find-snip end 'before)] + [strings null]) + (cond + [(< (send interactions-text get-snip-position snip) start) + (apply string-append strings)] + [else + (cond + [(is-a? snip string-snip%) + (loop (send snip previous) + (cons (send snip get-text 0 (send snip get-count)) strings))] + [(is-a? snip editor-snip%) + (let ([editor (send snip get-editor)]) + (cond + [(is-a? editor pasteboard%) + (loop (send snip previous) + (cons "" strings))] + [(is-a? editor text%) + (loop (send snip previous) + (list* "[" + (send editor get-text) + "]" + strings))]))] + [(is-a? snip image-snip%) + (loop (send snip previous) + (cons "" + strings))] + [else (error 'find-output "unknown snip: ~e~n" snip)])])))]))) \ No newline at end of file diff --git a/collects/tests/drscheme/drscheme-test.ss b/collects/tests/drscheme/drscheme-test.ss new file mode 100644 index 00000000..8061f488 --- /dev/null +++ b/collects/tests/drscheme/drscheme-test.ss @@ -0,0 +1,47 @@ +;;; drscheme-test.ss + +;;; files for testing of DrScheme + +;;; Author: Paul Steckler + +(load-relative "drscheme-test-util.ss") + +(define test-files + (list + "menu-test.ss" ; opens some dialogs and closes them + "repl-test.ss" ; executes and loads some terms in the REPL + "check-syntax-test.ss" ; calls syntax checker on some terms + )) + +(define pr-files + (list + "pr-17.ss" + "pr-39.ss" + "pr-39.ss" + "pr-46.ss" + "pr-48.ss" + "pr-51.ss" + "pr-58.ss" + "pr-80.ss" + "pr-99.ss" + "pr-144.ss" + "pr-246.ss" + )) + +(define (run-it s) + (clear-definitions (wait-for-drscheme-frame)) + (printf "Running tests in file ~a...~n" s) + (load-relative s) + (printf "Done with file ~a.~n" s)) + +(printf "Running DrScheme tests...~n") + +(for-each run-it test-files) + +(printf "Done with DrScheme tests.~n") + +(printf "Running tests designed from GNATS pr's...~n") + +(for-each run-it pr-files) + +(printf "Done with GNATS pr tests.~n") diff --git a/collects/tests/drscheme/event-efficency.ss b/collects/tests/drscheme/event-efficency.ss new file mode 100644 index 00000000..0119a04a --- /dev/null +++ b/collects/tests/drscheme/event-efficency.ss @@ -0,0 +1,63 @@ +(define semaphore (make-semaphore 0)) +(define loop-size 3000) +(define events/loop 10) + +(define frame (make-object frame% "frame" #f 100 100)) +(define counter 0) +(define canvas + (make-object + (class canvas% () + (inherit refresh) + (override + [on-paint + (lambda () + (cond + [(equal? 0 counter) + (void)] + [else + (set! counter (- counter 1)) + (refresh)]))]) + (sequence (super-init frame))))) + +(send frame show #t) +;(event-dispatch-handler (let ([orig (event-dispatch-handler)]) (lambda (eventspace) (orig eventspace)))) + +(define (test name body-expression after-expression) + (let ([start-time (current-milliseconds)]) + (eval + `(let loop ([n loop-size]) + (unless (zero? n) + ,body-expression + (loop (- n 1))))) + (let* ([end-time (current-milliseconds)] + [total-time (- end-time start-time)]) + + (eval after-expression) + + (printf "~a: time per event ~a msec~n~a: total time ~a msec~n" + name + (exact->inexact + (/ (floor (* (/ total-time loop-size events/loop) 1000)) 1000)) + name + total-time)))) + + +(test + "canvas" + `(begin + ,@(let loop ([n events/loop]) + (cond + [(zero? n) `()] + [else `((queue-callback void) + . + ,(loop (- n 1)))]))) + '(void)) + + +(test + "queue" + '(begin (set! counter events/loop) + (send canvas refresh)) + '(begin (queue-callback (lambda () (semaphore-post semaphore))) + (yield semaphore))) + diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss new file mode 100644 index 00000000..2338e2d4 --- /dev/null +++ b/collects/tests/drscheme/io.ss @@ -0,0 +1,35 @@ +(set-language-level! "Textual (MzScheme)") + +(define frame (wait-for-drscheme-frame)) + +(define (check-output expression expected) + (begin + (clear-definitions frame) + (type-in-definitions frame expression) + (do-execute frame) + (let ([got (fetch-output frame)]) + (unless (equal? expected got) + (error 'io.ss "expected ~s, got ~s for ~s" expected got expression))))) + +(check-output "(display 1)" "[1]") +(check-output "(display 1 (current-output-port))" "[1]") +(check-output "(display 1 (current-error-port))" "1") +(check-output "(display 1) (display 1 (current-error-port))" (format "[1]~n1")) +(check-output "(display 1 (current-error-port)) (display 1)" (format "1~n[1]")) +(check-output "(display 1) (display 1 (current-error-port)) (display 1)" (format "[1]~n1~n[1]")) +(check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))" (format "1~n[1]~n1")) +(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))" "[1]") +(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" "[1]") +(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))" "1") + + +;; long io / execute test +(clear-definitions frame) +(type-in-definitions + frame + "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))") +(do-execute frame) +(clear-definitions frame) +(do-execute frame) +(unless (equal? "" (fetch-output frame)) + (error 'io.ss "failed long io / execute test")) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss new file mode 100644 index 00000000..e2680e8a --- /dev/null +++ b/collects/tests/drscheme/language-test.ss @@ -0,0 +1,545 @@ +(define language (make-parameter "<>")) + +(define (set-language close-dialog?) + (set-language-level! (language) close-dialog?) + (unless close-dialog? + (with-handlers ([exn:user? (lambda (x) (void))]) + (fw:test:button-push "Show Details")))) + +(define (test-setting setting-name value expression result) + (fw:test:set-check-box! setting-name value) + (let ([f (get-top-level-focus-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)) + (let* ([drs (get-top-level-focus-window)] + [interactions (ivar drs interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output drs)]) + (unless (string=? result got) + (printf "FAILED: ~a ~a test~n expected: ~a~n got: ~a~n" (language) expression result got))) + '(dump-memory-stats))) + +(define (test-hash-bang) + (let* ([expression (format "#!~n1")] + [result "1"] + [drs (get-top-level-focus-window)] + [interactions (ivar drs interactions-text)]) + (clear-definitions drs) + (type-in-definitions drs expression) + (do-execute drs) + (let* ([got (fetch-output drs)]) + (unless (string=? "1" got) + (printf "FAILED: ~a ~a test~n expected: ~a~n got: ~a~n" + (language) expression result got))))) + +(define (mred) + (parameterize ([language "Graphical without Debugging (MrEd)"]) + (generic-settings #f) + (generic-output #t #t #f) + (set-language #f) + (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "cond or case: no matching clause") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "reference to undefined identifier: true") + (test-expression "mred^" "compile: illegal use of an expansion-time value name in: mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "define-values: illegal use (not at top-level) in: (#%define-values (x) x)") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "3/2" "3/2") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(1)") + (test-expression "argv" "#0()"))) + +(define (mzscheme) + (parameterize ([language "Textual without Debugging (MzScheme)"]) + (generic-settings #f) + (generic-output #t #t #f) + (set-language #f) + (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "cond or case: no matching clause") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "reference to undefined identifier: true") + (test-expression "mred^" "reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "define-values: illegal use (not at top-level) in: (#%define-values (x) x)") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "3/2" "3/2") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(1)") + (test-expression "argv" "#0()"))) + +(define (mred-debug) + (parameterize ([language "Graphical (MrEd)"]) + (generic-settings #f) + (generic-output #t #t #t) + (set-language #f) + (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "no matching cond clause") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #t "(letrec ([x x]) 1)" + "Variable x referenced before definition or initialization") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #f "(letrec ([x x]) 1)" "1") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "reference to undefined identifier: true") + (test-expression "mred^" "Invalid use of signature name mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "Invalid position for internal definition") + (test-expression "(letrec ([x x]) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "3/2" "3/2") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(1)") + (test-expression "argv" "#0()"))) + +(define (mzscheme-debug) + (parameterize ([language "Textual (MzScheme)"]) + (generic-settings #f) + (generic-output #t #t #t) + (set-language #f) + (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "no matching cond clause") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #t "(letrec ([x x]) 1)" + "Variable x referenced before definition or initialization") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #f "(letrec ([x x]) 1)" "1") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "reference to undefined identifier: true") + (test-expression "mred^" "reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "#t") + (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") + (test-expression "(cond [(= 1 2) 3])" "") + (test-expression "(cons 1 2)" "(1 . 2)") + (test-expression "'(1)" "(1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(#&1 #&1)") + (test-expression "(local ((define x x)) 1)" "Invalid position for internal definition") + (test-expression "(letrec ([x x]) 1)" "1") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "1") + (test-expression "1.0" "1.0") + (test-expression "#i1.0" "1.0") + (test-expression "3/2" "3/2") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(1)") + (test-expression "argv" "#0()"))) + +(define (zodiac-beginner) + (parameterize ([language "Beginning Student"]) + (zodiac) + (generic-output #f #f #t) + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" "reference to undefined identifier: time") + + (test-expression "(list make-posn posn-x posn-y posn?)" "(cons make-posn (cons posn-x (cons posn-y (cons posn? empty))))") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "true") + (test-expression "mred^" "reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "false") + (test-expression "(set! x 1)" "reference to undefined identifier: set!") + (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "'(1)" "Misuse of quote: '(1) is not a symbol") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(cons (box 1) (cons (box 1) empty))") + (test-expression "(local ((define x x)) 1)" "Invalid definition: must be at the top level") + (test-expression "(letrec ([x x]) 1)" "First term after parenthesis is illegal in an application") + (test-expression "(if 1 1 1)" "Condition value is neither true nor false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") + (test-expression "1.0" "1") + (test-expression "#i1.0" "#i1.0") + (test-expression "3/2" "1.5") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(cons 1 empty)") + (test-expression "argv" "reference to undefined identifier: argv"))) + +(define (zodiac-intermediate) + (parameterize ([language "Intermediate Student"]) + (zodiac) + (generic-output #t #f #t) + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #t "(local ((define x x)) 1)" + "Variable x referenced before definition or initialization") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #f "(local ((define x x)) 1)" "1") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "(list make-posn posn-x posn-y posn?)") + (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") + (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") + + (test-expression "true" "true") + (test-expression "mred^" "reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "false") + (test-expression "(set! x 1)" "reference to undefined identifier: set!") + (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "'(1)" "(list 1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(list (box 1) (box 1))") + (test-expression "(local ((define x x)) 1)" "Variable x referenced before definition or initialization") + (test-expression "(letrec ([x x]) 1)" "Variable x referenced before definition or initialization") + (test-expression "(if 1 1 1)" "Condition value is neither true nor false: 1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") + (test-expression "1.0" "1") + (test-expression "#i1.0" "#i1.0") + (test-expression "3/2" "1.5") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(list 1)") + (test-expression "argv" "reference to undefined identifier: argv"))) + +(define (zodiac-advanced) + (parameterize ([language "Advanced Student"]) + (zodiac) + (generic-output #t #t #t) + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #t "(local ((define x x)) 1)" + "Variable x referenced before definition or initialization") + (set-language #f) + (test-setting "Signal undefined variables when first referenced" #f "(local ((define x x)) 1)" "1") + + (test-hash-bang) + + (let ([drs (wait-for-drscheme-frame)]) + (clear-definitions drs) + (set-language #t) + (do-execute drs)) + + (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) + + (test-expression "(list make-posn posn-x posn-y posn?)" "(list make-posn posn-x posn-y posn?)") + (test-expression "set-posn-x!" "set-posn-x!") + (test-expression "set-posn-y!" "set-posn-y!") + + (test-expression "true" "true") + (test-expression "mred^" "reference to undefined identifier: mred^") + (test-expression "(eq? 'a 'A)" "false") + (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") + (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") + (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") + (test-expression "'(1)" "(list 1)") + (test-expression "(define shrd (box 1)) (list shrd shrd)" + "(shared ((-1- (box 1))) (list -1- -1-))") + (test-expression "(local ((define x x)) 1)" "Variable x referenced before definition or initialization") + (test-expression "(letrec ([x x]) 1)" "Variable x referenced before definition or initialization") + (test-expression "(if 1 1 1)" "1") + (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") + (test-expression "1.0" "1") + (test-expression "#i1.0" "#i1.0") + (test-expression "3/2" "1.5") + (test-expression "1/3" "1/3") + (test-expression "(list 1)" "(list 1)") + (test-expression "argv" "reference to undefined identifier: argv"))) + +(define (zodiac) + (generic-settings #t) + + (set-language #f) + (test-setting "Print booleans as true and false" #t "#t #f" (format "true~nfalse")) + (set-language #f) + (test-setting "Print booleans as true and false" #f "#t #f" (format "#t~n#f")) + + (set-language #f) + (test-setting "Unmatched cond/case is an error" #t "(cond [false 1])" "no matching cond clause")) + +(define (generic-settings false/true?) + (set-language #f) + (test-setting "Case sensitive" #t "(eq? 'a 'A)" (if false/true? "false" "#f")) + (set-language #f) + (test-setting "Case sensitive" #f "(eq? 'a 'A)" (if false/true? "true" "#t")) + (set-language #f) + (test-setting "Unmatched cond/case is an error" #f + (format "(cond [~a 1])" (if false/true? "false" "#f")) + "")) + +(define (generic-output list? quasi-quote? zodiac?) + (let* ([drs (wait-for-drscheme-frame)] + [expression (format "(define x (box 4/3))~n(list x x)")] + [set-output-choice + (lambda (option show-sharing rationals pretty?) + (set-language #f) + (fw:test:set-radio-box! "Output Style" option) + (when show-sharing + (fw:test:set-check-box! + "Show sharing in values" + (if (eq? show-sharing 'on) #t #f))) + (when rationals + (fw:test:set-check-box! + "Print rationals in whole/part notation" + (if (eq? rationals 'on) #t #f))) + (fw:test:set-check-box! + "Use pretty printer to format values" + pretty?) + (let ([f (get-top-level-focus-window)]) + (fw:test:button-push "OK") + (wait-for-new-frame f)))] + [test + ;; answer must either be a string, or a procedure that accepts both zero and 1 + ;; argument. When the procedure accepts 1 arg, the argument is `got' and + ;; the result must be a boolean indicating if the result was satisfactory. + ;; if the procedure receives no arguments, it must return a descriptive string + ;; for the error message + (lambda (option show-sharing rationals pretty? answer) + (set-output-choice option show-sharing rationals pretty?) + (do-execute drs) + (let ([got (fetch-output drs)]) + (unless (if (procedure? answer) + (answer got) + (whitespace-string=? answer got)) + (printf "FAILED ~a ~a, sharing ~a, rationals ~a, got ~s expected ~s~n" + (language) option show-sharing rationals got + (answer)))))]) + + (clear-definitions drs) + (type-in-definitions drs expression) + + (test "write" 'off #f #t "(#&4/3 #&4/3)") + (test "write" 'on #f #t "(#0=#&4/3 #0#)") + (when quasi-quote? + (test "Quasiquote" 'off 'off #t "`(,(box 4/3) ,(box 4/3))") + (test "Quasiquote" 'off 'on #t "`(,(box (+ 1 1/3)) ,(box (+ 1 1/3)))") + (test "Quasiquote" 'on 'off #t "(shared ((-1- (box 4/3))) `(,-1- ,-1-))") + (test "Quasiquote" 'on 'on #t "(shared ((-1- (box (+ 1 1/3)))) `(,-1- ,-1-))")) + (test "Constructor" 'off 'off #t + (if list? + "(list (box 4/3) (box 4/3))" + "(cons (box 4/3) (cons (box 4/3) empty))")) + (test "Constructor" 'off 'on #t + (if list? + "(list (box (+ 1 1/3)) (box (+ 1 1/3)))" + "(cons (box (+ 1 1/3)) (cons (box (+ 1 1/3)) empty))")) + (test "Constructor" 'on 'off #t + (if list? + "(shared ((-1- (box 4/3))) (list -1- -1-))" + (format "(shared ((-1- (box 4/3))) (cons -1- (cons -1- empty)))"))) + (test "Constructor" 'on 'on #t + (if list? + "(shared ((-1- (box (+ 1 1/3)))) (list -1- -1-))" + (format "(shared ((-1- (box (+ 1 1/3)))) (cons -1- (cons -1- empty)))"))) + + + ;; setup comment box + (clear-definitions drs) + (fw:test:menu-select "Edit" "Insert Text Box") + (fw:test:keystroke #\a) + (fw:test:keystroke #\b) + (fw:test:keystroke #\c) + + ;; test comment box in print-convert and print-convert-less settings + (test "Constructor" 'on 'on #t (if zodiac? "[abc]" "'non-string-snip")) + (test "write" 'on #f #t (if zodiac? "[abc]" "non-string-snip")) + + ;; setup write / pretty-print difference + (clear-definitions drs) + (for-each fw:test:keystroke + (string->list + "(define(f n)(cond((zero? n)null)[else(cons n(f(- n 1)))]))(f 40)")) + (test "Constructor" 'on 'on #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "Constructor" 'on 'on #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])) + (test "write" #f #f #f + (case-lambda + [(x) (not (member #\newline (string->list x)))] + [() "no newlines in result"])) + (test "write" #f #f #t + (case-lambda + [(x) (member #\newline (string->list x))] + [() "newlines in result (may need to make the window smaller)"])))) + +(define (whitespace-string=? string1 string2) + (let loop ([i 0] + [j 0] + [in-whitespace? #t]) + (cond + [(= i (string-length string1)) (only-whitespace? string2 j)] + [(= j (string-length string2)) (only-whitespace? string1 i)] + [else (let ([c1 (string-ref string1 i)] + [c2 (string-ref string2 j)]) + (cond + [in-whitespace? + (cond + [(whitespace? c1) + (loop (+ i 1) + j + #t)] + [(whitespace? c2) + (loop i + (+ j 1) + #t)] + [else (loop i j #f)])] + [(and (whitespace? c1) + (whitespace? c2)) + (loop (+ i 1) + (+ j 1) + #t)] + [(char=? c1 c2) + (loop (+ i 1) + (+ j 1) + #f)] + [else #f]))]))) + +(define (whitespace? c) + (or (char=? c #\newline) + (char=? c #\space) + (char=? c #\tab) + (char=? c #\return))) + +(define (only-whitespace? str i) + (let loop ([n i]) + (cond + [(= n (string-length str)) + #t] + [(whitespace? (string-ref str n)) + (loop (+ n 1))] + [else #f]))) + +;; whitespace-string=? tests +'(map (lambda (x) (apply equal? x)) + (list (list #t (whitespace-string=? "a" "a")) + (list #f (whitespace-string=? "a" "A")) + (list #f (whitespace-string=? "a" " ")) + (list #f (whitespace-string=? " " "A")) + (list #t (whitespace-string=? " " " ")) + (list #t (whitespace-string=? " " " ")) + (list #t (whitespace-string=? " " " ")) + (list #t (whitespace-string=? " " " ")) + (list #t (whitespace-string=? "a a" "a a")) + (list #t (whitespace-string=? "a a" "a a")) + (list #t (whitespace-string=? "a a" "a a")) + (list #t (whitespace-string=? " a" "a")) + (list #t (whitespace-string=? "a" " a")) + (list #t (whitespace-string=? "a " "a")) + (list #t (whitespace-string=? "a" "a ")))) + +(define (test-expression expression expected) + (let* ([drs (wait-for-drscheme-frame)] + [interactions-text (ivar drs interactions-text)] + [last-para (send interactions-text last-paragraph)]) + (send interactions-text set-position + (send interactions-text last-position) + (send interactions-text last-position)) + (type-in-interactions drs expression) + (type-in-interactions drs (string #\newline)) + (wait-for-computation drs) + (let ([got + (fetch-output + drs + (send interactions-text paragraph-start-position (+ last-para 1)) + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))]) + (unless (whitespace-string=? got expected) + (printf "FAILED: ~a expected ~s to produce ~s, got ~s instead~n" + (language) expression expected got))))) + + +;; clear teachpack +(let ([drs (wait-for-drscheme-frame)]) + (fw:test:menu-select "Language" "Clear All Teachpacks")) + +(zodiac-beginner) +(zodiac-intermediate) +(zodiac-advanced) +(mzscheme-debug) +(mred-debug) +(mzscheme) +(mred) diff --git a/collects/tests/drscheme/launcher.ss b/collects/tests/drscheme/launcher.ss new file mode 100644 index 00000000..ea7a9189 --- /dev/null +++ b/collects/tests/drscheme/launcher.ss @@ -0,0 +1,96 @@ +(define tmp-filename + (build-path (collection-path "tests" "drscheme") + "launcher-test-tmp.ss")) +(define tmp-launcher + (build-path (collection-path "tests" "drscheme") + (case (system-type) + [(unix) "launcher-test-tmp"] + [(windows) "launcher-test-tmp.exe"] + [else (error 'launcher.ss "cannot run this test under ~s" (system-type))]))) +(define tmp-teachpack + (build-path (collection-path "tests" "drscheme") + "launcher-test-teachpack.ss")) + +(define (get-port) + (let loop ([n 100]) + (unless (zero? n) + (with-handlers ([(lambda (x) #t) + (lambda (x) + (loop (- n 1)))]) + (let ([tcp-port (+ 51700 n)]) + (values tcp-port + (tcp-listen tcp-port))))))) + +(define (run-launcher/no-teachpack listener test expected) + (when (file-exists? tmp-launcher) + (delete-file tmp-launcher)) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "Scheme" "Create Launcher...")) + tmp-launcher) + (let-values ([(l-in l-out l-pid l-err l-proc) (apply values (process* tmp-launcher))] + [(in out) (tcp-accept listener)]) + (let ([got (read in)]) + (unless (equal? expected got) + (error test "expected ~s, got ~s" expected got))))) + +(define (teachpackless-test) + (define-values (port-num listener) (get-port)) + (define drs (wait-for-drscheme-frame)) + (clear-definitions drs) + (type-in-definitions + drs + `(let-values ([(in out) (tcp-connect "localhost" ,port-num)]) + (write 'the-correct-answer out) + (newline out))) + (when (file-exists? tmp-filename) + (delete-file tmp-filename)) + (save-drscheme-window-as tmp-filename) + (set-language-level! "Graphical without Debugging (MrEd)") + (run-launcher/no-teachpack listener 'no-teachpack 'the-correct-answer)) + +(define (teachpack-test language insert-junk) + (define-values (port-num listener) (get-port)) + (define drs (wait-for-drscheme-frame)) + (set-language-level! language) + (call-with-output-file tmp-teachpack + (lambda (port) + (write + `(unit/sig (send-back) + (import plt:userspace^) + (define (send-back sexp) + (let-values ([(in out) (tcp-connect "localhost" ,port-num)]) + (write sexp out) + (newline out) + (close-output-port out) + (close-input-port in)))) + port)) + 'truncate) + (clear-definitions drs) + (insert-junk) + (type-in-definitions drs `(send-back 'the-correct-answer)) + (fw:test:menu-select "File" "Save Definitions") + (fw:test:menu-select "Language" "Clear All Teachpacks") + (use-get/put-dialog + (lambda () + (fw:test:menu-select "Language" "Add Teachpack...")) + tmp-teachpack) + (run-launcher/no-teachpack listener 'teachpack-beginner 'the-correct-answer)) + +(teachpackless-test) + +;(teachpack-test "Graphical (MrEd)" void) +;(teachpack-test "Textual (MzScheme)" void) +;(teachpack-test "Textual without Debugging (MzScheme)" void) +;(teachpack-test "Graphical without Debugging (MrEd)" void) +;(teachpack-test "Beginning Student" void) +;(teachpack-test "Intermediate Student" void) +;(teachpack-test "Advanced Student" void) + +(teachpack-test "Beginning Student" + (lambda () + (let ([drs (wait-for-drscheme-frame)]) + (fw:test:menu-select "Edit" "Insert Text Box") + (fw:test:keystroke #\a) + (fw:test:keystroke #\b) + (fw:test:keystroke #\c)))) \ No newline at end of file diff --git a/collects/tests/drscheme/line-art.ss b/collects/tests/drscheme/line-art.ss new file mode 100644 index 00000000..7c1d918b --- /dev/null +++ b/collects/tests/drscheme/line-art.ss @@ -0,0 +1,27 @@ +(lambda (a b c d e f g h i j k l m n o p q r ss t u v w x y z) + (list z + y + x + w + v + u + t + ss + r + q + p + o + n + m + l + k + j + i + h + g + f + e + d + c + b + a)) \ No newline at end of file diff --git a/collects/tests/drscheme/menu-test.ss b/collects/tests/drscheme/menu-test.ss new file mode 100644 index 00000000..d23b1566 --- /dev/null +++ b/collects/tests/drscheme/menu-test.ss @@ -0,0 +1,82 @@ +;;; menu-test.ss + +;;; tests the various menu items in the DrScheme menubar + +;;; Author: Paul Steckler, based on earlier code by Robby Findler + +(load "drscheme-test-util.ss") + +;; Under X, the validity of these tests requires that the window +;; with the mouse cursor is active. That's not necessarily the case. + +(let* ([frame (wait-for-drscheme-frame)] + + [eq-frame? (lambda () (eq? (mred:test:get-active-frame) frame))] + + [dialog-test + (lambda (menu) + (lambda (item) + (mred:test:menu-select menu item) + (wait (lambda () (not (eq-frame?))) + (string-append + "Didn't get a new frame after selecting " + menu "|" item)) + (mred:test:button-push "Cancel") + (wait-pending) + (wait eq-frame? + (string-append + "Original DrScheme frame not active after cancelling File|" + item))))] + + [file-dialog-test (dialog-test "File")] + [edit-dialog-test (dialog-test "Edit")] + [language-dialog-test (dialog-test "Language")] + + [file-dialog-items + '("Open..." + "Open URL..." + "Save Definitions As..." + "Save Definitions As Text..." + "Save Interactions" + "Save Interactions As..." + "Save Interactions As Text..." + + ; we omit the print dialogs, because the test primitives + ; only work with MrEd-derived classes + + "Close" ; do this 3 times, per Robby + "Close" + "Close" + + ; the Quit dialog also seems not to work with the test primitives + + )] + + [edit-dialog-items + '("Preferences...")] + + [language-dialog-items + '("Configure Language..." + "Set Library To...")]) + + ; this makes sure REPL is loaded + + (type-in-definitions frame "a") + + (for-each file-dialog-test file-dialog-items) + (printf "File menu tests complete~n") + + (for-each edit-dialog-test edit-dialog-items) + (printf "Edit menu tests complete~n") + + (for-each language-dialog-test language-dialog-items) + (printf "Language menu tests complete~n") + + (printf "All menu tests complete~n")) + +; in old autosave+prompt-save.ss, we had: + +; ((load-relative (build-path 'up "mred" "gui-main.ss")) +; "New Unit" +; "Save Definitions" +; wx:frame%) diff --git a/collects/tests/drscheme/pr-144.ss b/collects/tests/drscheme/pr-144.ss new file mode 100644 index 00000000..5e0bd1c3 --- /dev/null +++ b/collects/tests/drscheme/pr-144.ss @@ -0,0 +1,106 @@ +;;; pr-144.ss + +;;; Open the preferences dialog, go to the check syntax section. +;;; Wait for the autosave delay and make sure no autosaves appear. + +(require-library "function.ss") + +(load-relative "drscheme-test-util.ss") + +(let* ([drs-frame (wait-for-drscheme-frame)] + [seconds 5] + [autosave-prefix "#mredauto#"] + [autosave-prefix-len (string-length autosave-prefix)] + [definitions-edit (ivar drs-frame definitions-edit)] + [autosave-save (mred:get-preference 'mred:autosaving-on?)] + [autosave-delay-save (mred:get-preference 'mred:autosave-delay)] + [get-font-cbs + (lambda (lst) + (let ([get-cb-with-label + (lambda (label) + (car (memf (lambda (elt) + (and (is-a? elt mred:check-box%) + (string=? (send elt get-label) label))) + lst)))]) + (map get-cb-with-label '("Slant" "Bold" "Underline"))))] + [autosave-file? + (lambda (filename) + (and (> (string-length filename) autosave-prefix-len) + (string=? (substring filename 0 autosave-prefix-len) + autosave-prefix)))] + [open-preferences + (lambda () + (mred:test:menu-select "Edit" "Preferences...") + (let* ([frame + (letrec ([loop + (lambda () + (let ([active (mred:test:get-active-frame)]) + (if (or (eq? active #f) + (eq? active drs-frame)) + (begin + (sleep 1/2) + (loop)) + active)))]) + (loop))] + [panel (send frame get-top-panel)] + [children (ivar panel children)] + [choice-box (car children)] + [choice-box-event + (let ([event-obj + (make-object wx:command-event% + wx:const-event-type-choice-command)]) + (send event-obj set-event-object choice-box) + event-obj)]) + (send choice-box-event set-command-int + (send choice-box find-string "Check Syntax")) + (send choice-box command choice-box-event) + + (let* ([upper-panel (cadr children)] + [check-syntax-panel (send upper-panel active-child)] + [check-box-panels (ivar check-syntax-panel children)] + + [syntax-panel (car check-box-panels)] + [syntax-check-boxes (get-font-cbs (ivar syntax-panel children))] + [curr-states (map (lambda (cb) (send cb get-value)) + syntax-check-boxes)]) + + ; toggle current states of syntax checkboxes + ; we're going to hit Cancel, so nothing should take effect + + (map (lambda (cb state) + (mred:test:set-check-box! cb (not state))) + syntax-check-boxes + curr-states))))]) + + ; delete any existing autosave files + + (for-each + (lambda (filename) + (when (autosave-file? filename) + (delete-file filename))) + (directory-list)) + + (mred:set-preference 'mred:autosaving-on? #t) + (mred:set-preference 'mred:autosave-delay seconds) + + (open-preferences) + + (sleep (+ seconds 5)) + + ; now see if there are any autosave files + + (if (ormap autosave-file? (directory-list)) + (printf "Autosave test failed~n") + (printf "Autosave test succeeded~n")) + + (mred:test:button-push "Cancel") + + (mred:set-preference 'mred:autosaving-on? autosave-save) + (mred:set-preference 'mred:autosave-delay autosave-delay-save)) + + + + + + + diff --git a/collects/tests/drscheme/pr-17.ss b/collects/tests/drscheme/pr-17.ss new file mode 100644 index 00000000..3e79d70d --- /dev/null +++ b/collects/tests/drscheme/pr-17.ss @@ -0,0 +1,69 @@ +;;; pr-17.ss + +;;; Create new frame, check that all buttons and menus exist + +;;; Author: Paul Steckler + +(load-relative "drscheme-test-util.ss") + +(define-macro check-for-button + (lambda (button s) + `(unless (ivar drscheme-frame-new ,button) + (printf "Missing ~a button" ,s)))) + +(let* ([drscheme-frame (wait-for-drscheme-frame)] + [drscheme-frame-new 'dummy] + [menubar (send drscheme-frame get-menu-bar)] + [menubar-new 'dummy] + [menus-expected + (if (eq? wx:platform 'windows) + '("&File" "&Edit" "&Windows" "&View" "S&cheme" "&Language" "&Help") + '("File" "Edit" "Windows" "View" "Scheme" "Language" "Help"))] + [buttons-expected '(check-syntax analyze execute break)] + [check-menus + (lambda () + (letrec ([loop + (lambda (lst n) + (if (null? lst) + #t + (let ([expected-item (car lst)] + [actual-item (send menubar-new get-label-top n)]) + (if (string=? expected-item actual-item) + (loop (cdr lst) (add1 n)) + (printf "Expected menu ~a but found ~a~n" + expected-item + actual-item)))))]) + (loop menus-expected 0)))] + [button-error + (lambda (s) + (printf "Can't find ~a button~n" s))]) + + ; open new unit window + + (mred:test:menu-select "File" "New") + + ; get data structures for new window + + (set! drscheme-frame-new (wait-for-new-drscheme-frame drscheme-frame)) + (set! menubar-new (send drscheme-frame-new get-menu-bar)) + + ; compare old and new + + (printf "Checking menus ... ") + + (check-menus) + + (printf "checking buttons ... ") + + (check-for-button check-syntax-button "check syntax") + (check-for-button analyze-button "analyze") + (check-for-button execute-button "execute") + (check-for-button stop-execute-button "break") + + (printf "done~n") + + (mred:test:menu-select "File" "Close")) + + + + diff --git a/collects/tests/drscheme/pr-246.ss b/collects/tests/drscheme/pr-246.ss new file mode 100644 index 00000000..e1b6f17f --- /dev/null +++ b/collects/tests/drscheme/pr-246.ss @@ -0,0 +1,47 @@ +;;; pr-246.ss + +;;; make sure (cons 1 2) is an error in beginner-level Scheme + +;;; pr-58.ss + +;;; tests check-syntax when given bogus improper list +;;; tested at each language level + +;;; Author: Paul Steckler + +(load-relative "drscheme-test-util.ss") + +(let* ([drs-frame (wait-for-drscheme-frame)] + [interactions-edit (ivar drs-frame interactions-edit)] + [execute-button (ivar drs-frame execute-button)] + [get-int-pos (lambda () (get-text-pos interactions-edit))] + [check-execute ; type in term, call execute + (lambda (str expected) + (clear-definitions drs-frame) + (push-button-and-wait execute-button) ; clears out any text in interactions-edit + (type-in-definitions drs-frame str) + (let ([answer-begin (get-int-pos)]) + (push-button-and-wait execute-button) + (let* ([answer-end (- (get-int-pos) 1)] + [actual (send interactions-edit get-text + answer-begin answer-end)]) + (unless (string=? actual expected) + (printf "Expected: ~a~n Actual: ~a~n~n" + expected actual)) + (let ([frame (mred:test:get-active-frame)]) + (unless (eq? frame drs-frame) + (error 'check-syntax "Unexpected window ~a" frame))))))]) + + (printf "Starting test~n") + + (set-language-level! "Beginner" drs-frame) + + (check-execute "(cons 1 2)" + "cons: second argument must be of type , given 1 and 2") + + ; end pr-246 + + (printf "Finished test~n")) + + + diff --git a/collects/tests/drscheme/pr-39.ss b/collects/tests/drscheme/pr-39.ss new file mode 100644 index 00000000..a4bcb22e --- /dev/null +++ b/collects/tests/drscheme/pr-39.ss @@ -0,0 +1,8 @@ +;;; pr-39.ss + +;;; this generated error before + +(require-library "referf.ss") + + + \ No newline at end of file diff --git a/collects/tests/drscheme/pr-46.ss b/collects/tests/drscheme/pr-46.ss new file mode 100644 index 00000000..a9c12924 --- /dev/null +++ b/collects/tests/drscheme/pr-46.ss @@ -0,0 +1,35 @@ +;;; pr-46.ss + +;;; tests register-will in the interactions window + +(load-relative "drscheme-test-util.ss") + +(let* ([drs-frame (wait-for-drscheme-frame)] + [interactions-edit (ivar drs-frame interactions-edit)] + [execute-button (ivar drs-frame execute-button)] + [get-int-pos (lambda () (get-text-pos interactions-edit))] + [check-execute ; type in term, hit execute + (lambda (str expected) + (clear-definitions drs-frame) + (type-in-definitions drs-frame str) + (let ([answer-begin (+ (get-int-pos) 3)]) + (push-button-and-wait execute-button) + (let ([answer-end (- (get-int-pos) 1)]) + (let ([actual (send interactions-edit get-text + answer-begin answer-end)]) + (unless (string=? actual expected) + (printf "Expected: ~a~n Actual: ~a~n~n" + expected actual))) + (let ([frame (mred:test:get-active-frame)]) + (unless (eq? frame drs-frame) + (error 'check-syntax "Unexpected window ~a" frame))))))] + [terms-and-msgs + '(("(register-will (list 1 2 3) display)" "") + ("(collect-garbage)" ""))]) + + (for-each + (lambda (p) (check-execute (car p) (cadr p))) + terms-and-msgs)) + + + \ No newline at end of file diff --git a/collects/tests/drscheme/pr-48.ss b/collects/tests/drscheme/pr-48.ss new file mode 100644 index 00000000..32a30a34 --- /dev/null +++ b/collects/tests/drscheme/pr-48.ss @@ -0,0 +1,383 @@ +;;; pr-48.ss + +;;; tests font style changes to text after syntax check + +;;; Author: Paul Steckler + +(require-library "function.ss") + +(load-relative "drscheme-test-util.ss") + +; a font description is a list + +(define make-font-desc + (lambda (slant weight uline) + (list slant weight uline))) + +(define slant car) +(define weight cadr) +(define uline caddr) + +; the descriptions for the 5 different syntax items should be +; distinct from one another + +(define normal-font-desc + (make-font-desc wx:const-normal wx:const-normal #f)) + +(define syn-font-desc + (make-font-desc wx:const-normal wx:const-bold #t)) + +(define prim-font-desc + (make-font-desc wx:const-slant wx:const-normal #f)) + +(define const-font-desc + (make-font-desc wx:const-normal wx:const-bold #f)) + +(define bound-var-font-desc + (make-font-desc wx:const-slant wx:const-bold #t)) + +(define free-var-font-desc + (make-font-desc wx:const-normal wx:const-normal #t)) + +; a problem is a syntax string and a list of font descriptions +; for each character in the string + +(define problem + (lambda (str descs) + (list str descs))) + +(let* ([drs-frame (wait-for-drscheme-frame)] + [definitions-edit (ivar drs-frame definitions-edit)] + [get-font-cbs + (lambda (lst) + (let ([get-cb-with-label + (lambda (label) + (car (memf (lambda (elt) + (and (is-a? elt mred:check-box%) + (string=? (send elt get-label) label))) + lst)))]) + (map get-cb-with-label '("Slant" "Bold" "Underline"))))] + [set-check-boxes! + (lambda (cbs desc) + (mred:test:set-check-box! (slant cbs) + (if (eq? (slant desc) wx:const-normal) + #f + #t)) + (mred:test:set-check-box! (weight cbs) + (if (eq? (weight desc) wx:const-normal) + #f + #t)) + (mred:test:set-check-box! (uline cbs) (uline desc)))] + [set-syn-check-preferences! + (lambda () + (mred:test:menu-select "Edit" "Preferences...") + (let* ([frame + (letrec ([loop + (lambda () + (let ([active (mred:test:get-active-frame)]) + (if (or (eq? active #f) + (eq? active drs-frame)) + (begin + (sleep 1/2) + (loop)) + active)))]) + (loop))] + [panel (send frame get-top-panel)] + [children (ivar panel children)] + [choice-box (car children)] + [choice-box-event + (let ([event-obj + (make-object wx:command-event% + wx:const-event-type-choice-command)]) + (send event-obj set-event-object choice-box) + event-obj)]) + (send choice-box-event set-command-int + (send choice-box find-string "Check Syntax")) + (send choice-box command choice-box-event) + + (let* ([upper-panel (cadr children)] + [check-syntax-panel (send upper-panel active-child)] + [check-box-panels (ivar check-syntax-panel children)] + + [syntax-panel (car check-box-panels)] + [syntax-check-boxes (get-font-cbs (ivar syntax-panel children))] + + [primitive-panel (cadr check-box-panels)] + [primitive-check-boxes (get-font-cbs (ivar primitive-panel children))] + + [constant-panel (caddr check-box-panels)] + [constant-check-boxes (get-font-cbs (ivar constant-panel children))] + + [bound-var-panel (cadddr check-box-panels)] + [bound-var-check-boxes (get-font-cbs (ivar bound-var-panel children))] + + [free-var-panel (car (cddddr check-box-panels))] + [free-var-check-boxes (get-font-cbs (ivar free-var-panel children))]) + + (for-each + + (lambda (p) + (set-check-boxes! (car p) (cadr p))) + + (list + (list syntax-check-boxes syn-font-desc) + (list primitive-check-boxes prim-font-desc) + (list constant-check-boxes const-font-desc) + (list bound-var-check-boxes bound-var-font-desc) + (list free-var-check-boxes free-var-font-desc))) + + (mred:test:button-push "OK"))))] + [print-desc + (lambda (d) + (let ([slant + (let ([slant-res (slant d)]) + (cond + [(eq? slant-res wx:const-normal) + 'normal-slant] + [(eq? slant-res wx:const-slant) + 'slant] + [(eq? slant-res wx:const-italic) + 'italic] + [else + 'unknown]))] + [weight + (let ([weight-res (weight d)]) + (cond + [(eq? weight-res wx:const-normal) + 'normal-weight] + [(eq? weight-res wx:const-light) + 'light] + [(eq? weight-res wx:const-bold) + 'bold] + [else + 'unknown]))] + [uline (case (uline d) + [(#t) 'underline] + [(#f) 'no-underline] + [else (number->string (uline d))])]) + (printf "~a/~a/~a~n" slant weight uline)))] + [check-check-syntax-fonts + (lambda (problem) + (letrec* + ([str (car problem)] + [font-descs (cadr problem)] + [loop + (lambda (n descs) + (if (null? descs) + '() + (let* ([the-snip (send definitions-edit + find-snip n wx:const-snip-after)] + [the-style (send the-snip get-style)] + [the-font (send the-style get-font)] + [exp-desc (car descs)] + [actual-desc + (list (send the-font get-style) + (send the-font get-weight) + (send the-font get-underlined))]) + (if (equal? exp-desc actual-desc) + (loop (add1 n) (cdr descs)) + (begin + (printf "*** Failed on input ~a ***~n" str) + (printf "At position ~a:~nExpected style: " n) + (print-desc exp-desc) + (printf "Actual style: ") + (print-desc actual-desc))))))]) + (clear-definitions drs-frame) + (type-in-definitions drs-frame str) + (mred:test:button-push (ivar drs-frame check-syntax-button)) + (loop 0 font-descs)))]) + + ; set syntax-check font preferences in dialog + + (set-syn-check-preferences!) + + ; now run problems + + (wait-for-drscheme-frame) + + ; a problem is a pair: + ; the first element is a piece of syntax to check + ; the second element is a list of font descriptions, + ; one for each character in the syntax + + (for-each check-check-syntax-fonts + + (list + + (problem + + "(or 1 2 3)" + + (list + normal-font-desc ; ( + syn-font-desc ; o + syn-font-desc ; r + normal-font-desc ; _ + const-font-desc ; 1 + normal-font-desc ; _ + const-font-desc ; 2 + normal-font-desc ; _ + const-font-desc ; 3 + normal-font-desc ; ) + )) + + (problem + + "(and 1 2 3)" + + (list + normal-font-desc ; ( + syn-font-desc ; a + syn-font-desc ; n + syn-font-desc ; d + normal-font-desc ; _ + const-font-desc ; 1 + normal-font-desc ; _ + const-font-desc ; 2 + normal-font-desc ; _ + const-font-desc ; 3 + normal-font-desc ; ) + )) + + (problem + + "'(a b c)" + + (list + const-font-desc ; ' + const-font-desc ; ( + const-font-desc ; a + const-font-desc ; _ + const-font-desc ; b + const-font-desc ; _ + const-font-desc ; c + const-font-desc ; ) + + )) + + (problem + + "(quote x)" + + (list + const-font-desc ; ( + const-font-desc ; q + const-font-desc ; u + const-font-desc ; o + const-font-desc ; t + const-font-desc ; e + const-font-desc ; _ + const-font-desc ; x + const-font-desc ; ) + )) + + (problem + + "(quasiquote x)" + + (list + const-font-desc ; ( + const-font-desc ; q + const-font-desc ; u + const-font-desc ; a + const-font-desc ; s + const-font-desc ; i + const-font-desc ; q + const-font-desc ; u + const-font-desc ; o + const-font-desc ; t + const-font-desc ; e + const-font-desc ; _ + const-font-desc ; x + const-font-desc ; ) + )) + + (problem + + "#&a" + + (list + + const-font-desc ; # + const-font-desc ; & + const-font-desc ; a + )) + + (problem + + "#&\"hi\"" + + (list + + const-font-desc ; # + const-font-desc ; & + const-font-desc ; " + const-font-desc ; h + const-font-desc ; i + const-font-desc ; " + )) + + (problem + + "#&2" + + (list + + const-font-desc ; # + const-font-desc ; & + const-font-desc ; 2 + )) + + (problem + + "(define x 3)" + + (list + + normal-font-desc ; ( + syn-font-desc ; d + syn-font-desc ; e + syn-font-desc ; f + syn-font-desc ; i + syn-font-desc ; n + syn-font-desc ; e + normal-font-desc ; _ + bound-var-font-desc ; x + normal-font-desc ; _ + const-font-desc ; 3 + normal-font-desc ; ) + )) + + (problem + + "(local ([define x 3]) x)" + + (list + + normal-font-desc ; ( + syn-font-desc ; l + syn-font-desc ; o + syn-font-desc ; c + syn-font-desc ; a + syn-font-desc ; l + normal-font-desc ; + normal-font-desc ; ( + normal-font-desc ; [ + syn-font-desc ; d + syn-font-desc ; e + syn-font-desc ; f + syn-font-desc ; i + syn-font-desc ; n + syn-font-desc ; e + normal-font-desc ; + bound-var-font-desc ; x + normal-font-desc ; + const-font-desc ; 3 + normal-font-desc ; ] + normal-font-desc ; ) + const-font-desc ; + bound-var-font-desc ; x + normal-font-desc ; ) + )) + + ))) diff --git a/collects/tests/drscheme/pr-51.dir/1.ss b/collects/tests/drscheme/pr-51.dir/1.ss new file mode 100644 index 00000000..466ca277 --- /dev/null +++ b/collects/tests/drscheme/pr-51.dir/1.ss @@ -0,0 +1,3 @@ +;;; 1.ss -- needed for pr-51.ss + +(load-relative "2.ss") diff --git a/collects/tests/drscheme/pr-51.dir/2.ss b/collects/tests/drscheme/pr-51.dir/2.ss new file mode 100644 index 00000000..d573477e --- /dev/null +++ b/collects/tests/drscheme/pr-51.dir/2.ss @@ -0,0 +1,3 @@ +;;; 2.ss -- needed for pr-51.ss + +(printf "This string should print!~n") diff --git a/collects/tests/drscheme/pr-51.ss b/collects/tests/drscheme/pr-51.ss new file mode 100644 index 00000000..87e159f8 --- /dev/null +++ b/collects/tests/drscheme/pr-51.ss @@ -0,0 +1,5 @@ +;;; pr-51.ss + +;;; tests printing while loading files in a subdirectory + +(require (build-path "pr-51.dir" "1.ss")) diff --git a/collects/tests/drscheme/pr-58.ss b/collects/tests/drscheme/pr-58.ss new file mode 100644 index 00000000..f7a314c4 --- /dev/null +++ b/collects/tests/drscheme/pr-58.ss @@ -0,0 +1,54 @@ +;;; pr-58.ss + +;;; tests check-syntax when given bogus improper list +;;; tested at each language level + +;;; Author: Paul Steckler + +(load-relative "drscheme-test-util.ss") + +(let* ([drs-frame (wait-for-drscheme-frame)] + [interactions-edit (ivar drs-frame interactions-edit)] + [execute-button (ivar drs-frame execute-button)] + [get-int-pos (lambda () (get-text-pos interactions-edit))] + [check-check-syntax ; type in term, call check-syntax + (lambda (str expected) + (clear-definitions drs-frame) + (type-in-definitions drs-frame str) + (push-button-and-wait execute-button) + (let ([answer-begin (+ (get-int-pos) 3)]) + (mred:test:button-push (ivar drs-frame check-syntax-button)) + (let* ([answer-end (- (get-int-pos) 1)] + [actual (send interactions-edit get-text + answer-begin answer-end)]) + (unless (string=? actual expected) + (printf "Expected: ~a~n Actual: ~a~n~n" + expected actual)) + (let ([frame (mred:test:get-active-frame)]) + (unless (eq? frame drs-frame) + (error 'check-syntax "Unexpected window ~a" frame))))))]) + + (printf "Starting tests~n") + + (set-language-level! "Beginner" drs-frame) + + (check-check-syntax "'(a . b)" "improper lists are not allowed") + + ; from pr-246 + ; execute says "cons: second argument must be of type , given 1 and 2") + + (check-check-syntax "(cons 1 2)" "") + + ; end pr-246 + + (set-language-level! "Intermediate" drs-frame) + (check-check-syntax "'(a . b)" "improper lists are not allowed") + + (set-language-level! "Advanced" drs-frame) + (check-check-syntax "'(a . b)" "improper lists are not allowed") + + (set-language-level! "R4RS+" drs-frame) + (check-check-syntax "'(a . b)" "") + + (printf "Finished tests~n")) + diff --git a/collects/tests/drscheme/pr-80.ss b/collects/tests/drscheme/pr-80.ss new file mode 100644 index 00000000..444ee040 --- /dev/null +++ b/collects/tests/drscheme/pr-80.ss @@ -0,0 +1,29 @@ +;;; pr-80.ss + +;;; Create a frame with buggy callback in the definitions window. +;;; After invoking the callback, make sure the source text is properly highlighted. + +(load-relative "drscheme-test-util.ss") + +(letrec* ([_ (wait-for-drscheme-frame)] + [drscheme-frame (mred:test:get-active-frame)] + [eq-frame? (lambda () (eq? (mred:test:get-active-frame) drscheme-frame))] + [interactions-edit (ivar drscheme-frame interactions-edit)] + [interactions-canvas (ivar drscheme-frame interactions-canvas)] + [definitions-edit (ivar drscheme-frame definitions-edit)] + [definitions-canvas (ivar drscheme-frame definitions-canvas)] + [execute-button (ivar drscheme-frame execute-button)] + [code "(let* ([frame (make-object mred:frame% null \"MyFrame\" 100 100 200 300)] + [panel (make-object mred:vertical-panel% frame)] + [button (make-object mred:button% panel + (lambda (self event) + (send frame show #f) (car 4)) + \"Push me\")]) + (send frame show #t))"]) + + (type-in-definitions drscheme-frame code) + (push-button-and-wait execute-button) + + (printf "Code in callback should be highlighted~n")) + + diff --git a/collects/tests/drscheme/pr-99.ss b/collects/tests/drscheme/pr-99.ss new file mode 100644 index 00000000..8637193a --- /dev/null +++ b/collects/tests/drscheme/pr-99.ss @@ -0,0 +1,11 @@ +;;; pr-99.ss + +(define x 5) + +(thread-wait (thread (lambda () (set! x (current-parameterization))))) + +(if (eq? x (current-parameterization)) + (printf "Test is *not* successful~n") + (printf "Test is successful~n")) + + \ No newline at end of file diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss new file mode 100644 index 00000000..0830d996 --- /dev/null +++ b/collects/tests/drscheme/repl-test.ss @@ -0,0 +1,490 @@ +(define-struct test (program + r4rs-load-answer prepend-filename? r4rs-execute-answer r4rs-execute-location + mred-execute-answer mred-load-answer mred-read-test? breaking-test?)) + +(define test-data + (list + + ;; basic tests + (make-test "(" + "1.1-1.2: missing close paren" + #t + "missing close paren" + (vector 0 1) + "read: expected a ')'; started at position 1 in " + "read: expected a ')'; started at position 1, line 1 in " + #t + #f) + (make-test "." + "1.1-1.2: can't use `.' outside list" + #t + "can't use `.' outside list" + (vector 0 1) + "read: illegal use of \".\" at position 1 in " + "read: illegal use of \".\" at position 1, line 1 in " + #t + #f) + (make-test "(lambda ())" + "1.1-1.12: Malformed lambda" + #t + "Malformed lambda" + (vector 0 11) + "lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())" + #f + #f) + (make-test "x" + "1.1-1.2: reference to undefined identifier: x" + #t + "reference to undefined identifier: x" + (vector 0 1) + "reference to undefined identifier: x" + "reference to undefined identifier: x" + #f + #f) + (make-test "(raise 1)" + "uncaught exception: 1" + #f + "uncaught exception: 1" + #f + "uncaught exception: 1" + "uncaught exception: 1" + #f + #f) + (make-test "(raise #f)" + "uncaught exception: #f" + #f + "uncaught exception: #f" + #f + "uncaught exception: #f" + "uncaught exception: #f" + #f + #f) + (make-test "(values 1 2)" + (format "1~n2") + #f + (format "1~n2") + #f + (format "1~n2") + (format "1~n2") + #f + #f) + (make-test "(list 1 2)" + "(1 2)" + #f + "(1 2)" + #f + "(1 2)" + "(1 2)" + #f + #f) + + ;; eval tests + (make-test " (eval '(values 1 2))" + (format "1~n2") + #f + (format "1~n2") + #f + (format "1~n2") + (format "1~n2") + #f + #f) + (make-test " (eval '(list 1 2))" + "(1 2)" + #f + "(1 2)" + #f + "(1 2)" + "(1 2)" + #f + #f) + (make-test " (eval '(lambda ()))" + "1.5-1.24: Malformed lambda" + #t + "Malformed lambda" + (vector 4 23) + "lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())" + #f + #f) + (make-test " (eval 'x)" + "1.5-1.14: reference to undefined identifier: x" + #t + "reference to undefined identifier: x" + (vector 4 13) + "reference to undefined identifier: x" + "reference to undefined identifier: x" + #f + #f) + + ;; printer setup test + (make-test "(car (void))" + "1.1-1.13: car: expects argument of type ; given #" + #t + "car: expects argument of type ; given #" + (vector 0 12) + "car: expects argument of type ; given #" + "car: expects argument of type ; given #" + #f + #f) + + + ;; error in the middle + (make-test "1 2 ( 3 4" + "1.5-1.6: missing close paren" + #t + (format "1~n2~nmissing close paren") + (vector 4 5) + (format "1~n2~nread: expected a ')'; started at position 5 in ") + (format "read: expected a ')'; started at position 5, line 1 in ") + #t + #f) + (make-test "1 2 . 3 4" + "1.5-1.6: can't use `.' outside list" + #t + (format "1~n2~ncan't use `.' outside list") + (vector 4 5) + (format "1~n2~nread: illegal use of \".\" at position 5 in ") + (format "read: illegal use of \".\" at position 5, line 1 in ") + #t + #f) + (make-test "1 2 x 3 4" + "1.5-1.6: reference to undefined identifier: x" + #t + (format "1~n2~nreference to undefined identifier: x") + (vector 4 5) + (format "1~n2~nreference to undefined identifier: x") + (format "reference to undefined identifier: x") + #f + #f) + (make-test "1 2 (raise 1) 3 4" + "uncaught exception: 1" + #f + (format "1~n2~nuncaught exception: 1") + 'unlocated-error + (format "1~n2~nuncaught exception: 1") + (format "uncaught exception: 1") + #f + #f) + (make-test "1 2 (raise #f) 3 4" + "uncaught exception: #f" + #f + (format "1~n2~nuncaught exception: #f") + 'unlocated-error + (format "1~n2~nuncaught exception: #f") + "uncaught exception: #f" + #f + #f) + + ;; new namespace test + (make-test (format "(current-namespace (make-namespace))~nif") + "compile: illegal use of a syntactic form name in: if" + #f + "compile: illegal use of a syntactic form name in: if" + 'unlocated-error + + "compile: illegal use of a syntactic form name in: if" + "compile: illegal use of a syntactic form name in: if" + #f + #f) + + ;; error escape handler test + (make-test (format "(let ([old (error-escape-handler)])~n(+ (let/ec k~n(dynamic-wind~n(lambda () (error-escape-handler (lambda () (k 5))))~n(lambda () (car))~n(lambda () (error-escape-handler old))))~n10))") + (format "5.12-5.17: car: expects 1 argument, given 0~n15") + #t + (format "car: expects 1 argument, given 0~n15") + 'definitions + + (format "car: expects 1 argument, given 0~n15") + (format "car: expects 1 argument, given 0~n15") + #f + #f) + + + ;; macro tests + (make-test "(define-macro m (lambda (x) (+ x 1))) (m 2)" + "3" + #f + "3" + #f + "3" + "3" + #f + #f) + (make-test "(define-macro m (lambda (x) `(+ ,x 1))) (m (+ 1 2))" + "4" + #f + "4" + #f + "4" + "4" + #f + #f) + (make-test "(define-macro m (car))" + "1.17-1.22: car: expects 1 argument, given 0" + #t + "car: expects 1 argument, given 0" + (vector 16 21) + "car: expects 1 argument, given 0" + "car: expects 1 argument, given 0" + #f + #f) + (make-test + (format "(define-macro m (lambda () (car)))~n(m)") + "1.28-1.33: car: expects 1 argument, given 0" + #t + "car: expects 1 argument, given 0" + (vector 27 32) + "car: expects 1 argument, given 0" + "car: expects 1 argument, given 0" + #f + #f) + (make-test + (format "(define-macro m (lambda (x) `(+ ,x 1)))~n(m #t)") + "2.1-2.7: +: expects type as 1st argument, given: #t; other arguments were: 1" + #t + "+: expects type as 1st argument, given: #t; other arguments were: 1" + (vector 40 46) + "+: expects type as 1st argument, given: #t; other arguments were: 1" + "+: expects type as 1st argument, given: #t; other arguments were: 1" + #f + #f) + (make-test + "(define-macro m 1)" + "1.1-1.19: Expander is not a procedure" + #t + "Expander is not a procedure" + (vector 0 18) + "define-macro: not a procedure" + "define-macro: not a procedure" + #f + #f) + (make-test + "(define-macro m (values (let ([x (lambda (x) x)]) x) (let ([y (lambda (x) x)]) y)))" + "context expected 1 value, received 2 values: # #" + #f + "context expected 1 value, received 2 values: # #" + #f + "context expected 1 value, received 2 values: # #" + "context expected 1 value, received 2 values: # #" + #f + #f) + + (make-test + (format "(define-macro m (lambda (x) (values x x)))~n(m 1)") + "context expected 1 value, received 2 values: 1 1" + #f + "context expected 1 value, received 2 values: 1 1" + #f + "context expected 1 value, received 2 values: 1 1" + "context expected 1 value, received 2 values: 1 1" + #f + #f) + + (make-test + (format "(define s (make-semaphore 0))~n(queue-callback~n(lambda ()~n(dynamic-wind~nvoid~n(lambda () (car))~n(lambda () (semaphore-post s)))))~n(yield s)") + "6.12-6.17: car: expects 1 argument, given 0" + #t + "car: expects 1 argument, given 0" + (vector 99 104) + "car: expects 1 argument, given 0" + "car: expects 1 argument, given 0" + #f + #f) + + ;; breaking tests + (make-test "(semaphore-wait (make-semaphore 0))" + "1.1-1.36: user break" + #t + "user break" + (vector 0 35) + + "user break" + "user break" + #f + #t) + + (make-test "(let l()(l))" + "1.9-1.12: user break" + #t + "user break" + (vector 8 11) + + "user break" + "user break" + #f + #t) + + ;; continuation tests + (make-test (format "(define k (call/cc (lambda (x) x)))~n(k 17)~nk") + "17" #f "17" #f + "17" "17" #f #f) + (make-test (format "(define v (vector (call/cc (lambda (x) x))))~n((vector-ref v 0) 2)~nv") + "#1(2)" #f "#1(2)" #f + "#1(2)" "#1(2)" #f #f) + (make-test (format "(define v (vector (eval '(call/cc (lambda (x) x)))))~n((vector-ref v 0) 2)~nv") + "#1(2)" #f "#1(2)" #f + "#1(2)" "#1(2)" #f #f) + + )) + +(define drscheme-frame (wait-for-drscheme-frame)) + +(define interactions-text (ivar drscheme-frame interactions-text)) +(define interactions-canvas (ivar drscheme-frame interactions-canvas)) +(define definitions-text (ivar drscheme-frame definitions-text)) +(define definitions-canvas (ivar drscheme-frame definitions-canvas)) +(define execute-button (ivar drscheme-frame execute-button)) +(define insert-string + (lambda (string) + (let loop ([n 0]) + (unless (= n (string-length string)) + (let ([c (string-ref string n)]) + (if (char=? c #\newline) + (fw:test:keystroke #\return) + (fw:test:keystroke c))) + (loop (+ n 1)))))) + +(define wait-for-execute (lambda () (wait-for-button execute-button))) +(define get-int-pos (lambda () (get-text-pos interactions-text))) + + +(define tmp-load-filename + (normalize-path (build-path (current-load-relative-directory) "repl-test-tmp.ss"))) + +;; given a filename "foo", we perform two operations on the contents +;; of the file "foo.ss". First, we insert its contents into the REPL +;; directly, and second, we use the load command. We compare the +;; the results of these operations against expected results. + +(define run-test + (lambda (execute-text-start escape mred?) + (lambda (in-vector) + (let* ([program (test-program in-vector)] + [pre-answer-load (test-r4rs-load-answer in-vector)] + [prepend-filename? (test-prepend-filename? in-vector)] + [answer-load (if prepend-filename? + (string-append "." tmp-load-filename ": " pre-answer-load) + pre-answer-load)] + [answer-execute (test-r4rs-execute-answer in-vector)] + [execute-location (test-r4rs-execute-location in-vector)] + [mred-execute-answer (test-mred-execute-answer in-vector)] + [mred-load-answer (test-mred-load-answer in-vector)] + [mred-read-test? (test-mred-read-test? in-vector)] + [breaking-test? (test-breaking-test? in-vector)]) + + (clear-definitions drscheme-frame) + ; load contents of test-file into the REPL, recording + ; the start and end positions of the text + + (insert-string program) + (do-execute drscheme-frame (not breaking-test?)) + (when breaking-test? + (fw:test:button-push (ivar drscheme-frame stop-execute-button)) + (wait-for-execute)) + + (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline + [received-execute + (send interactions-text get-text + execute-text-start execute-text-end)]) + + ; check focus and selection for execute test + (unless mred? + (cond + [(eq? execute-location 'definitions) + (unless (send definitions-canvas has-focus?) + (printf "FAILED execute test for ~s~n expected definitions to have the focus~n" + program))] + [(eq? execute-location 'unlocated-error) + (unless (send interactions-canvas has-focus?) + (printf "FAILED execute test for ~s~n expected interactions to have the focus~n" + program))] + [(and execute-location (send definitions-canvas has-focus?)) + (let ([error-range (send interactions-text get-error-range)]) + (unless (and error-range + (= (car error-range) (vector-ref execute-location 0)) + (= (cdr error-range) (vector-ref execute-location 1))) + (printf "FAILED execute test for ~s~n error-range is ~s~n expected ~a ~a~n" + program + error-range + (vector-ref execute-location 0) + (vector-ref execute-location 1))))] + [execute-location + (printf "FAILED execute test for ~s~n expected definitions canvas to have the focus~n" + program)] + [(not (send interactions-canvas has-focus?)) + (printf "FAILED execute test for ~s~n expected interactions to have the focus~n" + program)] + [else (void)])) + + ; check text for execute test + (let ([expected + (if mred? + (if mred-read-test? + (string-append mred-execute-answer "USERPORT") + mred-execute-answer) + answer-execute)]) + (unless (string=? received-execute expected) + (printf "FAILED execute test for ~s~n expected: ~s~n got: ~s~n" + program expected received-execute))) + + (fw:test:new-window interactions-canvas) + + ; construct the load file + + (call-with-output-file tmp-load-filename + (lambda (port) (display program port)) + 'truncate) + + ; stuff the load command into the REPL + + (for-each fw:test:keystroke + (string->list (format "(load ~s)" tmp-load-filename))) + + ; record current text position, then stuff a CR into the REPL + + (let ([load-text-start (+ 1 (send interactions-text last-position))]) + + (fw:test:keystroke #\return) + + (when breaking-test? + (fw:test:button-push (ivar drscheme-frame stop-execute-button))) + (wait-for-execute) + + (let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline + [received-load + (send interactions-text get-text + load-text-start load-text-end)]) + + ; check load text + (let ([expected + (if mred? + (if mred-read-test? + (string-append mred-load-answer + tmp-load-filename) + mred-load-answer) + answer-load)]) + (unless (string=? received-load expected) + (printf "FAILED load test for ~s~n expected: ~s~n got: ~s~n" + program expected received-load))) + + ; check for edit-sequence + (when (repl-in-edit-sequence?) + (printf "FAILED: repl in edit-sequence") + (escape))))))))) + +(define run-test-in-language-level + (lambda (raw?) + (let ([level (if raw? "Graphical without Debugging (MrEd)" "Graphical (MrEd)")]) + (printf "running ~a tests~n" level) + (set-language-level! level) + (fw:test:new-window definitions-canvas) + (fw:test:menu-select "Edit" "Select All") + (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) + "Clear" + "Delete")) + (do-execute drscheme-frame) + (let/ec escape (for-each (run-test (get-int-pos) escape raw?) test-data))))) + +(run-test-in-language-level #f) +(run-test-in-language-level #t) diff --git a/collects/tests/drscheme/sample-solutions.ss b/collects/tests/drscheme/sample-solutions.ss new file mode 100644 index 00000000..3cab6ac7 --- /dev/null +++ b/collects/tests/drscheme/sample-solutions.ss @@ -0,0 +1,131 @@ +;; memory debugging +(global-defined-value 'top-level-frames null) + +(define sample-solutions-dir + (build-path (collection-path "mzlib") + 'up + 'up + 'up + "robby" + "collects" + "solutions")) +(unless (directory-exists? sample-solutions-dir) + (error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir)) + +(set! sample-solutions-dir (normalize-path sample-solutions-dir)) + +;; add the full pathname to the toc entries. +(define toc + (map (lambda (x) (cons (build-path sample-solutions-dir (car x)) (cdr x))) + (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))) + +;; close out the first frame to avoid complications +(let ([orig-drs (wait-for-drscheme-frame)]) + (fw:test:menu-select "File" "New") + (wait-for-new-frame orig-drs) + (send orig-drs close)) + +(define frame-to-close (wait-for-drscheme-frame)) + +(define (test-single-file toc-entry) + (let ([filename (car toc-entry)] + [language (cadr toc-entry)] + [errors-ok? (caddr toc-entry)] + [teachpacks (cadddr toc-entry)] + [old-pref (fw:preferences:get 'framework:file-dialogs)]) + (fw:preferences:set 'framework:file-dialogs 'common) + + + (let* ([drs-frame (wait-for-drscheme-frame)] + [wait-for-execute + (lambda () + (wait-for-button (ivar drs-frame execute-button)))]) + (fw:test:menu-select "File" "Open...") + (wait-for-new-frame drs-frame) + (let ([pathname (find-labelled-window "Full pathname")] + [dialog (get-top-level-focus-window)]) + (send pathname focus) + (fw:test:keystroke #\a (case (system-type) + [(windows) (list 'control)] + [(macos) (list 'meta)] + [(unix) (list 'meta)])) + (let loop ([i 0]) + (when (< i (string-length filename)) + (fw:test:keystroke (string-ref filename i)) + (loop (+ i 1)))) + (fw:test:keystroke #\return) + (wait-for-new-frame dialog)) + (wait-for-new-frame drs-frame)) + + (let* ([drs-frame (wait-for-drscheme-frame)] + [wait-for-execute + (lambda () + (wait-for-button (ivar drs-frame execute-button)))]) + + (when frame-to-close (send frame-to-close close)) + (set! frame-to-close drs-frame) + + ;; memory debugging + (global-defined-value 'top-level-frames + (cons + (make-weak-box drs-frame) + (global-defined-value 'top-level-frames))) + (collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) + (send drs-frame update-memory-text) + ;(dump-memory-stats) + + (set-language-level! language) + (fw:test:menu-select "Language" "Clear All Teachpacks") + (for-each (lambda (teachpack) + (let ([filename (normalize-path (apply + build-path + (collection-path "mzlib") + 'up + 'up + "teachpack" + teachpack))]) + (fw:test:menu-select "Language" "Add Teachpack...") + (let ([dialog (wait-for-new-frame drs-frame)]) + (send (find-labelled-window "Full pathname") focus) + (fw:test:keystroke #\a (case (system-type) + [(windows) (list 'control)] + [(macos) (list 'meta)] + [(unix) (list 'meta)])) + (let loop ([i 0]) + (when (< i (string-length filename)) + (fw:test:keystroke (string-ref filename i)) + (loop (+ i 1)))) + (fw:test:keystroke #\return) + (wait-for-new-frame dialog)))) + teachpacks) + + (do-execute drs-frame) + (wait-for-execute) + + (when (and (not errors-ok?) + (has-error? drs-frame)) + (error 'sample-solutions.ss "should be no errors for ~s" filename)) + + + (let ([lines + (let ([port (open-input-string (fetch-output drs-frame))]) + (let loop () + (let ([line (read-line port)]) + (if (eof-object? line) + null + (cons line (loop))))))]) + (unless (< (length lines) 3) + (let loop ([before (car lines)] + [during (cadr lines)] + [after (caddr lines)] + [rest (cdddr lines)]) + (when (string=? during "=") + (unless (string=? before after) + (printf "FAILED ~s; expected ~s and ~s to be the same~n" + filename before after))) + (unless (null? rest) + (loop during after (car rest) (cdr rest)))))) + + (fw:preferences:set 'framework:file-dialogs old-pref)))) + +(for-each test-single-file toc) \ No newline at end of file diff --git a/collects/tests/drscheme/sig.ss b/collects/tests/drscheme/sig.ss new file mode 100644 index 00000000..0887ff22 --- /dev/null +++ b/collects/tests/drscheme/sig.ss @@ -0,0 +1,26 @@ +(require-library "function.ss") +(require-library "file.ss") +(require-library "guis.ss" "tests" "utils") + +(define-signature drscheme:test-util^ + (save-drscheme-window-as + use-get/put-dialog + do-execute + test-util-error + poll-until + wait-for-computation + wait-for-drscheme-frame + wait-for-new-frame + clear-definitions + type-in-definitions + type-in-interactions + wait + wait-pending + get-sub-panel + get-text-pos + wait-for-button + push-button-and-wait + set-language-level! + repl-in-edit-sequence? + fetch-output + has-error?)) diff --git a/collects/tests/drscheme/sixlib.ss b/collects/tests/drscheme/sixlib.ss new file mode 100644 index 00000000..c93554a7 --- /dev/null +++ b/collects/tests/drscheme/sixlib.ss @@ -0,0 +1,250 @@ +;; make sure these load +(parameterize ([current-namespace (make-namespace 'mred)]) + (require-library "graphicss.ss" "graphics") + (require-library "graphicr.ss" "graphics") + (require-library "graphicspr.ss" "graphics")) + +;; load the graphics +(require-library "graphics.ss" "graphics") +(require-library "macro.ss") +(open-graphics) + +(define (struct-test) + ;; test rgb selectors + (let* ([fraction 1/5] + [test + (list + (rgb-red (make-rgb fraction 0 0)) + (rgb-green (make-rgb 0 fraction 0)) + (rgb-blue (make-rgb 0 0 fraction)))]) + (unless (equal? (list fraction fraction fraction) test) + (error 'rgb "wrong: ~s" test))) + + ;; test posn selectors + (let* ([test + (list + (posn-x (make-posn 1 0)) + (posn-y (make-posn 0 1)))]) + (unless (equal? (list 1 1) test) + (error 'posn "wrong: ~s" test)))) + +;; test basic operations +(define (basic-test) + (let ([v (open-viewport "Tester" 200 200)]) + ((draw-string v) (make-posn 0 20) "Reversed X; click to continue") + ((draw-string v) (make-posn 0 40) "(busy-waiting right now!)") + ((draw-line v) (make-posn 0 0) (make-posn 100 100)) + ((draw-line v) (make-posn 100 0) (make-posn 0 100)) + ((flip-viewport v)) + (let loop () + (unless (ready-mouse-click v) + (loop))) + + ((clear-viewport v)) + ((draw-string v) (make-posn 0 20) "Cleared; click") + (get-mouse-click v) + + (let ([rect-draw + (lambda (f) + (f (make-posn 20 20) 60 60))] + [poly-draw + (lambda (f) + (f (list (make-posn 0 0) (make-posn 40 0) (make-posn 20 40)) (make-posn 20 20)))] + [string-draw + (lambda (f) + (f (make-posn 10 20) "XXXXX"))] + [shape + (lambda (do-draw draw clear flip name) + ((clear-viewport v)) + ((draw-string v) (make-posn 0 20) (format "Centered ~s" name)) + (do-draw (draw v)) + (get-mouse-click v) + + ((draw-string v) (make-posn 0 40) (format "Erased ~s" name)) + (do-draw (clear v)) + (get-mouse-click v) + + ((clear-viewport v)) + ((draw-string v) (make-posn 0 20) (format "Centered ~s" name)) + (do-draw (draw v)) + (get-mouse-click v) + + ((draw-string v) (make-posn 0 40) (format "Flipped ~s" name)) + (do-draw (flip v)) + (get-mouse-click v) + + ((draw-string v) (make-posn 0 40) (format "Flipped ~s back" name)) + (do-draw (flip v)) + (get-mouse-click v))]) + (shape rect-draw draw-rectangle clear-rectangle flip-rectangle "box") + (shape rect-draw draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle "solid box") + (shape rect-draw draw-ellipse clear-ellipse flip-ellipse "circle") + (shape rect-draw draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse "solid circle") + (shape poly-draw draw-polygon clear-polygon flip-polygon "polygon") + (shape poly-draw draw-solid-polygon clear-solid-polygon flip-solid-polygon "solid polygon") + (shape string-draw + draw-string + clear-string + flip-string + "string")) + + ((clear-viewport v)) + ((draw-string v) (make-posn 0 20) "Done; click") + (get-mouse-click v) + + (close-viewport v))) + +;; test get-pixel +(define (pixel-test) + (let ([v (open-viewport "test get-pixel" 8 8)] + [f (lambda (x y) + (if (= (modulo (+ x y) 2) 0) + (make-rgb 1 1 1) + (make-rgb (/ (modulo (+ x y) 3) 2) + (/ (modulo (+ x y 1) 3) 2) + (/ (modulo (+ x y 2) 3) 2))))] + + [unmarshall-color + (lambda (c) + (if (is-a? c color%) + (list (send c red) + (send c green) + (send c blue)) + c))] + + [for-each-point + (lambda (f) + (let loop ([i 8]) + (unless (= i 0) + (let loop ([j 8]) + (unless (= j 0) + (f (- i 1) (- j 1)) + (loop (- j 1)))) + (loop (- i 1)))))]) + (for-each-point + (lambda (i j) + ;(printf "(~a, ~a) -> ~a~n" i j (unmarshall-color (f i j))) + ((draw-pixel v) (make-posn i j) (f i j)))) + ;(get-mouse-click v) + (for-each-point + (lambda (i j) + (let* ([cmp + (lambda (rgb1 rgb2) + (and (= (rgb-red rgb1) (rgb-red rgb2)) + (= (rgb-blue rgb1) (rgb-blue rgb2)) + (= (rgb-green rgb1) (rgb-green rgb2))))] + [color-expected ((test-pixel v) (f i j))] + [bw-expected (if (cmp (make-rgb 1 1 1) color-expected) 0 1)] + [color-got ((get-color-pixel v) (make-posn i j))] + [bw-got ((get-pixel v) (make-posn i j))]) + (unless (= bw-got bw-expected) + (error 'test-get-pixel "wrong answer for (~a,~a); got ~a expectd ~a" + i j bw-got bw-expected)) + (unless (cmp color-expected color-got) + (error 'test-get-color-pixel "wrong answer for (~a,~a); got ~a expected ~a" + i j + (unmarshall-color color-got) + (unmarshall-color color-expected)))))) + (close-viewport v))) + +(define (snip-test) + ;; test snips + (let ([vp (open-pixmap "snip test" 100 100)]) + ((draw-string vp) (make-posn 20 30) "flipped rect") + ((flip-solid-rectangle vp) (make-posn 10 10) 80 80) + (display (viewport->snip vp)))) + +(define (color-test) + (let ([v (open-viewport "Color Tester" 100 200)]) + ((draw-solid-rectangle v) (make-posn 10 10) 80 80 (make-rgb 1 0 0)) + ((draw-solid-ellipse v) (make-posn 10 10) 80 80 (make-rgb 0 1 0)) + ((draw-line v) (make-posn 10 10) (make-posn 90 90) (make-rgb 0 0 1)) + ((draw-string v) (make-posn 10 100) "red rectangle") + ((draw-string v) (make-posn 10 120) "green ellipse") + ((draw-string v) (make-posn 10 140) "blue line") + (get-mouse-click v) + + ((draw-viewport v) (make-rgb 1 0 0)) + ((draw-string v) (make-posn 10 100) "solid red") + (get-mouse-click v) + + ((draw-viewport v)) + ((clear-string v) (make-posn 10 100) "solid black") + (get-mouse-click v) + + (close-viewport v))) + +(define (pixmap-test) + (local [(define width 500) + (define height 500) + (define pixmap-filename (build-path (collection-path "icons") "plt.gif")) + (define view-port (open-viewport "pixmap tests" width height)) + (define (line) + ((draw-line view-port) (make-posn 50 50) (make-posn 450 450))) + (define (next desc) + ((draw-string view-port) (make-posn 0 (- height 50)) desc) + ((draw-string view-port) (make-posn 0 (- height 30)) "click to continue") + (get-mouse-click view-port) + ((clear-viewport view-port)))] + + (line) + (((draw-pixmap-posn pixmap-filename) view-port) (make-posn 0 0)) + (next "draw line then draw-pixmap-posn") + + (line) + ((draw-pixmap view-port) pixmap-filename (make-posn 0 0)) + (next "pixmap-functions: draw line then draw-pixmap") + + (close-viewport view-port))) + +(define (copy-viewport-test) + (let* ([width 100] + [height 100] + [vs (open-viewport "viewport source" width height)] + [vd (open-viewport "viewport dest" width height)]) + + ((draw-ellipse vs) (make-posn 10 10) 80 80) + ((draw-string vs) (make-posn 10 30) "Click") + (get-mouse-click vs) + (copy-viewport vs vd) + ((clear-viewport vs)) + ((draw-string vs) (make-posn 10 30) "Cleared") + (get-mouse-click vd) + (void))) + +(define (keyboard-test) + (let ([v (open-viewport "keyboard" 300 200)] + [RED (make-rgb 1 0 0)] + [BLACK (make-rgb 0 0 0)]) + ((draw-string v) (make-posn 5 15) "Type, end with return (red is from key-ready):") + (let loop ([x 5]) + (let* ([kv (or (begin + ((draw-rectangle v) (make-posn 290 0) 10 10 RED) + (ready-key-press v)) + (begin + ((draw-rectangle v) (make-posn 290 0) 10 10 BLACK) + (cons 'slow (get-key-press v))))] + [k (key-value (if (pair? kv) (cdr kv) kv))]) + ((clear-rectangle v) (make-posn 0 290) 10 10) + (cond + [(eq? k #\return) 'done] + [(char? k) (let ([s (string k)]) + ((draw-string v) (make-posn x 50) s + (if (pair? kv) + BLACK + RED)) + (sleep 0.05) ; slow down so key-ready takes effect + (loop (+ x (car ((get-string-size v) s)))))] + [else (loop x)]))) + (close-viewport v))) + +(struct-test) +(basic-test) +(pixel-test) +(color-test) +(snip-test) +(pixmap-test) +(copy-viewport-test) +(keyboard-test) + +(close-graphics) diff --git a/collects/tests/drscheme/syncheck/basic.ss b/collects/tests/drscheme/syncheck/basic.ss new file mode 100644 index 00000000..5f49a206 --- /dev/null +++ b/collects/tests/drscheme/syncheck/basic.ss @@ -0,0 +1,25 @@ + +(define-struct x (a b c)) + +make-x +x? +x-b +set-x-c! + +rumplestilskin + +(1 2) +(letrec () 'constant) +(letrec-values ([(x y) 'constant]) 'constant) +(let () 'constant) +(let-values ([(x y) 'constant]) 'constant) +(let ([x 1]) x) +(lambda (x) 'constant) +(case-lambda [(x . y) x] [(x) x] [y x]) +`(,x) ;; this one won't show the unbound x :( +(if 1 2 3) +(set! y 1) +(define x 2) +(set! x 1) +(begin 123 x y) +(begin0 123 x y) diff --git a/collects/tests/drscheme/syncheck/circle.ss b/collects/tests/drscheme/syncheck/circle.ss new file mode 100644 index 00000000..74ac0aa5 --- /dev/null +++ b/collects/tests/drscheme/syncheck/circle.ss @@ -0,0 +1,14 @@ +(lambda (f) + + f f) + +(define g 1) + + g g g + +(define g 1) +g g + + + +g g g \ No newline at end of file diff --git a/collects/tests/drscheme/syncheck/generate.ss b/collects/tests/drscheme/syncheck/generate.ss new file mode 100644 index 00000000..5c287e06 --- /dev/null +++ b/collects/tests/drscheme/syncheck/generate.ss @@ -0,0 +1,34 @@ +#!/bin/sh + +string=? ; exec /home/mflatt/plt/bin/mzscheme -qr $0 + +;; run this to output lots of scheme code to stdout +;; that code should all pass thru the syntax checker + +(require-library "pretty.ss") + +(let ([orig-eval (current-eval)] + [orig-output (current-output-port)] + [dir (current-directory)]) + (parameterize ([current-eval + (lambda (x) + (begin0 (orig-eval x) + (pretty-print x orig-output)))] + [current-output-port (make-output-port void void)] + [current-error-port (make-output-port void void)] + [error-display-handler void]) + (current-directory "/home/mflatt/proj/mred/mzscheme/tests") + (load "testing.ss") + + (load "basic.ss") + (load "read.ss") + (load "syntax.ss") + (load "file.ss") + (load "path.ss") + (load "number.ss") + (load "object.ss") + (load "struct.ss") + (load "unit.ss") + (load "thread.ss") + (load "param.ss") + (current-directory dir))) diff --git a/collects/tests/drscheme/syncheck/lots.ss b/collects/tests/drscheme/syncheck/lots.ss new file mode 100644 index 00000000..891c20fa --- /dev/null +++ b/collects/tests/drscheme/syncheck/lots.ss @@ -0,0 +1,14 @@ +(define x 1) + +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x +x x x x x x x x x x x x x x x x x x x x diff --git a/collects/tests/drscheme/tool.ss b/collects/tests/drscheme/tool.ss new file mode 100644 index 00000000..b338fc72 --- /dev/null +++ b/collects/tests/drscheme/tool.ss @@ -0,0 +1,206 @@ +;; load this file as a tool to run the test suites + +(unit/sig () + (import [mred : mred^] + [core : mzlib:core^] + [fw : framework^] + [pc : mzlib:print-convert^] + (drscheme : drscheme:export^) + [zodiac : zodiac:system^]) + + (define test-thread + (let ([kill-old void]) + (lambda (test thunk) + (kill-old) + (let ([thread-desc (thread + (lambda () + (printf "t>> ~a started~n" test) + (thunk) + (printf "t>> ~a finished~n" test)))]) + (set! kill-old + (lambda () + (when (thread-running? thread-desc) + (kill-thread thread-desc) + (printf "t>> killed ~a~n" test)))))))) + + (define all-tests (map symbol->string (require-library "README" "tests" "drscheme"))) + + (define (make-repl) + (test-thread + "REPL" + (lambda () + (let ([startup "~/.mzschemerc"]) + (when (file-exists? startup) + (load startup))) + (read-eval-print-loop)))) + + (define (run-test-suite filename) + (test-thread + filename + (lambda () + (invoke-unit/sig + (compound-unit/sig (import [fw : framework^] + [mred : mred^]) + (link + [utils : test-utils:gui^ ((require-library "guir.ss" "tests" "utils") mred)] + [drs-utils : drscheme:test-util^ ((require-library "drscheme-test-util.ss" "tests" "drscheme") mred fw utils)] + [main : () + ((unit/sig () + (import [drs-utils : drscheme:test-util^] + [utils : test-utils:gui^]) + + (invoke-unit/sig + (eval + `(unit/sig () + (import [fw : framework^] + mzlib:function^ + mzlib:file^ + drscheme:test-util^ + test-utils:gui^ + mred^ + [drscheme : drscheme:export^] + [zodiac : zodiac:system^]) + + (include ,(build-path (collection-path "tests" "drscheme") filename)))) + (fw : framework^) + (core:function : mzlib:function^) + (core:file : mzlib:file^) + (drs-utils : drscheme:test-util^) + (utils : test-utils:gui^) + (mred : mred^) + (drscheme : drscheme:export^) + (zodiac : zodiac:system^))) + + drs-utils utils)]) + (export)) + (fw : framework^) + (mred : mred^))))) + + (fw:preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?) + (fw:preferences:set-default 'drscheme:test-suite:run-interval 10 number?) + + (fw:preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x)))) + (fw:preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x)))) + + (define current-test-suite-frame #f) + + (define (ask-test-suite) + (if current-test-suite-frame + (send current-test-suite-frame show #t) + (let* ([frame% (class mred:frame% () + (override + [on-size + (lambda (w h) + (fw:preferences:set 'drscheme:test-suite:frame-width w) + (fw:preferences:set 'drscheme:test-suite:frame-height h))] + [on-close + (lambda () + (set! current-test-suite-frame #f))]) + (sequence + (super-init "Test Suites" + #f + (fw:preferences:get 'drscheme:test-suite:frame-width) + (fw:preferences:get 'drscheme:test-suite:frame-height))))] + [drscheme-test-dir (collection-path "tests" "drscheme")] + [frame (make-object frame%)] + [panel (make-object mred:vertical-panel% frame)] + [top-panel (make-object mred:vertical-panel% panel)] + [bottom-panel (make-object mred:horizontal-panel% panel)]) + (send top-panel stretchable-height #f) + (send (make-object mred:button% + "REPL" + bottom-panel + (lambda (_1 _2) + (send frame show #f) + (make-repl))) + focus) + + (when drscheme-test-dir + (send top-panel stretchable-height #t) + (send bottom-panel stretchable-height #f) + (letrec ([lb (make-object mred:list-box% + #f + all-tests + top-panel + (lambda (b e) + (when (eq? (send e get-event-type) 'list-box-dclick) + (run-test-suite-callback))))] + [run-test-suite-callback + (lambda () + (let ([selection (send lb get-selection)]) + (when selection + (send frame show #f) + (let ([test (list-ref all-tests selection)]) + (fw:preferences:set + 'drscheme:test-suite:file-name + test) + (run-test-suite + test)))))]) + + ;; set values from preferences + (let* ([test-suite (fw:preferences:get 'drscheme:test-suite:file-name)] + [num (send lb find-string test-suite)]) + (when num + (send lb set-string-selection test-suite) + (send lb set-first-visible-item num) + (fw:test:run-interval (fw:preferences:get 'drscheme:test-suite:run-interval)))) + + (send + (make-object mred:button% + "Run Test Suite" + bottom-panel + (lambda (_1 _2) + (run-test-suite-callback))) + focus)) + + (let* ([pre-times (list 0 10 50 100 500)] + [times (if (member (fw:test:run-interval) pre-times) + pre-times + (append pre-times (list (fw:test:run-interval))))] + [choice + (make-object mred:choice% + "Run Interval" + (map number->string times) + top-panel + (lambda (choice event) + (let ([time (list-ref times (send choice get-selection))]) + (fw:preferences:set 'drscheme:test-suite:run-interval time) + (fw:test:run-interval time))))]) + (send choice set-selection + (let loop ([l times] + [n 0]) + (if (= (car l) (fw:test:run-interval)) + n + (loop (cdr l) + (+ n 1))))))) + (make-object mred:button% + "Cancel" + bottom-panel + (lambda (_1 _2) + (send frame show #f))) + (send frame show #t) + (set! current-test-suite-frame frame)))) + + (drscheme:get/extend:extend-unit-frame + (lambda (super%) + (class super% args + (inherit button-panel) + (sequence (apply super-init args)) + (private + [bitmap (make-object mred:bitmap% + (if (<= (mred:get-display-depth) 1) + (build-path (collection-path "icons") "bb-sm-bw.bmp") + (build-path (collection-path "icons") "bb-small.bmp")) + 'bmp)] + [button (make-object + mred:button% + (if (send bitmap ok?) + bitmap + "Console") + button-panel + (lambda (button evt) + (ask-test-suite)))]) + (sequence + (send button-panel change-children + (lambda (l) + (cons button (core:function:remq button l))))))))) diff --git a/collects/tests/framework/info.ss b/collects/tests/framework/info.ss new file mode 100644 index 00000000..aa2a0f41 --- /dev/null +++ b/collects/tests/framework/info.ss @@ -0,0 +1,14 @@ +(lambda (request response) + (case request + [(name) "Framework"] + [(install-collection) + (lambda (_) + (require-library "launcher.ss" "launcher") + (make-mred-launcher + (list "-qe-" + "(require-library \"framework-test-engine.ss\" \"tests\" \"framework\")") + (mred-program-launcher-path "Framework Test Engine")) + (make-mzscheme-launcher + (list "-mqve-" "(require-library \"main.ss\" \"tests\" \"framework\")") + (mred-program-launcher-path + "Framework Test")))])) \ No newline at end of file diff --git a/collects/tests/framework/key-specs.ss b/collects/tests/framework/key-specs.ss new file mode 100644 index 00000000..ab643fd5 --- /dev/null +++ b/collects/tests/framework/key-specs.ss @@ -0,0 +1,29 @@ +(define-struct key-spec (before after macos unix windows)) +(define-struct buff-spec (string start end)) + +(define global-specs + (list + (make-key-spec (make-buff-spec "abc" 1 1) + (make-buff-spec "abc" 2 2) + (list '(#\f control) '(right)) + (list '(#\f control) '(right)) + (list '(#\f control) '(right))))) + +(define scheme-specs + (list + (make-key-spec (make-buff-spec "(abc (def))" 4 4) + (make-buff-spec "(abc (def))" 10 10) + (list ;'(#\f alt control) + '(right alt)) + (list ;'(#\f alt control) + '(right alt)) + (list ;'(#\f alt control) + '(right alt))) + (make-key-spec (make-buff-spec "'(abc (def))" 1 1) + (make-buff-spec "'(abc (def))" 12 12) + (list ;'(#\f alt control) + '(right alt)) + (list ;'(#\f alt control) + '(right alt)) + (list ;'(#\f alt control) + '(right alt))))) diff --git a/collects/tests/framework/paren-test.ss b/collects/tests/framework/paren-test.ss new file mode 100644 index 00000000..62c4b91e --- /dev/null +++ b/collects/tests/framework/paren-test.ss @@ -0,0 +1,139 @@ +(define balanced-tests + `(("()" 0 2) + ("(a)" 0 3) + ("(a a)" 0 5) + ("(())" 0 4) + ("(())" 1 3) + ("([])" 1 3) + ("([])" 0 4) + ("{[]}" 1 3) + ("{[]}" 0 4) + ("abc" 0 3) + ("(abc (abc))" 0 11) + ("(abc (abc))" 5 10))) + +(define unbalanced-tests + `(("()" #t (1) (1)) + ("(()" #f (0 2) (1 2)) + ("(a()" #f (0) (1 3)) + (")" #f (0 1) (0 1)) + ("())" #f (1 2) (1 3)) + ("() a)" #f (1 4) (1 5)))) + +(define (run-unbalanced-test test-data) + (let ([expression (first test-data)] + [balanced? (second test-data)] + [forward-starts (third test-data)] + [backward-starts (fourth test-data)]) + (test + (string->symbol (format "unbalanced-paren-~a" expression)) + (lambda (x) (not (ormap (lambda (x) x) x))) + `(let ([t (make-object text%)]) + (send t insert ,expression) + (append + (list (not (eq? ,balanced? (scheme-paren:balanced? t 0 (send t last-position))))) + (map (lambda (n) (scheme-paren:forward-match t n (send t last-position))) ',forward-starts) + (map (lambda (n) (scheme-paren:backward-match t n 0)) ',backward-starts)))))) + +(define (run-balanced-test test-data) + (let ([expression (first test-data)] + [start (second test-data)] + [end (third test-data)]) + (test + (string->symbol (format "balanced-paren-~a/~a/~a" expression start end)) + (lambda (x) (equal? x (list start end #t))) + `(let ([t (make-object text%)]) + (send t insert ,expression) + (list (scheme-paren:backward-match t ,end 0) + (scheme-paren:forward-match t ,start (send t last-position)) + (scheme-paren:balanced? t 0 (send t last-position))))))) + +(define (run-scheme-unbalanced-test test-data) + (let ([expression (first test-data)] + [balanced? (second test-data)] + [forward-starts (third test-data)] + [backward-starts (fourth test-data)]) + (test + (string->symbol (format "scheme-unbalanced-paren-~a" expression)) + (lambda (x) (not (ormap (lambda (x) x) x))) + `(let* ([t (make-object scheme:text%)] + [setup-text + (lambda () + (send t erase) + (send t insert ,(string-append " " expression)))] + [insert-first + (lambda () + (send t insert " " 0 0))] + [delete-first + (lambda () + (send t delete 0 1))]) + (append + (map + (lambda (n) + (setup-text) + (send t get-backward-sexp (+ n 1)) + (delete-first) + (send t get-backward-sexp n)) + ',backward-starts) + (map + (lambda (n) + (setup-text) + (send t get-backward-sexp (+ n 1)) + (insert-first) + (send t get-backward-sexp (+ n 2))) + ',backward-starts) + (map + (lambda (n) + (setup-text) + (send t get-forward-sexp (+ n 1)) + (delete-first) + (send t get-forward-sexp n)) + ',forward-starts) + (map + (lambda (n) + (setup-text) + (send t get-forward-sexp (+ n 1)) + (insert-first) + (send t get-forward-sexp (+ n 2))) + ',forward-starts)))))) + +(define (run-scheme-balanced-test test-data) + (let* ([expression (first test-data)] + [start (second test-data)] + [end (third test-data)] + [answers (list start (+ start 2) end (+ end 2))]) + (test + (string->symbol (format "balanced-paren-~a/~a" expression answers)) + (lambda (x) (equal? x answers)) + `(let* ([t (make-object scheme:text%)] + [setup-text + (lambda () + (send t erase) + (send t insert ,(string-append " " expression)))] + [insert-first + (lambda () + (send t insert " " 0 0))] + [delete-first + (lambda () + (send t delete 0 1))]) + (list (begin (setup-text) + (send t get-backward-sexp ,(+ end 1)) + (delete-first) + (send t get-backward-sexp ,end)) + (begin (setup-text) + (send t get-backward-sexp ,(+ end 1)) + (insert-first) + (send t get-backward-sexp ,(+ end 2))) + (begin (setup-text) + (send t get-forward-sexp ,(+ start 1)) + (delete-first) + (send t get-forward-sexp ,start)) + (begin (setup-text) + (send t get-forward-sexp ,(+ start 1)) + (insert-first) + (send t get-forward-sexp ,(+ start 2)))))))) + +(for-each run-unbalanced-test unbalanced-tests) +(for-each run-scheme-unbalanced-test unbalanced-tests) +(for-each run-balanced-test balanced-tests) +(for-each run-scheme-balanced-test balanced-tests) diff --git a/collects/tests/framework/send-sexp.ss b/collects/tests/framework/send-sexp.ss new file mode 100644 index 00000000..ec88275f --- /dev/null +++ b/collects/tests/framework/send-sexp.ss @@ -0,0 +1,11 @@ +(define send-sexp + (lambda (sexp) + (let-values ([(in out) (tcp-connect "localhost" (require-library "receive-sexps-port.ss" "tests" "framework"))]) + (write sexp out) + (newline out) + (let ([result (read in)]) + (close-input-port in) + (close-output-port out) + (case (car result) + [(error) (error 'send-sexp (cadr result))] + [(normal) (cadr result)]))))) diff --git a/collects/tests/framework/utils.ss b/collects/tests/framework/utils.ss new file mode 100644 index 00000000..3776c311 --- /dev/null +++ b/collects/tests/framework/utils.ss @@ -0,0 +1,13 @@ +(define (wait-for-frame name) + (let ([timeout 10] + [pause-time 1/2]) + (send-sexp-to-mred + `(let loop ([n ,(/ timeout pause-time)]) + (if (zero? n) + (error 'wait-for-mred-frame + ,(format "after ~a seconds, frame labelled ~s didn't appear" timeout name)) + (let ([win (get-top-level-focus-window)]) + (printf "win: ~a label ~a~n" win (and win (string=? (send win get-label) ,name))) + (unless (and win (string=? (send win get-label) ,name)) + (sleep ,pause-time) + (loop (- n 1))))))))) diff --git a/collects/tests/info.ss b/collects/tests/info.ss new file mode 100644 index 00000000..717693fe --- /dev/null +++ b/collects/tests/info.ss @@ -0,0 +1,13 @@ +(let ([sub-collections (list "framework")]) + (lambda (request result) + (case request + [(name) "Test Suites"] + [(install-collection) + (lambda (arg) + (error-print-width 500) + (for-each (lambda (sub-collection) + (let ([sub-info (build-path (collection-path "tests" sub-collection) "info.ss")]) + (when (file-exists? sub-info) + (((load-relative sub-info) 'install-collection void) arg)))) + sub-collections))] + [else (result)]))) diff --git a/collects/tests/mred/auto.ss b/collects/tests/mred/auto.ss new file mode 100644 index 00000000..993e13bf --- /dev/null +++ b/collects/tests/mred/auto.ss @@ -0,0 +1,4 @@ + +(load-relative "editor.ss") +(load-relative "paramz.ss") +(load-relative "windowing.ss") diff --git a/collects/tests/mred/classhack.c b/collects/tests/mred/classhack.c new file mode 100644 index 00000000..85c6f2cf --- /dev/null +++ b/collects/tests/mred/classhack.c @@ -0,0 +1,149 @@ + +#include "escheme.h" + + +/**************** Copied from plt/src/mzscheme/src/object.c **************/ +typedef long ClassVariable; + +typedef struct Scheme_Class { + Scheme_Type type; + + ClassVariable *ivars; /* Order determines order of evaluation */ + + union { + Scheme_Closed_Prim *initf; + struct { + Scheme_Instance_Init_Proc *f; + void *data; + } insti; + } piu; + short priminit; + + short pos; + struct Scheme_Class **heritage; + struct Scheme_Class *superclass; /* Redundant, but useful. */ + Scheme_Object *super_init_name; + struct Scheme_Interface *equiv_intf; /* interface implied by this class */ + + short num_args, num_required_args, num_arg_vars; + short num_ivar, num_private, num_ref; + short num_public, num_slots; /* num_vslots == num_public */ + Scheme_Object **public_names; + /* ... */ +} Scheme_Class; + +typedef struct Scheme_Interface { + Scheme_Type type; + short num_names, num_supers; + short for_class; /* 1 => impl iff subclass, 0 => normal interface */ + Scheme_Object **names; + short *name_map; /* position in names => interface slot position */ + struct Scheme_Interface **supers; /* all superinterfaces (flattened hierarchy) */ + struct Scheme_Class *supclass; + short *super_offsets; /* superinterface => super's slot position offset */ + Scheme_Object *defname; +} Scheme_Interface; + +/*************************************************************************/ + +Scheme_Object *array_to_list(int c, Scheme_Object **names) +{ + Scheme_Object *p = scheme_null; + + while (c--) + p = scheme_make_pair(names[c], p); + + return p; +} + +Scheme_Object *arrays_to_list(int c1, Scheme_Object **ns1, + int c2, Scheme_Object **ns2) + /* Merge arrays. Exploit the fact that they're both + sorted. */ +{ + Scheme_Object **ns; + int c, i1, i2; + + ns = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object*) * (c1 + c2)); + c = i1 = i2 = 0; + while ((i1 < c1) || (i2 < c2)) { + if (i1 >= c1) { + ns[c++] = ns2[i2++]; + } else if (i2 >= c2) { + ns[c++] = ns1[i1++]; + } else { + Scheme_Object *n1 = ns1[i1]; + Scheme_Object *n2 = ns2[i2]; + + if (n1 == n2) { + ns[c++] = n1; + i1++; + i2++; + } else if ((unsigned long)n1 < (unsigned long)n2) { + ns[c++] = ns1[i1++]; + } else { + ns[c++] = ns2[i2++]; + } + } + } + + return array_to_list(c, ns); +} + +Scheme_Object *class_to_names(int argc, Scheme_Object **argv) +{ + Scheme_Class *class = (Scheme_Class *)argv[0]; + + if (!SCHEME_CLASSP(argv[0])) + scheme_wrong_type("class->names", "class", 0, argc, argv); + + return array_to_list(class->num_public, class->public_names); +} + +Scheme_Object *interface_to_names(int argc, Scheme_Object **argv) +{ + Scheme_Interface *interface = (Scheme_Interface *)argv[0]; + + if (!SCHEME_INTERFACEP(argv[0])) + scheme_wrong_type("interface->names", "interface", 0, argc, argv); + + return arrays_to_list(interface->num_names, interface->names, + interface->supclass->num_public, interface->supclass->public_names); +} + +Scheme_Object *interface_to_super_interfaces(int argc, Scheme_Object **argv) +{ + Scheme_Interface *interface = (Scheme_Interface *)argv[0]; + + if (!SCHEME_INTERFACEP(argv[0])) + scheme_wrong_type("interface->super-interfaces", "interface", 0, argc, argv); + + return array_to_list(interface->num_supers, (Scheme_Object**)interface->supers); +} + + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + return scheme_reload(env); +} + +Scheme_Object *scheme_reload(Scheme_Env *env) +{ + scheme_add_global("class->names", + scheme_make_prim_w_arity(class_to_names, + "class->names", + 1, 1), + env); + scheme_add_global("interface->names", + scheme_make_prim_w_arity(interface_to_names, + "interface->names", + 1, 1), + env); + scheme_add_global("interface->super-interfaces", + scheme_make_prim_w_arity(interface_to_super_interfaces, + "interface->super-interfaces", + 1, 1), + env); + + return scheme_void; +} diff --git a/collects/tests/mred/frame-edit.ss b/collects/tests/mred/frame-edit.ss new file mode 100644 index 00000000..5add33dd --- /dev/null +++ b/collects/tests/mred/frame-edit.ss @@ -0,0 +1,73 @@ +;; this file tests frames with various edits in them + +(define testing-frame #f) + +(define test-frame/edit + (lambda (frame% edit% title) + (let* ([frame (make-object + (class frame% args + (public [get-edit% (lambda () edit%)]) + (inherit show) + (sequence (apply super-init args))))] + [edit (send frame get-edit)] + [string-good "test insert"] + [string-bad "SHOULD NOT SEE THIS"] + [get-insertion + (lambda (string) + (if (is-a? edit wx:media-edit%) + string + (let ([snip (make-object wx:media-snip%)] + [snip-e (make-object mred:media-edit%)]) + (send snip set-media snip-e) + (send snip-e insert string) + snip)))]) + (set! testing-frame frame) + (send frame set-title-prefix title) + (send frame show #t) + (send edit insert (get-insertion string-good)) + (send edit lock #t) + (send edit insert (get-insertion string-bad)) + (send edit lock #f)))) + +(define continue? #t) + +(define close-down + (lambda () + (let ([answer (mred:get-choice "Continue the test suite?" + "Yes" "No" + "connections test suite")]) + (when (send testing-frame on-close) + (send testing-frame show #f)) + (unless answer + (error 'close-down))))) + +(define-macro frame/edit + (lambda (frame% edit%) + `(when continue? + (printf "testing frame: ~a edit: ~a~n" ',frame% ',edit%) + (test-frame/edit ,frame% ,edit% (format "~a ~a" ',frame% ',edit%))))) + +(define searching-frame% (mred:make-searchable-frame% mred:simple-menu-frame%)) +(define searching-info-frame% (mred:make-searchable-frame% mred:info-frame%)) + +(frame/edit mred:pasteboard-frame% mred:pasteboard%) (close-down) +(frame/edit mred:simple-menu-frame% mred:media-edit%) (close-down) +(frame/edit searching-frame% mred:media-edit%) (close-down) + +(frame/edit mred:info-frame% mred:info-edit%) (close-down) + +(frame/edit searching-info-frame% mred:searching-edit%) +(mred:find-string (send testing-frame get-canvas) + null + 0 0 (list 'ignore-case)) +(close-down) + +(frame/edit mred:info-frame% mred:clever-file-format-edit%) (close-down) +(frame/edit mred:info-frame% mred:file-edit%) (close-down) +(frame/edit mred:info-frame% mred:backup-autosave-edit%) (close-down) +(frame/edit mred:info-frame% mred:scheme-mode-edit%) (close-down) + +(frame/edit searching-info-frame% mred:clever-file-format-edit%) (close-down) +(frame/edit searching-info-frame% mred:file-edit%) (close-down) +(frame/edit searching-info-frame% mred:backup-autosave-edit%) (close-down) +(frame/edit searching-info-frame% mred:scheme-mode-edit%) (close-down) diff --git a/collects/tests/mred/gui-main.ss b/collects/tests/mred/gui-main.ss new file mode 100644 index 00000000..588b125d --- /dev/null +++ b/collects/tests/mred/gui-main.ss @@ -0,0 +1,89 @@ +(lambda (new-name save-name console%) + (let* ([dir (current-load-relative-directory)] + [console + (let loop ([printout? #f]) + (let ([f (mred:test:get-active-frame)]) + (if (and f + (is-a? f console%)) + f + (begin + (unless printout? + (printf "please select the console~n")) + (sleep 1/2) + (loop #t)))))] + [wait + (opt-lambda (test desc-string [time 5]) + (let ([int 1/2]) + (let loop ([sofar 0]) + (cond + [(> sofar time) (error 'wait desc-string)] + [(test) (void)] + [else (sleep int) + (loop (+ sofar int))]))))] + [wait-pending + (lambda () + (wait (lambda () (= 0 (mred:test:number-pending-actions))) + "pending action sdidn't terminate") + (mred:test:reraise-error))] + [_ (mred:test:menu-select "File" new-name)] + [_ (wait-pending)] + [_ (wait (lambda () (not (eq? (mred:test:get-active-frame) console))) + "focus didn't change from the console after File|New")] + [frame (mred:test:get-active-frame)] + [_ (mred:test:keystroke #\a)] + + [_ (mred:test:menu-select "File" "Close")] + [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) + "active frame remained original frame after File|Close")] + [_ (mred:test:button-push "Cancel")] + [_ (wait-pending)] + + [_ (mred:test:menu-select "File" "Close")] + [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) + "active frame remained original frame after File|Close")] + [_ (mred:test:button-push "Cancel")] + [_ (wait-pending)] + + [_ (wait (lambda () (eq? frame (mred:test:get-active-frame))) + "active frame did not return to editor frame")] + [_ (mred:test:menu-select "File" "Close")] + [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) + "active frame remained original frame after File|Close")] + [_ (mred:test:button-push "Close Anyway")] + [_ (wait-pending)] + + [_ (unless (mred:get-preference 'mred:autosaving-on?) + (error 'autosave "autosaving preference turned off. Turn back on (with preferences dialog)"))] + [tmp-file (build-path dir "tmp.ss")] + [backup-file (build-path dir "#tmp.ss#1#")] + [_ (call-with-output-file tmp-file + (lambda (port) (display "12" port)) + 'truncate)] + [_ (when (file-exists? backup-file) + (delete-file backup-file))] + [_ (mred:edit-file tmp-file)] + [_ (wait (lambda () (not (eq? console (mred:test:get-active-frame)))) + "after mred:edit-file, the console remained active")] + [frame (mred:test:get-active-frame)] + [_ (mred:test:keystroke #\3)] + [autosave-time (+ 10 (mred:get-preference 'mred:autosave-delay))] + [_ (printf "waiting for autosave timeout (~a secs)~n" autosave-time)] + [_ (sleep autosave-time)] + [_ (printf "finished waiting for autosave timeout~n")] + [_ (unless (file-exists? backup-file) + (error 'autosave "autosave file (~a) not created" backup-file))] + [_ (mred:test:menu-select "File" save-name)] + [_ (wait-pending)] + [_ (when (file-exists? backup-file) + (error 'autosave "autosave file (~a) not deleted after original file saved"))] + [_ (mred:test:menu-select "File" "Close")] + [_ (wait-pending)] + [_ (wait (lambda () (eq? (mred:test:get-active-frame) console)) + "focus didn't return to the console after closing autosave test frame")]) + (printf "test finished~n"))) + +; +; when rewriting, apply this function to: +; "New Unit" +; "Save Definitions" +; wx:frame% diff --git a/collects/tests/mred/gui.ss b/collects/tests/mred/gui.ss new file mode 100644 index 00000000..1125a133 --- /dev/null +++ b/collects/tests/mred/gui.ss @@ -0,0 +1,5 @@ +(let ([f (load-relative "gui-main.ss")]) + (thread + (lambda () + (f "New" "Save" mred:console-frame%)))) + diff --git a/collects/tests/mred/imred.ss b/collects/tests/mred/imred.ss new file mode 100644 index 00000000..f7bda4ae --- /dev/null +++ b/collects/tests/mred/imred.ss @@ -0,0 +1,70 @@ +(define make-invokable-unit + (lambda (application) + (compound-unit/sig (import) + (link [wx : wx^ (wx@)] + [core : mzlib:core^ (mzlib:core@)] + [mred : mred^ ((require-library "linkwx.ss" "mred") core wx)] + [application : () (application mred core wx)]) + (export (unit mred mred2))))) + +(define (go flags) + (define die? #f) + (define my-app + (unit/sig () + (import mred^ + mzlib:core^ + [wx : wx^]) + + (define app-name "Tester") + (define console (if (memq 'console flags) + (make-object console-frame%) + #f)) + (define eval-string pretty-print@:pretty-print) + (when (memq 'thread flags) + (let ([s (make-semaphore 1)] + [s2 (make-semaphore 0)] + [done (make-semaphore 0)]) + ; Use of semaphore-callback insures that thread is a child + ; of the eventspace + (semaphore-callback s + (lambda () + (semaphore-post done) + (thread (lambda () + (let loop () + (sleep 1) + (loop)))) + (when (begin0 + die? + (set! die? (not die?))) + (kill-thread (current-thread))))) ; kills handler thread + ; Add another callback that we know will not get triggered + (semaphore-callback s2 void) + (wx:yield done))) + (when (memq 'eventspace flags) + (let ([e (wx:make-eventspace)]) + (parameterize ([wx:current-eventspace e]) + (send (make-object wx:frame% null "Testing" -1 -1 100 100) + show #t)))) + (unless (memq 'force flags) + (run-exit-callbacks)))) + + (let loop () + (collect-garbage) + (collect-garbage) + (wx:yield) (sleep) (wx:yield) (sleep) + (wx:yield) (sleep) (wx:yield) (sleep) + (wx:yield) (sleep) (wx:yield) (sleep) + (wx:yield) (sleep) (wx:yield) (sleep) + (wx:yield) (sleep) (wx:yield) (sleep) + (dump-memory-stats) + (let ([custodian (make-custodian)]) + (parameterize ([current-custodian custodian] + [wx:current-eventspace + (if (memq 'force flags) + (wx:make-eventspace) + (wx:current-eventspace))]) + (invoke-unit/sig + (make-invokable-unit my-app))) + (when (memq 'force flags) + (custodian-shutdown-all custodian))) + (loop))) diff --git a/collects/tests/mred/mediastream.ss b/collects/tests/mred/mediastream.ss new file mode 100644 index 00000000..a4c8a261 --- /dev/null +++ b/collects/tests/mred/mediastream.ss @@ -0,0 +1,60 @@ + +(define out-base (make-object wx:media-stream-out-string-base%)) +(define out (make-object wx:media-stream-out% out-base)) + +(define items (list 10 3.5 100 0 -1 -100 -3.5 "howdy")) + +(define (write-all) + (for-each + (lambda (i) + (send out put i)) + items)) + +(write-all) + +(let ([start (send out tell)]) + (send out put-fixed 100) + (write-all) + (let ([end (send out tell)]) + (send out jump-to start) + (send out put-fixed 99) + (send out jump-to end) + (send out put "End Second"))) + +(define file (send out-base get-string)) + +(define in-base (make-object wx:media-stream-in-string-base% file)) +(define in (make-object wx:media-stream-in% in-base)) + +(define (test expected got) + (unless (equal? expected got) + (error 'media-stream-test "expected ~s, got ~s~n" expected got))) + +(define (read-all) + (for-each + (lambda (i) + (test i + (cond + [(string? i) (send in get-string)] + [(inexact? i) (send in get-inexact)] + [else (send in get-exact)]))) + items)) +(read-all) +(test 99 (let ([b (box 0)]) + (send in get-fixed b) + (unbox b))) +(read-all) +(test "End Second" (send in get-string)) + +(define example-file-name (build-path (current-load-relative-directory) "mediastream.example")) +(define expect (if (file-exists? example-file-name) + (with-input-from-file example-file-name + (lambda () + (read-string (+ (string-length file) 10)))) + (begin + (fprintf (current-error-port) "Warning: ~a does not exist; creating it.~n" example-file-name) + (with-output-to-file example-file-name + (lambda () (display file))) + file))) +(unless (string=? file expect) + (error "generated file does not match expected file")) diff --git a/collects/tests/mred/random.ss b/collects/tests/mred/random.ss new file mode 100644 index 00000000..3c535b6f --- /dev/null +++ b/collects/tests/mred/random.ss @@ -0,0 +1,1028 @@ + +; (require-library "errortrace.ss" "errortrace") +(require-library "core.ss") + +(define example-list% + (class object% (name-in parents [filter (lambda (x) (not (void? x)))]) + (public + [name name-in] + [items '()] + [num-items 0] + [baddies null] + + [parents-count + (if parents + (map (lambda (parent) + (ivar parent count)) + parents) + '())] + [parents-choose + (if parents + (map (lambda (parent) + (ivar parent choose-example)) + parents) + '())] + [choose-parent-example + (lambda (which) + (let loop ([pos which][counts parents-count][chooses parents-choose]) + (if (null? counts) + (void) + (let ([c ((car counts))]) + (if (< pos c) + ((car chooses) pos) + (loop (- pos c) (cdr counts) (cdr chooses)))))))] + + [count + (lambda () (+ num-items (apply + (map (lambda (x) (x)) parents-count))))] + [set-filter + (lambda (f) + (set! filter f))] + [prepare values] + [set-prepare + (lambda (f) + (set! prepare f))] + [add + (lambda (x) + (if (filter x) + (begin + (set! num-items (add1 num-items)) + (set! items (cons x items))) + (error 'add "rejected: ~a in: ~a" x name)))] + [all-examples + (lambda () + (apply append items (map (lambda (p) (send p all-examples)) parents)))] + [choose-example + (opt-lambda ([which #f]) + (let ([n (if which + which + (let ([c (count)]) + (if (zero? c) + 0 + (random c))))]) + (if (< n num-items) + (prepare (list-ref items n)) + (choose-parent-example (- n num-items)))))] + [add-bad + (lambda (i) + (set! baddies (cons i baddies)))] + [bad-examples + (lambda () baddies)]) + (sequence (super-init)))) + +(define boxed-example-list% + (class object% (parent) + (public + [name `(boxed ,(ivar parent name))] + [all-examples + (lambda () + (let ([l (map box (send parent all-examples))]) + l))] + [choose-example + (opt-lambda ([which #f]) + (let ([ex (send parent choose-example)]) + (if (void? ex) + (void) + (box ex))))] + [bad-examples + (lambda () (cons 5 (map box (send parent bad-examples))))]) + (sequence (super-init)))) + +(define listed-example-list% + (class object% (parent) + (public + [name `(listed ,(ivar parent name))] + [all-examples + (lambda () + (let ([l (map list (send parent all-examples))]) + l))] + [add + (lambda (v) + (unless (list? v) + (error 'add "rejected: ~a in: ~a" v name)) + (for-each + (lambda (i) + (send parent add i)) + v))] + [choose-example + (opt-lambda ([which #f]) + (let ([ex (send parent choose-example)]) + (if (void? ex) + (void) + (list ex))))] + [bad-examples + (lambda () + (cons 5 (map list (send parent bad-examples))))]) + (sequence (super-init)))) + +(define optional-example-list% + (class object% (parent val) + (public + [name `(optional ,(ivar parent name))] + [all-examples + (lambda () + (let ([l (map box (send parent all-examples))]) + (cons val l)))] + [add + (lambda (x) + (and x (send parent add x)))] + [choose-example + (opt-lambda ([which #f]) + (if (zero? (random 2)) + val + (send parent choose-example)))] + [bad-examples + (lambda () (cons #t (send parent bad-examples)))]) + (sequence (super-init)))) + +(define choose-example-list% + (class object% (parents) + (public + [name `(choose ,(map (lambda (p) (ivar p name)) parents))] + [all-examples + (lambda () + (apply append (map (lambda (p) (send p all-examples)) parents)))] + [add void] + [choose-example + (opt-lambda ([which #f]) + (send (list-ref parents (random (length parents))) + choose-example which))] + [bad-examples + (lambda () null)]) + (sequence (super-init)))) + +(define unknown-example-list% + (class object% (who) + (public + [name `(unknown ,who)] + [all-examples (lambda () null)] + [add void] + [choose-example + (opt-lambda ([which #f]) + (format "[dummy for ~a]" name))] + [bad-examples + (lambda () null)]) + (sequence (super-init)))) + +(define discrete-example-list% + (class object% (vals) + (public + [name `(one-of ,@vals)] + [all-examples (lambda () vals)] + [add (lambda (x) (unless (member x vals) + (error '|add in discrete-example-list| + "no good: ~a" x)))] + [choose-example + (opt-lambda ([which #f]) + (list-ref vals (random (length vals))))] + [bad-examples + (lambda () + (if (member 'bad-example-symbol vals) + null + (list 'bad-example-symbol)))]) + (sequence (super-init)))) + +(define number-example-list% + (class object% (parent start end) + (public + [name `(number in ,start ,end)] + [all-examples + (lambda () + (filter ok (send parent all-examples)))] + [ok (lambda (v) (<= start v end))] + [add (lambda (v) + (send parent add v) + (unless (ok v) + (error 'add "rejected (late): ~a in: ~a" v name)))] + [choose-example + (opt-lambda ([which #f]) + (let loop () + (let ([v (send parent choose-example which)]) + (if (ok v) + v + (loop)))))] + [bad-examples + (lambda () + (list* (sub1 start) + (if (= (add1 end) end) + (- start 2) + (add1 end)) + (send parent bad-examples)))]) + (sequence (super-init)))) + +(define-struct (fatal-exn struct:exn) ()) + +(define (fatal-error name str . args) + (raise (make-fatal-exn (apply format (string-append "~a: " str) name args) + ((debug-info-handler))))) + +(define trying-class #f) +(define trying-method #f) + +(define null-results null) + +(define-macro define-main + (lambda list + (let loop ([l list][rest '()]) + (if (null? l) + (cons 'begin rest) + (loop (cdr l) + (let* ([first (car l)] + [name (if (symbol? first) + first + (car first))] + [strname (symbol->string name)] + [bases (if (symbol? first) + () + (cdr first))] + [el-name (lambda (s) + (if s + (string->symbol + (string-append + (symbol->string s) + "-example-list")) + #f))]) + (append + `((define ,(el-name name) + (make-object example-list% + ',name + (list ,@(map el-name bases)) + (lambda (v) (when (null? v) + (set! null-results (cons (list trying-class trying-method ',name) + null-results)) + (error ',name "got null")))))) + (if (or (regexp-match "%$" strname) (regexp-match "<%>$" strname)) + `((send ,(el-name name) set-filter (lambda (x) (is-a? x ,name))) + (send ,(el-name name) add-bad 5)) + null) + rest))))))) + +(define-main + void + (value char real string-list subarea<%>) + char + ubyte + integer + integer-list + symbol + real + real-list + string + string-list + boolean + procedure + eventspace + + (area<%> window<%> subarea<%> area-container<%>) + + (subarea<%> subwindow<%> pane%) + + (window<%> subwindow<%> area-container-window<%>) + + (area-container<%> area-container-window<%> pane%) + + (subwindow<%> control<%> canvas<%> panel%) + + (area-container-window<%> top-level-window<%> panel%) + + (control<%> message% button% check-box% slider% gauge% text-field% radio-box% list-control<%>) + + (list-control<%> choice% list-box%) + + (top-level-window<%> frame% dialog%) + + (pane% horizontal-pane% vertical-pane% grow-box-spacer-pane%) + + (panel% horizontal-panel% vertical-panel%) + + (canvas<%> canvas% editor-canvas%) + + message% + button% + check-box% + slider% + gauge% + text-field% + radio-box% + + choice% + list-box% + + canvas% + editor-canvas% + + horizontal-pane% + vertical-pane% + grow-box-spacer-pane% + + horizontal-panel% + vertical-panel% + + frame% + dialog% + + point% + + ps-setup% + + color% + font% + brush% + pen% + region% + + font-list% + pen-list% + brush-list% + color-database<%> + font-name-directory<%> + + cursor% + bitmap% + + (event% control-event% scroll-event% mouse-event% key-event%) + control-event% + scroll-event% + mouse-event% + key-event% + + (dc<%> bitmap-dc% post-script-dc% printer-dc%) + bitmap-dc% + post-script-dc% + printer-dc% + + (menu-item-container<%> menu% menu-bar% popup-menu%) + + popup-menu% + menu-bar% + + (menu-item<%> separator-menu-item% labelled-menu-item<%>) + (labelled-menu-item<%> selectable-menu-item<%> menu%) + (selectable-menu-item<%> menu-item% checkable-menu-item%) + separator-menu-item% + menu-item% + checkable-menu-item% + + menu% + + timer% + + add-color<%> + mult-color<%> + style-delta% + style<%> + style-list% + + (editor-admin% editor-snip-editor-admin<%>) + editor-snip-editor-admin<%> + snip-admin% + + (editor<%> text% pasteboard%) + text% + pasteboard% + + (snip% string-snip% image-snip% editor-snip%) + (string-snip% tab-snip%) + tab-snip% + image-snip% + editor-snip% + + snip-class% + snip-class-list<%> + + editor-data% + editor-data-class% + editor-data-class-list<%> + + keymap% + editor-wordbreak-map% + + (editor-stream-in-base% editor-stream-in-string-base%) + (editor-stream-out-base% editor-stream-out-string-base%) + + editor-stream-in-string-base% + editor-stream-out-string-base% + + editor-stream-in% + editor-stream-out% + + clipboard<%> + clipboard-client%) + +(send bitmap%-example-list set-filter (lambda (bm) (send bm ok?))) + +; Avoid stuck states in random testing: +(send frame%-example-list set-prepare (lambda (w) (send w enable #t) w)) +(send dialog%-example-list set-prepare (lambda (w) (send w enable #t) w)) + +(send boolean-example-list set-filter boolean?) +(send char-example-list set-filter char?) +(send string-example-list set-filter string?) +(send symbol-example-list set-filter symbol?) +(send real-example-list set-filter real?) +(send integer-example-list set-filter (lambda (x) (and (number? x) (exact? x) (integer? x)))) +(send integer-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (exact? x) (integer? x))) x)))) +(send real-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (real? x))) x)))) + +(define false-example-list (make-object example-list% 'false '())) +(send false-example-list add #f) +(send false-example-list add-bad #t) + +(send char-example-list add-bad 'not-a-char) +(send string-example-list add-bad 'not-a-string) +(send symbol-example-list add-bad "not a symbol") +(send real-example-list add-bad 4+5i) +(send integer-example-list add-bad 5.0) +(send integer-list-example-list add-bad 7) +(send real-list-example-list add-bad 7.0) + +(define empty-list-example-list (make-object example-list% 'empty-list '())) +(send empty-list-example-list add null) +(send empty-list-example-list add-bad #f) + +(send* boolean-example-list + (add #t) + (add #f)) + +(send* integer-example-list + (add 0) (add 0) (add 0) (add 0) + (add 0) (add 0) (add 0) (add 0) + (add 0) (add 0) (add 0) (add 0) + (add 0) (add 0) (add 0) (add 0) + (add -1) + (add -2) + (add -3) + (add -1000) + (add 1) + (add 2) + (add 3) + (add 4) + (add 5) + (add 6) + (add 7) + (add 8) + (add 9) + (add 10) + (add 16) + (add 32) + (add 64) + (add 128) + (add 256) + (add 255) + (add 1023) + (add 1000)) + +(send* real-example-list + (add 0.0) (add 0.0) + (add -1.0) + (add -2.0) + (add -1000.0) + (add 1.0) + (add 2.0) + (add 256.0) + (add +inf.0) + (add -inf.0) + (add 2/3) + (add -100/9)) + +(define non-negative-integer-example-list (make-object number-example-list% integer-example-list 0 +inf.0)) +(define positive-integer-example-list (make-object number-example-list% integer-example-list 1 +inf.0)) + +(define non-negative-real-example-list (make-object number-example-list% real-example-list 0 +inf.0)) +(define positive-integer-example-list (make-object number-example-list% real-example-list 1e-200 +inf.0)) + +(define (range-integer-example-list s e) + (make-object number-example-list% integer-example-list s e)) + +(define (range-real-example-list s e) + (make-object number-example-list% real-example-list s e)) + +(send* symbol-example-list + (add 'ok) (add 'change-family)) + +(send* string-list-example-list + (add '("apple" "banana" "coconut"))) + +(send* char-example-list + (add #\nul) + (add #\a) + (add #\1) + (add #\newline) + (add #\tab) + (add #\z) + (add #\C)) + +(send* real-example-list + (add 0.) + (add 0.) + (add 0.) + (add -1.) + (add -2.) + (add -3.) + (add -1000.) + (add 1.) + (add 2.) + (add 3.) + (add 1000.) + (add 5)) + +(send* string-example-list + (add "") + (add "hello") + (add "system/mred.xbm") + (add "system/mred.bmp") + (add "mred.gif") + (add "goodbye adious see you later zai jian seeya bye-bye")) + +(send procedure-example-list add void) + +(define classinfo (make-hash-table)) + +(define (add-all-combinations example-list items) + (for-each + (lambda (i) (send example-list add i)) + (let loop ([items items]) + (cond + [(null? (cdr items)) items] + [else (let ([l (loop (cdr items))]) + (append + (map (lambda (x) (bitwise-ior (car items) x)) l) + l))])))) + +(define (optional v l) (make-object optional-example-list% l v)) +(define (boxed l) (make-object boxed-example-list% l)) +(define (unknown s) (make-object unknown-example-list% s)) +(define (choice . l) (make-object choose-example-list% l)) +(define (style-list . l) (make-object listed-example-list% (make-object discrete-example-list% l))) +(define (symbol-in l) (make-object discrete-example-list% l)) + +(load-relative "windowing-classes.ss") +(load-relative "drawing-classes.ss") +(load-relative "editor-classes.ss") + +(define (get-args l) + (let/ec bad + (let loop ([l l]) + (if (null? l) + '() + (let* ([source (car l)] + [value (send source choose-example #f)]) + (if (void? value) + (bad (format "no examples: ~a" (ivar source name))) + (cons value (loop (cdr l))))))))) + +(define (get-all-args l) + (let loop ([l l]) + (if (null? l) + '() + (let* ([source (car l)] + [values (send source all-examples)] + [rest (loop (cdr l))]) + (if (null? (cdr l)) + (list values) + (apply append + (map (lambda (other) + (map (lambda (v) (cons v other)) values)) + rest))))))) + +(define-struct posargs (good bads)) + +(define (get-bad-args l) + (let/ec bad + (let loop ([l l]) + (if (null? l) + '() + (let* ([source (car l)] + [good (send source choose-example #f)] + [bads (send source bad-examples)]) + (if (void? good) + (bad (format "no examples: ~a" (ivar source name))) + (cons (make-posargs good bads) (loop (cdr l))))))))) + +(define thread-output-port current-output-port) + +(define print-only? #f) + +(define (apply-args v dest name k) + (if (list? v) + (begin + (fprintf (thread-output-port) "~a: ~s" name v) + (flush-output (thread-output-port)) + (if print-only? + (newline) + (with-handlers (((lambda (x) (not (fatal-exn? x))) + (lambda (x) + (fprintf (thread-output-port) + ": error: ~a~n" + (exn-message x))))) + (if (eq? dest 'values) + (k v) + (send dest add (k v))) + (flush-display) + (fprintf (thread-output-port) ": success~n")))) + (fprintf (thread-output-port) "~a: failure: ~a~n" name v))) + +(define (try-args arg-types dest name k) + (apply-args (get-args arg-types) dest name k)) + +(define (try-all-args arg-types dest name k) + (let ([vs (get-all-args arg-types)]) + (for-each (lambda (v) + (apply-args v dest name k)) + vs))) + +(define (apply-bad-args v dest name k bad) + (fprintf (thread-output-port) "~a: ~s" name v) + (flush-output (thread-output-port)) + (with-handlers ([exn:application:type? + (lambda (x) + (fprintf (thread-output-port) ": exn: ~a~n" + (exn-message x)) + ;; Check for expected bad value in exn record + (unless (eqv? bad (exn:application-value x)) + (if (or (and (box? bad) (eqv? (unbox bad) (exn:application-value x))) + (and (pair? bad) (null? (cdr bad)) + (eqv? (car bad) (exn:application-value x)))) + (fprintf (thread-output-port) + " BOX/PAIR CONTEXT MISMATCH: ~a~n" bad) + (fprintf (thread-output-port) + " EXN CONTENT MISMATCH: ~a != ~a~n" + (exn:application-value x) bad))) + ;; Check that exn is from the right place: + (let ([class (if (list? name) + (let ([n (car name)]) + (if (symbol? n) + n + '|.|)) + name)] + [method (if (list? name) (cadr name) 'initialization)]) + (when (eq? method 'initialization) + ; init is never inherited, so class name really should be present + (unless (regexp-match (symbol->string class) (exn-message x)) + (fprintf (thread-output-port) + " NO OCCURRENCE of class name ~a in the error message~n" + class))) + (unless (regexp-match (symbol->string method) (exn-message x)) + (fprintf (thread-output-port) + " NO OCCURRENCE of method ~a in the error message~n" + method))))] + [exn:application:arity? + (lambda (x) + (fprintf (thread-output-port) + ": UNEXPECTED ARITY MISMATCH: ~a~n" + (exn-message x)))] + [(lambda (x) (not (fatal-exn? x))) + (lambda (x) + (fprintf (thread-output-port) + ": WRONG EXN TYPE: ~a~n" + (exn-message x)))]) + (k v) + (flush-display) + (fprintf (thread-output-port) ": NO EXN RAISED~n"))) + +(define (try-bad-args arg-types dest name k) + (let ([args (get-bad-args arg-types)]) + (cond + [(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a~n" name args)] + [else + (let loop ([pres null][posts args]) + (unless (null? posts) + (for-each + (lambda (bad) + (apply-bad-args (append + (map posargs-good pres) + (list bad) + (map posargs-good (cdr posts))) + dest name k bad)) + (posargs-bads (car posts))) + (loop (append pres (list (car posts))) (cdr posts))))]))) + +(define (create-some cls try) + (when (class? cls) + (let* ([v (hash-table-get classinfo cls)] + [dest (car v)] + [name (cadr v)] + [creators (caddr v)]) + (let loop ([l creators]) + (unless (null? l) + (try (car l) dest name + (lambda (v) + (apply make-object cls v))) + (loop (cdr l))))))) + +(define (create-all-random) + (fprintf (thread-output-port) "creating all randomly...~n") + (hash-table-for-each classinfo (lambda (k v) + (create-some k try-args)))) +(define (create-all-exhaust) + (fprintf (thread-output-port) "creating all exhaustively...~n") + (hash-table-for-each classinfo (lambda (k v) + (create-some k try-all-args)))) + +(define (create-all-bad) + (fprintf (thread-output-port) "creating all with bad arguments...~n") + (hash-table-for-each classinfo (lambda (k v) + (create-some k try-bad-args)))) + +(define (try-methods cls try) + (let* ([v (hash-table-get classinfo cls)] + [source (car v)] + [use (if source (send source choose-example) #f)] + [name (cadr v)] + [methods (cdddr v)]) + (if (void? use) + (fprintf (thread-output-port) "~s: no examples~n" name) + (let loop ([l methods]) + (unless (null? l) + (unless (symbol? (car l)) + (let* ([method (car l)] + [iv (car method)] + [resulttype (caddr method)] + [argtypes (cdddr method)]) + (set! trying-class (and source (ivar source name))) + (set! trying-method iv) + (try argtypes resulttype (list name iv use) + (lambda (args) + (if use + (begin + + ;; Avoid showing a disabled dialog + (when (and (is-a? use dialog%) + (eq? iv 'show) + (equal? args '(#t))) + (send use enable #t)) + + ;; Avoid excessive scaling + (when (eq? iv 'set-scale) + (set! args (map (lambda (x) (min x 10)) args))) + + (apply (ivar/proc use iv) args)) + + (apply (global-defined-value iv) args)))))) + (loop (cdr l))))))) + +(define (call-random except) + (fprintf (thread-output-port) "calling all except ~a randomly...~n" except) + (hash-table-for-each classinfo (lambda (k v) + (unless (member k except) + (try-methods k try-args))))) + +(define (call-all-random) + (call-random null)) + +(define (call-all-bad) + (fprintf (thread-output-port) "calling all with bad arguments...~n") + (hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args)))) + +(define (call-all-non-editor) + (call-random (list :editor-buffer% :editor-edit% :editor-snip% :editor-pasteboard% 'EditorGlobal))) + +(define (init) + (create-all-random) + (create-all-random) + (create-all-random) + (create-all-random)) + +(with-handlers ([void (lambda (x) + (printf "Warning: couldn't load classhack.so~n"))]) + (load-relative-extension "classhack.so")) + +(printf " Creating Example Instances~n") + +(define f (make-object frame% "Example Frame 1")) +(send frame%-example-list add f) + +(define d (make-object dialog% "Example Dialog 1")) +(send dialog%-example-list add d) + +(define hpl (make-object horizontal-panel% f)) +(send horizontal-panel%-example-list add hpl) +(define vpl (make-object vertical-panel% d)) +(send vertical-panel%-example-list add vpl) +(define hp (make-object horizontal-pane% d)) +(send horizontal-pane%-example-list add hp) +(define vp (make-object vertical-pane% f)) +(send vertical-pane%-example-list add vp) +(define sp (make-object grow-box-spacer-pane% f)) +(send grow-box-spacer-pane%-example-list add sp) + +(send message%-example-list add (make-object message% "Message 1" hpl)) +(send button%-example-list add (make-object button% "Button 1" vpl void)) +(send check-box%-example-list add (make-object check-box% "Check Box 1" hp void)) +(send slider%-example-list add (make-object slider% "Slider 1" -10 10 vp void)) +(send gauge%-example-list add (make-object gauge% "Gauge 1" 100 hpl)) +(send text-field%-example-list add (make-object text-field% "Text Field 1" vpl void)) +(send radio-box%-example-list add (make-object radio-box% "Radio Box 1" '("Radio Button 1.1" "Radio Button 1.2") hp void)) +(send choice%-example-list add (make-object choice% "Choice 1" '("Choice 1.1" "Choice 1.2" "Choice 1.3") vp void)) +(send list-box%-example-list add (make-object list-box% "List Box 1" '("List Box 1.1" "List Box 1.2" "List Box 1.3") hpl void)) + +(send canvas%-example-list add (make-object canvas% f)) +(define c (make-object editor-canvas% d)) +(send editor-canvas%-example-list add c) + +(send point%-example-list add (make-object point% 50 60)) + +(send ps-setup%-example-list add (make-object ps-setup%)) + +(send color%-example-list add (make-object color% "RED")) +(send font%-example-list add (make-object font% 12 'roman 'normal 'normal)) +(send brush%-example-list add (make-object brush% "GREEN" 'solid)) +(send pen%-example-list add (make-object pen% "BLUE" 1 'solid)) +(send region%-example-list add (make-object region% (send c get-dc))) + +(send font-list%-example-list add the-font-list) +(send pen-list%-example-list add the-pen-list) +(send brush-list%-example-list add the-brush-list) +(send color-database<%>-example-list add the-color-database) +(send font-name-directory<%>-example-list add the-font-name-directory) + +(send cursor%-example-list add (make-object cursor% 'watch)) +(send bitmap%-example-list add (make-object bitmap% (build-path (collection-path "icons") "bb.gif"))) + +(send control-event%-example-list add (make-object control-event% 'list-box)) +(send scroll-event%-example-list add (make-object scroll-event%)) +(send mouse-event%-example-list add (make-object mouse-event% 'left-down)) +(send key-event%-example-list add (make-object key-event%)) + +(send bitmap-dc%-example-list add (make-object bitmap-dc%)) +(send post-script-dc%-example-list add (make-object post-script-dc% #f)) + +(with-handlers ([void void]) + (send printer-dc%-example-list add (make-object printer-dc%))) + +(define mb (make-object menu-bar% f)) +(send menu-bar%-example-list add mb) +(define m (make-object menu% "Menu1" mb)) +(send menu%-example-list add m) +(send popup-menu%-example-list add (make-object popup-menu% "Popup Menu 1")) + +(send separator-menu-item%-example-list add (make-object separator-menu-item% m)) +(send menu-item%-example-list add (make-object menu-item% "Menu Item 1" m void)) +(send checkable-menu-item%-example-list add (make-object checkable-menu-item% "Checkable Menu Item 1" m void)) + +(send timer%-example-list add (make-object timer%)) + +(define sd (make-object style-delta%)) +(send add-color<%>-example-list add (send sd get-background-add)) +(send mult-color<%>-example-list add (send sd get-background-mult)) +(send style-delta%-example-list add sd) +(define sl (make-object style-list%)) +(send style-list%-example-list add sl) +(send style<%>-example-list add (send sl basic-style)) + +(define e (make-object text%)) +(send c set-editor e) +(send text%-example-list add e) +(send pasteboard%-example-list add (make-object pasteboard%)) + +(define s (make-object editor-snip%)) +(send e insert s) +(send editor-snip-editor-admin<%>-example-list add (send (send s get-editor) get-admin)) +(send snip-admin%-example-list add (make-object snip-admin%)) + +(send tab-snip%-example-list add (make-object tab-snip%)) +(send image-snip%-example-list add (make-object image-snip%)) +(send editor-snip%-example-list add (make-object editor-snip%)) + +(send snip-class%-example-list add (make-object snip-class%)) +(send snip-class-list<%>-example-list add (get-the-snip-class-list)) + +(send editor-data%-example-list add (make-object editor-data%)) +(send editor-data-class%-example-list add (make-object editor-data-class%)) +(send editor-data-class-list<%>-example-list add (get-the-editor-data-class-list)) + +(send keymap%-example-list add (make-object keymap%)) +(send editor-wordbreak-map%-example-list add the-editor-wordbreak-map) + +(define sib (make-object editor-stream-in-string-base% "Hello")) +(send editor-stream-in-string-base%-example-list add sib) +(define sob (make-object editor-stream-out-string-base%)) +(send editor-stream-out-string-base%-example-list add sob) + +(send editor-stream-in%-example-list add (make-object editor-stream-in% sib)) +(send editor-stream-out%-example-list add (make-object editor-stream-out% sob)) + +(send clipboard<%>-example-list add the-clipboard) +(send clipboard-client%-example-list add (make-object clipboard-client%)) + +(printf " Done Creating Example Instances~n") + +(printf " Checking all methods~n") +(define in-top-level null) +(hash-table-for-each classinfo + (lambda (key v) + (let* ([methods (cdddr v)] + [names (map (lambda (x) (if (pair? x) (car x) x)) methods)]) + (if (string? key) + ;; Check global procs/values + (for-each + (lambda (name method) + (if (void? (with-handlers ([void void]) + (global-defined-value name))) + ;; Not there + (printf "No such procedure/value: ~a~n" name) + + (let ([v (global-defined-value name)]) + (when (procedure? v) + ;; check arity + (unless (equal? (arity v) (cadr method)) + (printf "Arity mismatch for ~a, real: ~a documented: ~a~n" + name (arity v) (cadr method)))))) + + (set! in-top-level (cons name in-top-level))) + names methods) + ;; Check intf/class methods + (begin + (set! in-top-level (cons (cadr v) in-top-level)) + + ; Check printed form: + (let ([p (open-output-string)]) + (display key p) + (let ([sp (get-output-string p)] + [ss (let ([s (symbol->string (cadr v))]) + (format "#<~a:~a>" + (if (interface? key) "interface" "class") + s))]) + (unless (string=? sp ss) + (printf "bad printed form: ~a != ~a~n" sp ss)))) + + ; Check documented methods are right + (let ([ex (send (car v) choose-example)]) + (unless (is-a? ex key) + (printf "Bad example: ~a for ~a~n" ex key)) + (for-each + (lambda (name method) + (if (or (and (interface? key) + (ivar-in-interface? name key)) + (and (class? key) + (ivar-in-interface? name (class->interface key)))) + + ;; Method is there, check arity + (when (is-a? ex key) + (let ([m (ivar/proc ex name)]) + (unless (equal? (arity m) (cadr method)) + (printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a~n" + name key + (arity m) (cadr method))))) + + ;; Not there + (printf "No such method: ~a in ~a~n" name key))) + names methods)) + + ; Check everything is documented + (when (procedure? (with-handlers ([void void]) (global-defined-value 'class->names))) + (for-each + (lambda (n) + (unless (memq n names) + (printf "Undocumented method: ~a in ~a~n" n key))) + (let ([l ((if (interface? key) interface->names class->names) key)] + [l2 (interface->ivar-names (if (interface? key) + key + (class->interface key)))]) + (unless (and (= (length l) + (length l2)) + (andmap (lambda (i) (member i l2)) + l)) + (printf "Ivar list doesn't match expected for ~a~n" key)) + l)))))))) +(printf " Method-checking done~n") + +(let* ([get-all (lambda (n) + (parameterize ([current-namespace n]) + (map car (make-global-value-list))))] + [expect-n (list* 'mred@ 'mred^ (append (get-all (make-namespace)) in-top-level))] + [actual-n (get-all (make-namespace 'mred))]) + (for-each + (lambda (i) + (unless (memq i expect-n) + (printf "Undocumented global: ~a~n" i))) + actual-n)) + +(unless (and (>= (vector-length argv) 1) + (string=? (vector-ref argv 0) "-r")) + (exit 0)) + +;; Remove some things: +(for-each (lambda (p) + (let ([k (ormap (lambda (k) + (and (equal? k (car p)) + k)) + (hash-table-map classinfo (lambda (k v) k)))]) + (hash-table-put! + classinfo k + (let ([l (hash-table-get classinfo k)]) + (let loop ([l l]) + (cond + [(null? l) null] + [(and (pair? (car l)) + (eq? (cadr p) (caar l))) + (cdr l)] + [else (cons (car l) (loop (cdr l)))])))))) + '(("Eventspaces" sleep/yield))) + +(random-seed 179) + +(create-all-bad) +(call-all-bad) + +(create-all-random) +(call-all-random) diff --git a/collects/tests/mred/showkey.ss b/collects/tests/mred/showkey.ss new file mode 100644 index 00000000..45a633c0 --- /dev/null +++ b/collects/tests/mred/showkey.ss @@ -0,0 +1,40 @@ + +(require-library "macro.ss") + +(let ([c% + (class-asi canvas% + (override + [on-event + (lambda (ev) + (printf "MOUSE ~a meta: ~a control: ~a alt: ~a shift: ~a buttons: ~a ~a ~a~n" + (send ev get-event-type) + (send ev get-meta-down) + (send ev get-control-down) + (send ev get-alt-down) + (send ev get-shift-down) + (send ev get-left-down) + (send ev get-middle-down) + (send ev get-right-down)))] + [on-char + (lambda (ev) + (printf "KEY code: ~a meta: ~a control: ~a alt: ~a shift: ~a~n" + (let ([v (send ev get-key-code)]) + (if (symbol? v) + v + (format "~a = ASCII ~a" v (char->integer v)))) + (send ev get-meta-down) + (send ev get-control-down) + (send ev get-alt-down) + (send ev get-shift-down)))]))]) + (define f (make-object (class frame% () + (inherit accept-drop-files) + (override + [on-drop-file (lambda (file) + (printf "Dropped: ~a~n" file))]) + (sequence + (super-init "tests" #f 100 100) + (accept-drop-files #t))))) + (define c (make-object c% f)) + (send c focus) + (send f show #t)) + diff --git a/collects/tests/mysterx/README b/collects/tests/mysterx/README new file mode 100644 index 00000000..e9bf3688 --- /dev/null +++ b/collects/tests/mysterx/README @@ -0,0 +1,26 @@ +MysterX test control +==================== + +The file mystests.ss in this directory creates a window +with a test ActiveX control, and runs a number of tests on it. +After the internal tests are performed, you can interact +with the test control using a mouse. + +The C++ code in the src subdirectory is supplied uncompiled. +You need Visual C++ 6.0 to compile it. You may need to +change the directory for MZC in testobject.mak if you have +installed PLT software to a nonstandard location. + +To compile, run "nmake". Once you've compiled the test ActiveX +control, load "mystests.ss". + +DHTML test code +=============== + +The file dhtmltests.ss contains a number of tests +for the Dynamic HTML capabilities of MysterX. +Simply load the file into MzScheme or DrScheme to run the +tests. Any errors will be printed in the REPL. +The behavior that appears in the window that is created +may be ignored. + diff --git a/collects/tests/mysterx/dhtmltests.ss b/collects/tests/mysterx/dhtmltests.ss new file mode 100644 index 00000000..a827fb6e --- /dev/null +++ b/collects/tests/mysterx/dhtmltests.ss @@ -0,0 +1,133 @@ +;;; dhtmltests.ss -- DHTML tests for MysterX + +(require-library "mysterx.ss" "mysterx") + +(define wb (make-object mx-browser% "DHTML tests" 300 300 + 'default 'default '(maximize))) + +(define doc (send wb current-document)) + +(send doc insert-html "

This is some text

") + +(define txt (send doc find-element "P" "text")) + +(define (test-prop getter setter expected) + (printf "Checking ~a~n" getter) + ((ivar/proc txt setter) expected) + (let ([got ((ivar/proc txt getter))]) + (unless (equal? got expected) + (printf "~a: Expected ~a, got ~a~n" + getter expected got)))) + +(define tests + `((font-family set-font-family! ("monospace" "fantasy")) + (font-size set-font-size! xx-large) + (font-style set-font-style! oblique) + (font-variant set-font-variant! small-caps) + (font-weight set-font-weight! bolder) + (background-attachment set-background-attachment! fixed) + (background-image + set-background-image! + "http://www.cs.rice.edu/CS/PLT/packages/drscheme/logo.gif") + (background-repeat set-background-repeat! no-repeat) + (background-position set-background-position! (right bottom)) + (background-position-x set-background-position-x! + ,(make-css-length 42 'em)) + (background-position-y set-background-position-y! + ,(make-css-percentage 95)) + (letter-spacing set-letter-spacing! normal) + (letter-spacing set-letter-spacing! + ,(make-css-length 20 'pt)) + (vertical-align set-vertical-align! super) + (text-decoration set-text-decoration! (underline line-through)) + (text-decoration-underline set-text-decoration-underline! #t) + (text-decoration-overline set-text-decoration-overline! #t) + (text-decoration-linethrough set-text-decoration-linethrough! #t) + (text-decoration-blink set-text-decoration-blink! #t) + (color set-color! red) + (background-color set-background-color! orange) + (pixel-top set-pixel-top! 27) + (pixel-left set-pixel-left! 99) + (pixel-width set-pixel-width! 99) + (pixel-height set-pixel-height! 199) + (overflow set-overflow! scroll) + (pos-top set-pos-top! 13.0) + (pos-left set-pos-left! 17.0) + (pos-width set-pos-width! 188.0) + (text-transform set-text-transform! uppercase) + (text-align set-text-align! justify) + (text-indent set-text-indent! ,(make-css-length 50 'pt)) + (line-height set-line-height! ,(make-css-percentage 200)) + (margin set-margin! (auto ,(make-css-length 70 'pt) auto auto)) + (margin-top set-margin-top! ,(make-css-length 70 'pt)) + (margin-bottom set-margin-bottom! auto) + (margin-left set-margin-left! auto) + (margin-right set-margin-right! ,(make-css-percentage 200)) + (pagebreak-before set-pagebreak-before! always) + (pagebreak-after set-pagebreak-after! always) + (cursor set-cursor! help) + (padding set-padding! ,(list (make-css-length 70 'pt) (make-css-percentage 300))) + (padding-top set-padding-top! ,(make-css-length 30 'em)) + (padding-bottom set-padding-bottom! ,(make-css-length 3 'cm)) + (padding-left set-padding-left! ,(make-css-length 3 'ex)) + (padding-right set-padding-right! ,(make-css-length 70 'mm)) + (border set-border! (blue ,(make-css-length 6 'pt) solid)) + (border-top set-border-top! (red ,(make-css-length 8 'pt) dashed)) + (border-bottom set-border-bottom! (green ,(make-css-length 4 'pt) dotted)) + (border-left set-border-left! (pink thick dotted)) + (border-right set-border-right! (black thin dashed)) + (border-color set-border-color! orange) + (border-top-color set-border-top-color! cyan) + (border-bottom-color set-border-bottom-color! darkseagreen) + (border-left-color set-border-left-color! goldenrod) + (border-right-color set-border-right-color! purple) + (border-width set-border-width! ,(make-css-length 20 'pt)) + (border-top-width set-border-top-width! ,(make-css-length 15 'pt)) + (border-bottom-width set-border-bottom-width! ,(make-css-length 15 'pt)) + (border-left-width set-border-left-width! ,(make-css-length 15 'pt)) + (border-right-width set-border-right-width! ,(make-css-length 15 'pt)) + (border-bottom-width set-border-bottom-width! ,(make-css-length 30 'pt)) + (border-left-width set-border-left-width! ,(make-css-length 30 'em)) + (border-right-width set-border-right-width! ,(make-css-length 1 'in)) + (border-style set-border-style! solid) + (border-top-style set-border-top-style! none) + (border-bottom-style set-border-bottom-style! dashed) + (border-left-style set-border-left-style! dotted) + (border-right-style set-border-right-style! none) + (style-float set-style-float! left) + (display set-display! list-item) + (list-style-type set-list-style-type! lower-roman) + (list-style-position set-list-style-position! inside) + (visibility set-visibility! hidden) + (clip set-clip! + (,(make-css-length 2 'cm) auto + ,(make-css-length 5 'in) auto)) + (clip set-clip! + (,(make-css-length 2 'cm) auto + ,(make-css-length 5 'in) auto)) + (style-float set-style-float! left) + (clear set-clear! both) + (width set-width! ,(make-css-percentage 50)) + (height set-height! ,(make-css-percentage 50)) + (top set-top! auto) + (left set-left! auto) + (z-index set-z-index! 4))) + +(for-each + (lambda (t) + (apply test-prop t)) + tests) + +; filter test + +(define filter-spec + '(glow (strength 99) (enabled #t) (color "#ff00ff"))) + +(apply (ivar/proc txt 'set-filter!) filter-spec) + +(let ([result (send txt filter)]) + (if (equal? result filter-spec) + (printf "Checking filter~n") + (error (format "filter test: Expected ~a, got ~a~n" + filter-spec result)))) + diff --git a/collects/tests/mysterx/mystests.ss b/collects/tests/mysterx/mystests.ss new file mode 100644 index 00000000..6502acb2 --- /dev/null +++ b/collects/tests/mysterx/mystests.ss @@ -0,0 +1,71 @@ +;;; mystests.ss -- test suite for MysterX + +(require-library "mysterx.ss" "mysterx") + +(define wb (make-object mx-browser% "MysTest" 230 250)) +(define doc (send wb current-document)) + +(define ctrl (send doc insert-object "TestControl Class" 95 95 'percent)) + +(define (inv f . args) (apply com-invoke ctrl f args)) + +(define errors? #f) + +(define tests + `(("AddTest" (39 ,(box 420)) ,(+ 39 420)) + ("AddTest" (420 ,(box 39)) ,(+ 420 39)) + ("FloatTest" (4.7 5.2) ,(- 5.2 4.7)) + ("FloatTest" (88.7 33.2) ,(- 33.2 88.7)) + ("FloatTest" (-88.7 33.2) ,(- 33.2 -88.7)) + ("StringTest" ("abc" "def") ,"abcdef") + ("StringTest" ("Supercali" "fragilistic") ,"Supercalifragilistic") + ("ShortTest" (42 17) ,(* 42 17)) + ("ShortTest" (77 -22) ,(* 77 -22)))) + +(for-each + (lambda (t) + (let ([got (apply inv (car t) (cadr t))] + [expected (caddr t)]) + (unless (equal? got expected) + (set! errors? #t) + (printf "Expected: ~a~nGot : ~a~n" + expected got)))) + tests) + +(define caption "SomeCaption") + +(com-set-property! ctrl "Caption" caption) + +(unless (string=? caption (com-get-property ctrl "Caption")) + (set! errors? #t)) + +(when errors? + (printf "There were errors!~n")) + +(define (make-mousefun s) + (let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a~n")]) + (lambda (button shift x y) + (printf t button shift x y)))) + +(define (mouse-pair s) + (list s (make-mousefun s))) + +(unless errors? + (for-each + (lambda (sf) + (com-register-event-handler ctrl (car sf) (cadr sf))) + `(("Click" + ,(lambda () (printf "Click~n"))) + ,(mouse-pair "MouseMove") + ,(mouse-pair "MouseDown") + ,(mouse-pair "MouseUp"))) + + (printf "Try clicking and moving the mouse over the object~n") + (printf "You should see Click, MouseMove, MouseDown, and MouseUp events~n")) + + + + + + + diff --git a/collects/tests/mysterx/src/Makefile b/collects/tests/mysterx/src/Makefile new file mode 100644 index 00000000..75fbf3a1 --- /dev/null +++ b/collects/tests/mysterx/src/Makefile @@ -0,0 +1,2 @@ +all : + nmake /f testobject.mak diff --git a/collects/tests/mysterx/src/resource.h b/collects/tests/mysterx/src/resource.h new file mode 100644 index 00000000..862c34d5 --- /dev/null +++ b/collects/tests/mysterx/src/resource.h @@ -0,0 +1,18 @@ +//{{NO_DEPENDENCIES}} +// Microsoft Developer Studio generated include file. +// Used by testobject.rc +// +#define IDS_PROJNAME 100 +#define IDB_TESTCONTROL 101 +#define IDR_TESTCONTROL 102 + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NEXT_RESOURCE_VALUE 201 +#define _APS_NEXT_COMMAND_VALUE 32768 +#define _APS_NEXT_CONTROL_VALUE 201 +#define _APS_NEXT_SYMED_VALUE 103 +#endif +#endif diff --git a/collects/tests/mysterx/src/stdafx.cxx b/collects/tests/mysterx/src/stdafx.cxx new file mode 100644 index 00000000..a5eea178 --- /dev/null +++ b/collects/tests/mysterx/src/stdafx.cxx @@ -0,0 +1,12 @@ +// stdafx.cpp : source file that includes just the standard includes +// stdafx.pch will be the pre-compiled header +// stdafx.obj will contain the pre-compiled type information + +#include "stdafx.h" + +#ifdef _ATL_STATIC_REGISTRY +#include +#include +#endif + +#include diff --git a/collects/tests/mysterx/src/stdafx.h b/collects/tests/mysterx/src/stdafx.h new file mode 100644 index 00000000..79976b0b --- /dev/null +++ b/collects/tests/mysterx/src/stdafx.h @@ -0,0 +1,28 @@ +// stdafx.h : include file for standard system include files, +// or project specific include files that are used frequently, +// but are changed infrequently + +#if !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_) +#define AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_ + +#if _MSC_VER > 1000 +#pragma once +#endif // _MSC_VER > 1000 + +#define STRICT +#ifndef _WIN32_WINNT +#define _WIN32_WINNT 0x0400 +#endif +#define _ATL_APARTMENT_THREADED + +#include +//You may derive a class from CComModule and use it if you want to override +//something, but do not change the name of _Module +extern CComModule _Module; +#include +#include + +//{{AFX_INSERT_LOCATION}} +// Microsoft Visual C++ will insert additional declarations immediately before the previous line. + +#endif // !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED) diff --git a/collects/tests/mysterx/src/testcont.bmp b/collects/tests/mysterx/src/testcont.bmp new file mode 100644 index 0000000000000000000000000000000000000000..122976492c7c0572b0bab819e7a01b7c59a56c22 GIT binary patch literal 246 zcmZvTu@S={3`M{1a>w~-Oz90WNBZodDsCCUl-fd_3mT?MOTHkb1z%6nmtOBLW_*Yz zwf(i=F^oL&U83V=&J)Zm(OM(j=;NbzuP8nrd2dAIz<@|O9Wa}$vyYd+g5Ww13Dg-R lBFL&IBCx8eaZ`(GWv_ctBa7~-@={Amew7$okj0rc#}8UDI@bUI literal 0 HcmV?d00001 diff --git a/collects/tests/mysterx/src/testcontrol.cxx b/collects/tests/mysterx/src/testcontrol.cxx new file mode 100644 index 00000000..22563ffc --- /dev/null +++ b/collects/tests/mysterx/src/testcontrol.cxx @@ -0,0 +1,51 @@ +// TestControl.cpp : Implementation of CTestControl + +#include "stdafx.h" +#include "Testobject.h" +#include "TestControl.h" + +///////////////////////////////////////////////////////////////////////////// +// CTestControl + + + +STDMETHODIMP CTestControl::AddTest(long n1, long *n2, long *n3) +{ + // note side effect + + + *n3 = n1 + *n2; + + *n2 = n1; + + return S_OK; +} + +STDMETHODIMP CTestControl::StringTest(BSTR s1, BSTR s2, BSTR *s3) +{ + int len1,len2; + + len1 = SysStringLen(s1); + len2 = SysStringLen(s2); + + *s3 = SysAllocStringByteLen(NULL,(len1 + len2 + 1)*2); + wcsncpy(*s3,s1,len1); + wcsncpy(*s3 + len1,s2,len2); + *(*s3 + len1 + len2) = L'\0'; + + return S_OK; +} + +STDMETHODIMP CTestControl::ShortTest(short n1, short n2, short *n3) +{ + *n3 = n1 * n2; + + return S_OK; +} + +STDMETHODIMP CTestControl::FloatTest(double n1, double n2, double *n3) +{ + *n3 = n2 - n1; + + return S_OK; +} diff --git a/collects/tests/mysterx/src/testcontrol.h b/collects/tests/mysterx/src/testcontrol.h new file mode 100644 index 00000000..90787c21 --- /dev/null +++ b/collects/tests/mysterx/src/testcontrol.h @@ -0,0 +1,172 @@ +// TestControl.h : Declaration of the CTestControl + +#ifndef __TESTCONTROL_H_ +#define __TESTCONTROL_H_ + +#include "resource.h" // main symbols +#include +#include +#include "testobjectCP.h" + + +///////////////////////////////////////////////////////////////////////////// +// CTestControl +class ATL_NO_VTABLE CTestControl : + public CComObjectRootEx, + public CStockPropImpl, + public CComControl, + public IPersistStreamInitImpl, + public IOleControlImpl, + public IOleObjectImpl, + public IOleInPlaceActiveObjectImpl, + public IViewObjectExImpl, + public IOleInPlaceObjectWindowlessImpl, + public IConnectionPointContainerImpl, + public IPersistStorageImpl, + public ISpecifyPropertyPagesImpl, + public IQuickActivateImpl, + public IDataObjectImpl, + public IProvideClassInfo2Impl<&CLSID_TestControl, &DIID__ITestControlEvents, &LIBID_TESTOBJECTLib>, + public IPropertyNotifySinkCP, + public CComCoClass, + public CProxy_ITestControlEvents< CTestControl > +{ +public: + CTestControl() + { + } + +DECLARE_REGISTRY_RESOURCEID(IDR_TESTCONTROL) + +DECLARE_PROTECT_FINAL_CONSTRUCT() + +BEGIN_COM_MAP(CTestControl) + COM_INTERFACE_ENTRY(ITestControl) + COM_INTERFACE_ENTRY(IDispatch) + COM_INTERFACE_ENTRY(IViewObjectEx) + COM_INTERFACE_ENTRY(IViewObject2) + COM_INTERFACE_ENTRY(IViewObject) + COM_INTERFACE_ENTRY(IOleInPlaceObjectWindowless) + COM_INTERFACE_ENTRY(IOleInPlaceObject) + COM_INTERFACE_ENTRY2(IOleWindow, IOleInPlaceObjectWindowless) + COM_INTERFACE_ENTRY(IOleInPlaceActiveObject) + COM_INTERFACE_ENTRY(IOleControl) + COM_INTERFACE_ENTRY(IOleObject) + COM_INTERFACE_ENTRY(IPersistStreamInit) + COM_INTERFACE_ENTRY2(IPersist, IPersistStreamInit) + COM_INTERFACE_ENTRY(IConnectionPointContainer) + COM_INTERFACE_ENTRY(ISpecifyPropertyPages) + COM_INTERFACE_ENTRY(IQuickActivate) + COM_INTERFACE_ENTRY(IPersistStorage) + COM_INTERFACE_ENTRY(IDataObject) + COM_INTERFACE_ENTRY(IProvideClassInfo) + COM_INTERFACE_ENTRY(IProvideClassInfo2) + COM_INTERFACE_ENTRY_IMPL(IConnectionPointContainer) +END_COM_MAP() + +BEGIN_PROP_MAP(CTestControl) + PROP_DATA_ENTRY("_cx", m_sizeExtent.cx, VT_UI4) + PROP_DATA_ENTRY("_cy", m_sizeExtent.cy, VT_UI4) + PROP_ENTRY("Caption", DISPID_CAPTION, CLSID_NULL) + // Example entries + // PROP_ENTRY("Property Description", dispid, clsid) + // PROP_PAGE(CLSID_StockColorPage) +END_PROP_MAP() + +BEGIN_CONNECTION_POINT_MAP(CTestControl) + CONNECTION_POINT_ENTRY(IID_IPropertyNotifySink) + CONNECTION_POINT_ENTRY(DIID__ITestControlEvents) +END_CONNECTION_POINT_MAP() + +BEGIN_MSG_MAP(CTestControl) + CHAIN_MSG_MAP(CComControl) + DEFAULT_REFLECTION_HANDLER() + MESSAGE_HANDLER(WM_LBUTTONDOWN, OnLButtonDown) + MESSAGE_HANDLER(WM_LBUTTONUP, OnLButtonUp) + MESSAGE_HANDLER(WM_MBUTTONDOWN, OnMButtonDown) + MESSAGE_HANDLER(WM_MBUTTONUP, OnMButtonUp) + MESSAGE_HANDLER(WM_RBUTTONDOWN, OnRButtonDown) + MESSAGE_HANDLER(WM_RBUTTONUP, OnRButtonUp) + MESSAGE_HANDLER(WM_MOUSEMOVE, OnMouseMove) +END_MSG_MAP() +// Handler prototypes: +// LRESULT MessageHandler(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled); +// LRESULT CommandHandler(WORD wNotifyCode, WORD wID, HWND hWndCtl, BOOL& bHandled); +// LRESULT NotifyHandler(int idCtrl, LPNMHDR pnmh, BOOL& bHandled); + + + +// IViewObjectEx + DECLARE_VIEW_STATUS(VIEWSTATUS_SOLIDBKGND | VIEWSTATUS_OPAQUE) + +// ITestControl +public: + STDMETHOD(FloatTest)(double n1,double n2,/*[out,retval]*/double *n3); + STDMETHOD(ShortTest)(short int n1,short int n2,/*[out,retval]*/short int *n3); + STDMETHOD(StringTest)(BSTR s1,BSTR s2,/*[out,retval]*/BSTR *s3); + STDMETHOD(AddTest)(long n1,long *n2,/*[out,retval]*/long *n3); + + HRESULT OnDraw(ATL_DRAWINFO& di) + { + RECT& rc = *(RECT*)di.prcBounds; + Rectangle(di.hdcDraw, rc.left, rc.top, rc.right, rc.bottom); + + SetTextAlign(di.hdcDraw, TA_CENTER|TA_BASELINE); + LPCTSTR pszText = _T("MysterX Test Control"); + TextOut(di.hdcDraw, + (rc.left + rc.right) / 2, + (rc.top + rc.bottom) / 2, + pszText, + lstrlen(pszText)); + + return S_OK; + } + CComBSTR m_bstrCaption; + LRESULT OnLButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseDown(0x1,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + Fire_Click(); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnLButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseUp(0x1,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnMButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseDown(0x4,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + Fire_Click(); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnMButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseUp(0x4,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnRButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseDown(0x2,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + Fire_Click(); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnRButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + Fire_MouseUp(0x2,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + return DefWindowProc(uMsg,wParam,lParam); + } + LRESULT OnMouseMove(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) + { + short button; + short shift; + + button = wParam & (MK_LBUTTON | MK_MBUTTON | MK_RBUTTON); + shift = wParam & (MK_CONTROL | MK_SHIFT); + + Fire_MouseMove(button,shift,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); + + return DefWindowProc(uMsg,wParam,lParam); + } +}; + +#endif //__TESTCONTROL_H_ diff --git a/collects/tests/mysterx/src/testcontrol.rgs b/collects/tests/mysterx/src/testcontrol.rgs new file mode 100644 index 00000000..8c369919 --- /dev/null +++ b/collects/tests/mysterx/src/testcontrol.rgs @@ -0,0 +1,34 @@ +HKCR +{ + Testobject.TestControl.1 = s 'TestControl Class' + { + CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}' + } + Testobject.TestControl = s 'TestControl Class' + { + CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}' + CurVer = s 'Testobject.TestControl.1' + } + NoRemove CLSID + { + ForceRemove {FED8FE26-19CA-11D3-B5DB-0060089002FE} = s 'TestControl Class' + { + ProgID = s 'Testobject.TestControl.1' + VersionIndependentProgID = s 'Testobject.TestControl' + ForceRemove 'Programmable' + InprocServer32 = s '%MODULE%' + { + val ThreadingModel = s 'Apartment' + } + ForceRemove 'Control' + ForceRemove 'Insertable' + ForceRemove 'ToolboxBitmap32' = s '%MODULE%, 101' + 'MiscStatus' = s '0' + { + '1' = s '131473' + } + 'TypeLib' = s '{07B31FF0-19EE-11D3-B5DB-0060089002FE}' + 'Version' = s '1.0' + } + } +} diff --git a/collects/tests/mysterx/src/testobject.cxx b/collects/tests/mysterx/src/testobject.cxx new file mode 100644 index 00000000..6f5f57a1 --- /dev/null +++ b/collects/tests/mysterx/src/testobject.cxx @@ -0,0 +1,72 @@ +// testobject.cpp : Implementation of DLL Exports. + + +// Note: Proxy/Stub Information +// To build a separate proxy/stub DLL, +// run nmake -f testobjectps.mk in the project directory. + +#include "stdafx.h" +#include "resource.h" +#include +#include "testobject.h" + +#include "testobject_i.c" +#include "TestControl.h" + + +CComModule _Module; + +BEGIN_OBJECT_MAP(ObjectMap) +OBJECT_ENTRY(CLSID_TestControl, CTestControl) +END_OBJECT_MAP() + +///////////////////////////////////////////////////////////////////////////// +// DLL Entry Point + +extern "C" +BOOL WINAPI DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID /*lpReserved*/) +{ + if (dwReason == DLL_PROCESS_ATTACH) + { + _Module.Init(ObjectMap, hInstance, &LIBID_TESTOBJECTLib); + DisableThreadLibraryCalls(hInstance); + } + else if (dwReason == DLL_PROCESS_DETACH) + _Module.Term(); + return TRUE; // ok +} + +///////////////////////////////////////////////////////////////////////////// +// Used to determine whether the DLL can be unloaded by OLE + +STDAPI DllCanUnloadNow(void) +{ + return (_Module.GetLockCount()==0) ? S_OK : S_FALSE; +} + +///////////////////////////////////////////////////////////////////////////// +// Returns a class factory to create an object of the requested type + +STDAPI DllGetClassObject(REFCLSID rclsid, REFIID riid, LPVOID* ppv) +{ + return _Module.GetClassObject(rclsid, riid, ppv); +} + +///////////////////////////////////////////////////////////////////////////// +// DllRegisterServer - Adds entries to the system registry + +STDAPI DllRegisterServer(void) +{ + // registers object, typelib and all interfaces in typelib + return _Module.RegisterServer(TRUE); +} + +///////////////////////////////////////////////////////////////////////////// +// DllUnregisterServer - Removes entries from the system registry + +STDAPI DllUnregisterServer(void) +{ + return _Module.UnregisterServer(TRUE); +} + + diff --git a/collects/tests/mysterx/src/testobject.def b/collects/tests/mysterx/src/testobject.def new file mode 100644 index 00000000..9dd3b921 --- /dev/null +++ b/collects/tests/mysterx/src/testobject.def @@ -0,0 +1,9 @@ +; testobject.def : Declares the module parameters. + +LIBRARY "testobject.DLL" + +EXPORTS + DllCanUnloadNow @1 PRIVATE + DllGetClassObject @2 PRIVATE + DllRegisterServer @3 PRIVATE + DllUnregisterServer @4 PRIVATE diff --git a/collects/tests/mysterx/src/testobject.idl b/collects/tests/mysterx/src/testobject.idl new file mode 100644 index 00000000..8176914b --- /dev/null +++ b/collects/tests/mysterx/src/testobject.idl @@ -0,0 +1,66 @@ +// testobject.idl : IDL source for testobject.dll +// + +// This file will be processed by the MIDL tool to +// produce the type library (testobject.tlb) and marshalling code. + +import "oaidl.idl"; +import "ocidl.idl"; +#include "olectl.h" + + + [ + object, + uuid(07B31FFC-19EE-11D3-B5DB-0060089002FE), + dual, + helpstring("ITestControl Interface"), + pointer_default(unique) + ] + interface ITestControl : IDispatch + { + [propput, id(DISPID_CAPTION)] + HRESULT Caption([in]BSTR strCaption); + [propget, id(DISPID_CAPTION)] + HRESULT Caption([out,retval]BSTR* pstrCaption); + [id(1), helpstring("method AddTest")] HRESULT AddTest(long n1,long *n2,[out,retval]long *n3); + [id(2), helpstring("method StringTest")] HRESULT StringTest(BSTR s1,BSTR s2,[out,retval]BSTR *s3); + [id(3), helpstring("method ShortTest")] HRESULT ShortTest(short int n1,short int n2,[out,retval]short int *n3); + [id(4), helpstring("method FloatTest")] HRESULT FloatTest(double n1,double n2,[out,retval]double *n3); + }; + +[ + uuid(07B31FF0-19EE-11D3-B5DB-0060089002FE), + version(1.0), + helpstring("testobject 1.0 Type Library") +] +library TESTOBJECTLib +{ + importlib("stdole32.tlb"); + importlib("stdole2.tlb"); + + [ + uuid(07B31FFD-19EE-11D3-B5DB-0060089002FE), + helpstring("_ITestControlEvents Interface") + ] + dispinterface _ITestControlEvents + { + properties: + methods: + [id(DISPID_CLICK), helpstring("method Click")] HRESULT Click(); + [id(DISPID_MOUSEDOWN), helpstring("method MouseDown")] HRESULT MouseDown(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); + [id(DISPID_MOUSEUP), helpstring("method MouseUp")] HRESULT MouseUp(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); + [id(1), helpstring("method KeyDown")] HRESULT KeyDown(short *keyCode,short shift); + [id(2), helpstring("method KeyUp")] HRESULT KeyUp(short *keyCode,short shift); + [id(3), helpstring("method MouseMove")] HRESULT MouseMove(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); + }; + + [ + uuid(FED8FE26-19CA-11D3-B5DB-0060089002FE), + helpstring("TestControl Class") + ] + coclass TestControl + { + [default] interface ITestControl; + [default, source] dispinterface _ITestControlEvents; + }; +}; diff --git a/collects/tests/mysterx/src/testobject.mak b/collects/tests/mysterx/src/testobject.mak new file mode 100644 index 00000000..3e78fd67 --- /dev/null +++ b/collects/tests/mysterx/src/testobject.mak @@ -0,0 +1,48 @@ +# mysterx.mak + +all : testobject.dll + +clean : + -@erase testcontrol.obj + -@erase testobject.obj + -@erase testobject.dll + +CPP=cl.exe +CPP_FLAGS=/MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /c + +MTL=midl.exe +MTL_SWITCHES=/tlb testobject.tlb /h testobject.h /iid testobject_i.c /Oicf +RSC=rc.exe +RSC_PROJ=/l 0x409 /fo"testobject.res" +REGSVR32=regsvr32 + +.cxx.obj:: + $(CPP) $(CPP_FLAGS) $< + +MZC="C:\Program Files\PLT\mzc" + +LINK32=link.exe +LINK32_FLAGS= \ + kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \ + advapi32.lib ole32.lib oleaut32.lib \ + uuid.lib odbc32.lib odbccp32.lib \ + /nologo /subsystem:windows /dll /incremental:no /machine:I386 \ + /def:testobject.def /out:testobject.dll +DEF_FILE=testobject.def +LINK32_OBJS= \ + testobject.obj testcontrol.obj testobject.res + +testobject.dll : $(DEF_FILE) $(LINK32_OBJS) + $(LINK32) $(LINK32_FLAGS) $(LINK32_OBJS) + $(REGSVR32) /s testobject.dll + +testcontrol.obj : testcontrol.cxx testobject.tlb stdafx.h + +testobject.obj : testobject.cxx stdafx.h + +testobject.tlb : testobject.idl + $(MTL) $(MTL_SWITCHES) testobject.idl + +testcontrol.res : testcontrol.rc testcontrol.tlb + $(RSC) $(RSC_PROJ) testcontrol.rc + diff --git a/collects/tests/mysterx/src/testobject.rc b/collects/tests/mysterx/src/testobject.rc new file mode 100644 index 00000000..0ae3fa9c --- /dev/null +++ b/collects/tests/mysterx/src/testobject.rc @@ -0,0 +1,132 @@ +//Microsoft Developer Studio generated resource script. +// +#include "resource.h" + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +#include "winres.h" + +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// English (U.S.) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) +#ifdef _WIN32 +LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE DISCARDABLE +BEGIN + "resource.h\0" +END + +2 TEXTINCLUDE DISCARDABLE +BEGIN + "#include ""winres.h""\r\n" + "\0" +END + +3 TEXTINCLUDE DISCARDABLE +BEGIN + "1 TYPELIB ""testobject.tlb""\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +#ifndef _MAC +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 1,0,0,1 + PRODUCTVERSION 1,0,0,1 + FILEFLAGSMASK 0x3fL +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904B0" + BEGIN + VALUE "CompanyName", "\0" + VALUE "FileDescription", "testobject Module\0" + VALUE "FileVersion", "1, 0, 0, 1\0" + VALUE "InternalName", "testobject\0" + VALUE "LegalCopyright", "Copyright 1999\0" + VALUE "OriginalFilename", "testobject.DLL\0" + VALUE "ProductName", "testobject Module\0" + VALUE "ProductVersion", "1, 0, 0, 1\0" + VALUE "OLESelfRegister", "\0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + +#endif // !_MAC + + +///////////////////////////////////////////////////////////////////////////// +// +// Bitmap +// + +IDB_TESTCONTROL BITMAP DISCARDABLE "testcont.bmp" + + +///////////////////////////////////////////////////////////////////////////// +// +// REGISTRY +// + +IDR_TESTCONTROL REGISTRY DISCARDABLE "TestControl.rgs" + +///////////////////////////////////////////////////////////////////////////// +// +// String Table +// + +STRINGTABLE DISCARDABLE +BEGIN + IDS_PROJNAME "testobject" +END + +#endif // English (U.S.) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// +1 TYPELIB "testobject.tlb" + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/collects/tests/mysterx/src/testobjectCP.h b/collects/tests/mysterx/src/testobjectCP.h new file mode 100644 index 00000000..9f65ed24 --- /dev/null +++ b/collects/tests/mysterx/src/testobjectCP.h @@ -0,0 +1,179 @@ +#ifndef _TESTOBJECTCP_H_ +#define _TESTOBJECTCP_H_ + + + + + + +template +class CProxy_ITestControlEvents : public IConnectionPointImpl +{ + //Warning this class may be recreated by the wizard. +public: + HRESULT Fire_Click() + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + DISPPARAMS disp = { NULL, NULL, 0, 0 }; + pDispatch->Invoke(DISPID_CLICK, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + return varResult.scode; + + } + HRESULT Fire_MouseDown(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + CComVariant* pvars = new CComVariant[4]; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + pvars[3] = button; + pvars[2] = shift; + pvars[1] = x; + pvars[0] = y; + DISPPARAMS disp = { pvars, NULL, 4, 0 }; + pDispatch->Invoke(DISPID_MOUSEDOWN, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + delete[] pvars; + return varResult.scode; + + } + HRESULT Fire_MouseUp(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + CComVariant* pvars = new CComVariant[4]; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + pvars[3] = button; + pvars[2] = shift; + pvars[1] = x; + pvars[0] = y; + DISPPARAMS disp = { pvars, NULL, 4, 0 }; + pDispatch->Invoke(DISPID_MOUSEUP, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + delete[] pvars; + return varResult.scode; + + } + HRESULT Fire_KeyDown(SHORT * keyCode, SHORT shift) + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + CComVariant* pvars = new CComVariant[2]; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + pvars[1] = keyCode; + pvars[0] = shift; + DISPPARAMS disp = { pvars, NULL, 2, 0 }; + pDispatch->Invoke(0x1, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + delete[] pvars; + return varResult.scode; + + } + HRESULT Fire_KeyUp(SHORT *keyCode, SHORT shift) + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + CComVariant* pvars = new CComVariant[2]; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + pvars[1] = keyCode; + pvars[0] = shift; + DISPPARAMS disp = { pvars, NULL, 2, 0 }; + pDispatch->Invoke(0x2, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + delete[] pvars; + return varResult.scode; + + } + HRESULT Fire_MouseMove(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) + { + CComVariant varResult; + T* pT = static_cast(this); + int nConnectionIndex; + CComVariant* pvars = new CComVariant[4]; + int nConnections = m_vec.GetSize(); + + for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) + { + pT->Lock(); + CComPtr sp = m_vec.GetAt(nConnectionIndex); + pT->Unlock(); + IDispatch* pDispatch = reinterpret_cast(sp.p); + if (pDispatch != NULL) + { + VariantClear(&varResult); + pvars[3] = button; + pvars[2] = shift; + pvars[1] = x; + pvars[0] = y; + DISPPARAMS disp = { pvars, NULL, 4, 0 }; + pDispatch->Invoke(0x3, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); + } + } + delete[] pvars; + return varResult.scode; + + } +}; +#endif \ No newline at end of file diff --git a/collects/tests/mzscheme/README b/collects/tests/mzscheme/README new file mode 100644 index 00000000..32bca41e --- /dev/null +++ b/collects/tests/mzscheme/README @@ -0,0 +1,44 @@ + +To run most of the tests, run: + > (load "PATHTOHERE/all.ss") +where PATHTOHERE is the path to this directory. + +Test failures may cause the test to stop before finishing, but most +test failures will let the test continue, and a summary message at the +end will enummerate the failures that occurred. + +Some files are directories are created (in the current directory) +during the run. The files are named "tmp" where is a number. +The directory is named "deep". If the test suite passes, the directory +should be removed, but some "tmp" files will remain. (The "tmp" +files are automatically replaced if the test suite is run again.) + +Unless your machine clock is always exactly in sync with your disk, +don't worry about failures that look like this: + ((path) (#f #t (#<|primitive:<=|> 11 39 11))) + ((path) (#f #t (#<|primitive:<=|> 11 39 11))) + ((path) (#f #t (#<|primitive:<=|> 11 39 11))) + +Additionally, test expand-defmacro by running: + > (load "PATHTOHERE/expand.ss") + +Test compilation and writing/reading compiled code with: + > (load "PATHTOHERE/compile.ss") + +Test deep non-tail recursion with: + > (load "PATHTOHERE/deep.ss") + +Run the standard tests with no output except for the results with: + > (load "PATHTOHERE/quiet.ss") + +Run 3 copies of the test suite concurrently in separate threads: + > (load "PATHTOHERE/parallel.ss") + +MzLib tests are run with: + > (load "PATHTOHERE/mzlib.ss") + + +Please report bugs using + http://www.cs.rice.edu/CS/PLT/Bugs/ +or (as a last resort) send mail to + plt-bugs@rice.edu diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss new file mode 100644 index 00000000..8c2f2925 --- /dev/null +++ b/collects/tests/mzscheme/all.ss @@ -0,0 +1,40 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(load-relative "basic.ss") +(load-relative "read.ss") +(unless (defined? 'building-flat-tests) + (load-relative "macro.ss")) +(load-relative "syntax.ss") +(load-relative "number.ss") +(load-relative "object.ss") +(load-relative "struct.ss") +(load-relative "unit.ss") +(load-relative "unitsig.ss") +(load-relative "thread.ss") +(load-relative "contmark.ss") +(load-relative "will.ss") +(load-relative "namespac.ss") +(unless (or (defined? 'building-flat-tests) + (defined? 'read/zodiac) + (defined? 'in-drscheme?)) + (load-relative "param.ss")) +(load-relative "file.ss") +(load-relative "path.ss") +(unless (defined? 'building-flat-tests) + (load-relative "hashper.ss")) +(unless (or (defined? 'building-flat-tests) + (defined? 'read/zodiac) + (defined? 'in-drscheme?)) + (load-relative "optimize.ss")) +(unless (defined? 'building-flat-tests) + (load-relative "name.ss")) +(unless (defined? 'building-flat-tests) + (load-relative "multi-expand.ss")) + +;; Ok, so this isn't really all of them. Here are more: +; thrport.ss +; deep.ss + +; See also README diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss new file mode 100644 index 00000000..7018a2ed --- /dev/null +++ b/collects/tests/mzscheme/basic.ss @@ -0,0 +1,1494 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(test '() 'null null) +(test '() 'null ()) + +(let ([f (lambda () #&7)]) + (test #t eq? (f) (f))) + +(SECTION 2 1);; test that all symbol characters are supported. +'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) + +(SECTION 3 4) +(define disjoint-type-functions + (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) +(define type-examples + (list + #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) +(define i 1) +(for-each (lambda (x) (display (make-string i #\ )) + (set! i (+ 3 i)) + (write x) + (newline)) + disjoint-type-functions) +(define type-matrix + (map (lambda (x) + (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) + (write t) + (write x) + (newline) + t)) + type-examples)) + +(SECTION 6 1) +(test #f not #t) +(test #f not 3) +(test #f not (list 3)) +(test #t not #f) +(test #f not '()) +(test #f not (list)) +(test #f not 'nil) +(arity-test not 1 1) + +(test #t boolean? #f) +(test #t boolean? #t) +(test #f boolean? 0) +(test #f boolean? '()) +(arity-test boolean? 1 1) + +(SECTION 6 2) +(test #t eqv? 'a 'a) +(test #f eqv? 'a 'b) +(test #t eqv? 2 2) +(test #f eqv? 2 2.0) +(test #t eqv? '() '()) +(test #t eqv? '10000 '10000) +(test #t eqv? 10000000000000000000 10000000000000000000) +(test #f eqv? 10000000000000000000 10000000000000000001) +(test #f eqv? 10000000000000000000 20000000000000000000) +(test #f eqv? (cons 1 2) (cons 1 2)) +(test #f eqv? (lambda () 1) (lambda () 2)) +(test #f eqv? #f 'nil) +(let ((p (lambda (x) x))) + (test #t eqv? p p)) +(define gen-counter + (lambda () + (let ((n 0)) + (lambda () (set! n (+ n 1)) n)))) +(let ((g (gen-counter))) (test #t eqv? g g)) +(test #f eqv? (gen-counter) (gen-counter)) +(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) + (g (lambda () (if (eqv? f g) 'g 'both)))) + (test #f eqv? f g)) + +(test #t eq? 'a 'a) +(test #f eq? (list 'a) (list 'a)) +(test #t eq? '() '()) +(test #t eq? car car) +(let ((x '(a))) (test #t eq? x x)) +(let ((x '#())) (test #t eq? x x)) +(let ((x (lambda (x) x))) (test #t eq? x x)) + +(test #t equal? 'a 'a) +(test #t equal? '("a") '("a")) +(test #t equal? '(a) '(a)) +(test #t equal? '(a (b) c) '(a (b) c)) +(test #t equal? '("a" ("b") "c") '("a" ("b") "c")) +(test #t equal? "abc" "abc") +(test #t equal? 2 2) +(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) +(test #t equal? (box "a") (box "a")) +(test #f equal? "" (string #\null)) + +(test #f equal? 'a "a") +(test #f equal? 'a 'b) +(test #f equal? '(a) '(b)) +(test #f equal? '(a (b) d) '(a (b) c)) +(test #f equal? '(a (b) c) '(d (b) c)) +(test #f equal? '(a (b) c) '(a (d) c)) +(test #f equal? "abc" "abcd") +(test #f equal? "abcd" "abc") +(test #f equal? 2 3) +(test #f equal? 2.0 2) +(test #f equal? (make-vector 5 'b) (make-vector 5 'a)) +(test #f equal? (box "a") (box "b")) + +(arity-test eq? 2 2) +(arity-test eqv? 2 2) +(arity-test equal? 2 2) + +(SECTION 6 3) +(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) +(define x (list 'a 'b 'c)) +(define y x) +(and list? (test #t list? y)) +(set-cdr! x 4) +(test '(a . 4) 'set-cdr! x) +(test #t eqv? x y) +(test '(a b c . d) 'dot '(a . (b . (c . d)))) +(test #f list? y) +(let ((x (list 'a))) (set-cdr! x x) (test #f list? x)) +(arity-test list? 1 1) + +(test #t pair? '(a . b)) +(test #t pair? '(a . 1)) +(test #t pair? '(a b c)) +(test #f pair? '()) +(test #f pair? '#(a b)) +(arity-test pair? 1 1) + +(test '(a) cons 'a '()) +(test '((a) b c d) cons '(a) '(b c d)) +(test '("a" b c) cons "a" '(b c)) +(test '(a . 3) cons 'a 3) +(test '((a b) . c) cons '(a b) 'c) +(arity-test cons 2 2) + +(test 'a car '(a b c)) +(test '(a) car '((a) b c d)) +(test 1 car '(1 . 2)) +(arity-test car 1 1) +(error-test '(car 1)) + +(test '(b c d) cdr '((a) b c d)) +(test 2 cdr '(1 . 2)) +(arity-test cdr 1 1) +(error-test '(cdr 1)) + +(test '(a 7 c) list 'a (+ 3 4) 'c) +(test '() list) + +(test 3 length '(a b c)) +(test 3 length '(a (b) (c d e))) +(test 0 length '()) +(arity-test length 1 1) +(error-test '(length 1)) +(error-test '(length '(1 . 2))) +(error-test '(length "a")) +; (error-test '(length (quote #0=(1 . #0#)))) +(error-test '(let ([p (cons 1 1)]) (set-cdr! p p) (length p))) +(define x (cons 4 0)) +(set-cdr! x x) +(error-test '(length x)) + +(define l '(1 2 3)) +(set-cdr! l 5) +(test '(1 . 5) 'set-cdr! l) +(set-car! l 0) +(test '(0 . 5) 'set-car! l) +(arity-test set-car! 2 2) +(arity-test set-cdr! 2 2) +(error-test '(set-car! 4 4)) +(error-test '(set-cdr! 4 4)) + +(define (box-tests box unbox box? set-box! set-box!-name unbox-name) + (define b (box 5)) + (test 5 unbox b) + (when set-box! + (set-box! b 6) + (test 6 unbox b)) + (test #t box? b) + (test #f box? 5) + (arity-test box 1 1) + (arity-test unbox 1 1) + (arity-test box? 1 1) + (when set-box! + (arity-test set-box! 2 2)) + (error-test `(,unbox-name 8)) + (when set-box! + (error-test `(,set-box!-name 8 8)))) +(box-tests box unbox box? set-box! 'set-box! 'unbox) +(box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value) + +(test '(x y) append '(x) '(y)) +(test '(a b c d) append '(a) '(b c d)) +(test '(a (b) (c)) append '(a (b)) '((c))) +(test '() append) +(test '(a b c . d) append '(a b) '(c . d)) +(test 'a append '() 'a) +(test 1 append 1) +(test '(1 . 2) append '(1) 2) +(test '(1 . 2) append '(1) 2) +(error-test '(append '(1 2 . 3) 1)) +(error-test '(append '(1 2 3) 1 '(4 5 6))) +(test '(x y) append! '(x) '(y)) +(test '(a b c d) append! '(a) '(b c d)) +(test '(a (b) (c)) append! '(a (b)) '((c))) +(test '() append!) +(test '(a b c . d) append! '(a b) '(c . d)) +(test 'a append! '() 'a) +(test 1 append! 1) +(error-test '(append! '(1 2 . 3) 1)) +(error-test '(append! '(1 2 3) 1 '(4 5 6))) + +(define l '(1 2)) +(define l2 '(3 4 . 7)) +(define l3 (append l l2)) +(test '(1 2 3 4 . 7) 'append l3) +(set-car! l2 5) +(test '(1 2 5 4 . 7) 'append l3) +(set-car! l3 0) +(test '(0 2 5 4 . 7) 'append l3) +(test '(1 2) 'append l) + +(let* ([l '(1 2)] + [l2 '(3 4 . 7)] + [l3 (append! l l2)]) + (test '(1 2 3 4 . 7) 'append! l3) + (set-car! l2 5) + (test '(1 2 5 4 . 7) 'append! l3) + (set-car! l3 0) + (test '(0 2 5 4 . 7) 'append! l3) + (test '(0 2 5 4 . 7) 'append! l)) + +(test '(c b a) reverse '(a b c)) +(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) +(arity-test reverse 1 1) +(error-test '(reverse 1)) +(error-test '(reverse '(1 . 1))) + +(define l '(a b c)) +(test '(c b a) reverse! l) +(test '(a) 'reverse! l) +(test '((e (f)) d (b c) a) reverse! '(a (b c) d (e (f)))) +(arity-test reverse! 1 1) +(error-test '(reverse! 1)) +(error-test '(reverse! '(1 . 1))) + +(test 'c list-ref '(a b c d) 2) +(test 'c list-ref '(a b c . d) 2) +(arity-test list-ref 2 2) +(error-test '(list-ref 1 1) exn:application:mismatch?) +(error-test '(list-ref '(a b . c) 2) exn:application:mismatch?) +(error-test '(list-ref '(1 2 3) 2.0)) +(error-test '(list-ref '(1) '(1))) +(error-test '(list-ref '(1) 1) exn:application:mismatch?) +(error-test '(list-ref '() 0) exn:application:mismatch?) +(error-test '(list-ref '() 0) exn:application:mismatch?) +(error-test '(list-ref '(1) -1)) + +(test '(c d) list-tail '(a b c d) 2) +(test '(a b c d) list-tail '(a b c d) 0) +(test '(b c . d) list-tail '(a b c . d) 1) +(test 1 list-tail 1 0) +(arity-test list-tail 2 2) +(error-test '(list-tail 1 1) exn:application:mismatch?) +(error-test '(list-tail '(1 2 3) 2.0)) +(error-test '(list-tail '(1) '(1))) +(error-test '(list-tail '(1) -1)) +(error-test '(list-tail '(1) 2) exn:application:mismatch?) +(error-test '(list-tail '(1 2 . 3) 3) exn:application:mismatch?) + +(define (test-mem memq memq-name) + (test '(a b c) memq 'a '(a b c)) + (test '(b c) memq 'b '(a b c)) + (test '(b . c) memq 'b '(a b . c)) + (test '#f memq 'a '(b c d)) + + (arity-test memq 2 2) + (error-test `(,memq-name 'a 1) exn:application:mismatch?) + (error-test `(,memq-name 'a '(1 . 2)) exn:application:mismatch?)) + +(test-mem memq 'memq) +(test-mem memv 'memv) +(test-mem member 'member) + +(test #f memq "apple" '("apple")) +(test #f memv "apple" '("apple")) +(test '("apple") member "apple" '("apple")) + +; (test #f memq 1/2 '(1/2)) ; rationals are immutable and we may want to optimize +(test '(1/2) memv 1/2 '(1/2)) +(test '(1/2) member 1/2 '(1/2)) + +(test '((1 2)) member '(1 2) '(1 2 (1 2))) + +(define (test-ass assq assq-name) + (define e '((a 1) (b 2) (c 3))) + (test '(a 1) assq 'a e) + (test '(b 2) assq 'b e) + (test #f assq 'd e) + (test '(a 1) assq 'a '((x 0) (a 1) b 2)) + (test '(a 1) assq 'a '((x 0) (a 1) . 0)) + (arity-test assq 2 2) + + (error-test `(,assq-name 1 1) exn:application:mismatch?) + (error-test `(,assq-name 1 '(1 2)) exn:application:mismatch?) + (error-test `(,assq-name 1 '((0) . 2)) exn:application:mismatch?)) + +(test-ass assq 'assq) +(test-ass assv 'assv) +(test-ass assoc 'assoc) + +(test #f assq '(a) '(((a)) ((b)) ((c)))) +(test #f assv '(a) '(((a)) ((b)) ((c)))) +(test '((b) 1) assoc '(b) '(((a)) ((b) 1) ((c)))) + +; (test #f assq '1/2 '(((a)) (1/2) ((c)))) ; rationals are immutable and we may want to optimize +(test '(1/2) assv '1/2 '(((a)) (1/2) ((c)))) +(test '(1/2) assoc '1/2 '(((a)) (1/2) ((c)))) + +(SECTION 6 4) +(test #t symbol? 'foo) +(test #t symbol? (car '(a b))) +(test #f symbol? "bar") +(test #t symbol? 'nil) +(test #f symbol? '()) +(test #f symbol? #f) +;;; But first, what case are symbols in? Determine the standard case: +(define char-standard-case char-upcase) +(if (string=? (symbol->string 'A) "a") + (set! char-standard-case char-downcase)) +(test #t 'standard-case + (string=? (symbol->string 'a) (symbol->string 'A))) +(test #t 'standard-case + (or (string=? (symbol->string 'a) "A") + (string=? (symbol->string 'A) "a"))) +(define (str-copy s) + (let ((v (make-string (string-length s)))) + (do ((i (- (string-length v) 1) (- i 1))) + ((< i 0) v) + (string-set! v i (string-ref s i))))) +(define (string-standard-case s) + (set! s (str-copy s)) + (do ((i 0 (+ 1 i)) + (sl (string-length s))) + ((>= i sl) s) + (string-set! s i (char-standard-case (string-ref s i))))) +(test (string-standard-case "flying-fish") symbol->string 'flying-fish) +(test (string-standard-case "martin") symbol->string 'Martin) +(test "Malvina" symbol->string (string->symbol "Malvina")) +(test #t 'standard-case (eq? 'a 'A)) + +(define x (string #\a #\b)) +(define y (string->symbol x)) +(string-set! x 0 #\c) +(test "cb" 'string-set! x) +(test "ab" symbol->string y) +(test y string->symbol "ab") + +(test #t eq? 'mISSISSIppi 'mississippi) +(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) +(test 'JollyWog string->symbol (symbol->string 'JollyWog)) + +(arity-test symbol? 1 1) + +(SECTION 6 6) +(test #t eqv? '#\ #\Space) +(test #t eqv? #\space '#\Space) +(test #t char? #\a) +(test #t char? #\() +(test #t char? #\ ) +(test #t char? '#\newline) +(arity-test char? 1 1) + +(test #t char=? #\A) +(test #f char=? #\A #\B) +(test #f char=? #\A #\A #\B) +(test #f char=? #\A #\B #\A) +(test #f char=? #\a #\b) +(test #f char=? #\9 #\0) +(test #t char=? #\A #\A) +(test #t char=? #\A #\A #\A) +(test #t char=? #\370 #\370) +(test #f char=? #\371 #\370) +(test #f char=? #\370 #\371) +(arity-test char=? 1 -1) +(error-test '(char=? #\a 1)) +(error-test '(char=? #\a #\b 1)) +(error-test '(char=? 1 #\a)) + +(test #t char? #\A) +(test #f char>? #\A #\B) +(test #t char>? #\B #\A) +(test #f char>? #\A #\B #\C) +(test #f char>? #\B #\A #\C) +(test #t char>? #\C #\B #\A) +(test #f char>? #\a #\b) +(test #t char>? #\9 #\0) +(test #f char>? #\A #\A) +(test #f char>? #\370 #\370) +(test #t char>? #\371 #\370) +(test #f char>? #\370 #\371) +(arity-test char>? 1 -1) +(error-test '(char>? #\a 1)) +(error-test '(char>? #\a #\a 1)) +(error-test '(char>? 1 #\a)) + +(test #t char<=? #\A) +(test #t char<=? #\A #\B) +(test #t char<=? #\A #\B #\C) +(test #t char<=? #\A #\A #\C) +(test #f char<=? #\A #\B #\A) +(test #f char<=? #\B #\A #\C) +(test #t char<=? #\a #\b) +(test #f char<=? #\9 #\0) +(test #t char<=? #\A #\A) +(test #t char<=? #\370 #\370) +(test #f char<=? #\371 #\370) +(test #t char<=? #\370 #\371) +(arity-test char<=? 1 -1) +(error-test '(char<=? #\a 1)) +(error-test '(char<=? #\b #\a 1)) +(error-test '(char<=? 1 #\a)) + +(test #t char>=? #\A) +(test #f char>=? #\A #\B) +(test #f char>=? #\a #\b) +(test #t char>=? #\9 #\0) +(test #t char>=? #\A #\A) +(test #t char>=? #\370 #\370) +(test #t char>=? #\371 #\370) +(test #f char>=? #\370 #\371) +(arity-test char>=? 1 -1) +(error-test '(char>=? #\a 1)) +(error-test '(char>=? #\a #\b 1)) +(error-test '(char>=? 1 #\a)) + +(test #t char-ci=? #\A) +(test #f char-ci=? #\A #\B) +(test #f char-ci=? #\A #\A #\B) +(test #f char-ci=? #\a #\B) +(test #f char-ci=? #\A #\b) +(test #f char-ci=? #\a #\b) +(test #f char-ci=? #\9 #\0) +(test #t char-ci=? #\A #\A) +(test #t char-ci=? #\A #\a) +(test #t char-ci=? #\A #\a #\A) +(test #t char-ci=? #\370 #\370) +(test #f char-ci=? #\371 #\370) +(test #f char-ci=? #\370 #\371) +(arity-test char-ci=? 1 -1) +(error-test '(char-ci=? #\a 1)) +(error-test '(char-ci=? #\a #\b 1)) +(error-test '(char-ci=? 1 #\a)) + +(test #t char-ci? #\A) +(test #f char-ci>? #\A #\B) +(test #f char-ci>? #\B #\A #\C) +(test #t char-ci>? #\C #\B #\A) +(test #f char-ci>? #\a #\B) +(test #f char-ci>? #\A #\b) +(test #f char-ci>? #\a #\b) +(test #t char-ci>? #\C #\b #\A) +(test #t char-ci>? #\9 #\0) +(test #f char-ci>? #\A #\A) +(test #f char-ci>? #\A #\a) +(test #f char-ci>? #\370 #\370) +(test #t char-ci>? #\371 #\370) +(test #f char-ci>? #\370 #\371) +(arity-test char-ci>? 1 -1) +(error-test '(char-ci>? #\a 1)) +(error-test '(char-ci>? #\a #\b 1)) +(error-test '(char-ci>? 1 #\a)) + +(test #t char-ci<=? #\A) +(test #t char-ci<=? #\A #\B) +(test #t char-ci<=? #\a #\B) +(test #t char-ci<=? #\a #\B #\C) +(test #f char-ci<=? #\a #\b #\A) +(test #t char-ci<=? #\A #\b) +(test #t char-ci<=? #\a #\b) +(test #f char-ci<=? #\9 #\0) +(test #t char-ci<=? #\A #\A) +(test #t char-ci<=? #\A #\a) +(test #t char-ci<=? #\370 #\370) +(test #f char-ci<=? #\371 #\370) +(test #t char-ci<=? #\370 #\371) +(arity-test char-ci<=? 1 -1) +(error-test '(char-ci<=? #\a 1)) +(error-test '(char-ci<=? #\b #\a 1)) +(error-test '(char-ci<=? 1 #\a)) + +(test #t char-ci>=? #\A) +(test #f char-ci>=? #\A #\B) +(test #f char-ci>=? #\B #\A #\C) +(test #t char-ci>=? #\B #\B #\A) +(test #f char-ci>=? #\a #\B) +(test #f char-ci>=? #\A #\b) +(test #f char-ci>=? #\a #\b) +(test #t char-ci>=? #\9 #\0) +(test #t char-ci>=? #\A #\A) +(test #t char-ci>=? #\A #\a) +(test #t char-ci>=? #\370 #\370) +(test #t char-ci>=? #\371 #\370) +(test #f char-ci>=? #\370 #\371) +(arity-test char-ci>=? 1 -1) +(error-test '(char-ci>=? #\a 1)) +(error-test '(char-ci>=? #\a #\b 1)) +(error-test '(char-ci>=? 1 #\a)) + +(define (ascii-range start end) + (let ([s (or (and (number? start) start) (char->integer start))] + [e (or (and (number? end) end) (char->integer end))]) + (let loop ([n e][l (list (integer->char e))]) + (if (= n s) + l + (let ([n (sub1 n)]) + (loop n (cons (integer->char n) l))))))) + +(define basic-uppers (ascii-range #\A #\Z)) +(define uppers basic-uppers) +(define basic-lowers (ascii-range #\a #\z)) +(define lowers basic-lowers) +(when (eq? (system-type) 'macos) + ; There are more alphabetics: + (set! uppers (append uppers + (ascii-range 128 134) + (ascii-range 174 175) + (ascii-range 203 206) + (ascii-range 217 217) + (ascii-range 229 239) + (ascii-range 241 244))) + (set! lowers (append lowers + (ascii-range 135 159) + (ascii-range 190 191) + (ascii-range 207 207) + (ascii-range 216 216)))) +(define alphas (append uppers lowers)) +(define digits (ascii-range #\0 #\9)) +(define whites (list #\newline #\return #\space #\page #\tab #\vtab)) + +(define (test-all is-a? name members) + (let loop ([n 0]) + (unless (= n 256) + (let ([c (integer->char n)]) + (test (and (memq c members) #t) `(,is-a? (integer->char ,n)) (is-a? c)) + (loop (add1 n))))) + (arity-test char-alphabetic? 1 1) + (error-test `(,name 1))) + +(test-all char-alphabetic? 'char-alphabetic? alphas) +(test-all char-numeric? 'char-numeric? digits) +(test-all char-whitespace? 'char-whitespace? whites) +(test-all char-upper-case? 'char-upper-case? uppers) +(test-all char-lower-case? 'char-lower-case? lowers) + +(let loop ([n 0]) + (unless (= n 256) + (test n 'integer->char (char->integer (integer->char n))) + (loop (add1 n)))) + +(test 0 char->integer #\nul) +(test 10 char->integer #\newline) +(test 13 char->integer #\return) +(test 9 char->integer #\tab) +(test 8 char->integer #\backspace) +(test 12 char->integer #\page) +(test 32 char->integer #\space) +(test 127 char->integer #\rubout) +(test #\null 'null #\nul) +(test #\newline 'linefeed #\linefeed) + +(test #\. integer->char (char->integer #\.)) +(test #\A integer->char (char->integer #\A)) +(test #\a integer->char (char->integer #\a)) +(test #\371 integer->char (char->integer #\371)) +(arity-test integer->char 1 1) +(arity-test char->integer 1 1) +(error-test '(integer->char 5.0)) +(error-test '(integer->char 'a)) +(error-test '(integer->char -1)) +(error-test '(integer->char 256)) +(error-test '(integer->char 10000000000000000)) +(error-test '(char->integer 5)) + +(define (test-up/down case case-name members amembers memassoc) + (let loop ([n 0]) + (unless (= n 256) + (let ([c (integer->char n)]) + (if (memq c members) + (if (memq c amembers) + (test (cdr (assq c memassoc)) case c) + (test (case c) case c)) ; BOGUS! Could tweak Mac testing here + (test n `(char->integer (,case-name (integer->char ,n))) (char->integer (case c))))) + (loop (add1 n)))) + (arity-test case 1 1) + (error-test `(,case-name 2))) + +(test-up/down char-upcase 'char-upcase lowers basic-lowers (map cons basic-lowers basic-uppers)) +(test-up/down char-downcase 'char-downcase uppers basic-uppers (map cons basic-uppers basic-lowers)) + +((load-relative "censor.ss") + (lambda () + (let loop ([n 0]) + (unless (= n 256) + (let ([c (integer->char n)]) + (if (or (char<=? #\a c #\z) + (char<=? #\A c #\Z) + (char<=? #\0 c #\9)) + (begin + (test c latin-1-integer->char n) + (test n char->latin-1-integer c)) + (when (latin-1-integer->char n) + (test n char->latin-1-integer (latin-1-integer->char n))))) + (loop (add1 n)))))) + +(arity-test latin-1-integer->char 1 1) +(arity-test char->latin-1-integer 1 1) +(error-test '(latin-1-integer->char 5.0)) +(error-test '(latin-1-integer->char 'a)) +(error-test '(latin-1-integer->char -1)) +(error-test '(latin-1-integer->char 256)) +(error-test '(latin-1-integer->char 10000000000000000)) +(error-test '(char->latin-1-integer 5)) + +(SECTION 6 7) +(test #t string? "The word \"recursion\\\" has many meanings.") +(test #t string? "") +(arity-test string? 1 1) +(test 3 'make-string (string-length (make-string 3))) +(test "" make-string 0) +(arity-test make-string 1 2) +(error-test '(make-string "hello")) +(error-test '(make-string 5 "hello")) +(error-test '(make-string 5.0 #\b)) +(error-test '(make-string 5.2 #\a)) +(error-test '(make-string -5 #\f)) +(error-test '(make-string 500000000000000 #\f) exn:misc:out-of-memory?) + +(define f (make-string 3 #\*)) +(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) +(arity-test string-set! 3 3) +(error-test '(string-set! "hello" 0 #\a)) ; immutable string constant +(define hello-string (string-copy "hello")) +(error-test '(string-set! hello-string 'a #\a)) +(error-test '(string-set! 'hello 4 #\a)) +(error-test '(string-set! hello-string 4 'a)) +(error-test '(string-set! hello-string 4.0 'a)) +(error-test '(string-set! hello-string 5 #\a) exn:application:mismatch?) +(error-test '(string-set! hello-string -1 #\a)) +(error-test '(string-set! hello-string (expt 2 100) #\a) exn:application:mismatch?) +(test "abc" string #\a #\b #\c) +(test "" string) +(error-test '(string #\a 1)) +(error-test '(string 1 #\a)) +(error-test '(string 1)) +(test 3 string-length "abc") +(test 0 string-length "") +(arity-test string-length 1 1) +(error-test '(string-length 'apple)) +(test #\a string-ref "abc" 0) +(test #\c string-ref "abc" 2) +(arity-test string-ref 2 2) +(error-test '(string-ref 'apple 4)) +(error-test '(string-ref "apple" 4.0)) +(error-test '(string-ref "apple" '(4))) +(error-test '(string-ref "apple" 5) exn:application:mismatch?) +(error-test '(string-ref "" 0) exn:application:mismatch?) +(error-test '(string-ref "" (expt 2 100)) exn:application:mismatch?) +(error-test '(string-ref "apple" -1)) +(test "" substring "ab" 0 0) +(test "" substring "ab" 1 1) +(test "" substring "ab" 2 2) +(test "a" substring "ab" 0 1) +(test "b" substring "ab" 1 2) +(test "ab" substring "ab" 0 2) +(test (string #\a #\nul #\b) substring (string #\- #\a #\nul #\b #\*) 1 4) +(arity-test substring 3 3) +(error-test '(substring 'hello 2 3)) +(error-test '(substring "hello" "2" 3)) +(error-test '(substring "hello" 2.0 3)) +(error-test '(substring "hello" 2 3.0)) +(error-test '(substring "hello" 2 "3")) +(error-test '(substring "hello" 2 7) exn:application:mismatch?) +(error-test '(substring "hello" -2 3)) +(error-test '(substring "hello" 4 3) exn:application:mismatch?) +(error-test '(substring "hello" (expt 2 100) 3) exn:application:mismatch?) +(error-test '(substring "hello" (expt 2 100) 5) exn:application:mismatch?) +(error-test '(substring "hello" 3 (expt 2 100)) exn:application:mismatch?) +(test "foobar" string-append "foo" "bar") +(test "foo" string-append "foo") +(test "foo" string-append "foo" "") +(test "foogoo" string-append "foo" "" "goo") +(test "foo" string-append "" "foo") +(test "" string-append) +(test (string #\a #\nul #\b #\c #\nul #\d) + string-append (string #\a #\nul #\b) (string #\c #\nul #\d)) +(error-test '(string-append 1)) +(error-test '(string-append "hello" 1)) +(error-test '(string-append "hello" 1 "done")) +(test "" make-string 0) +(define s (string-copy "hello")) +(define s2 (string-copy s)) +(test "hello" 'string-copy s2) +(string-set! s 2 #\x) +(test "hello" 'string-copy s2) +(test (string #\a #\nul #\b) string-copy (string #\a #\nul #\b)) +(string-fill! s #\x) +(test "xxxxx" 'string-fill! s) +(arity-test string-copy 1 1) +(arity-test string-fill! 2 2) +(error-test '(string-copy 'blah)) +(error-test '(string-fill! "oops" 5)) + +(define ax (string #\a #\nul #\370 #\x)) +(define abigx (string #\a #\nul #\370 #\X)) +(define ax2 (string #\a #\nul #\370 #\x)) +(define ay (string #\a #\nul #\371 #\x)) + +(test #t string=? "string") +(test #t string? "string") +(test #t string<=? "string") +(test #t string>=? "string") +(test #t string-ci=? "string") +(test #t string-ci? "string") +(test #t string-ci<=? "string") +(test #t string-ci>=? "string") + +(test #t string=? "" "") +(test #f string? "" "") +(test #t string<=? "" "") +(test #t string>=? "" "") +(test #t string-ci=? "" "") +(test #f string-ci? "" "") +(test #t string-ci<=? "" "") +(test #t string-ci>=? "" "") + +(test #f string=? "A" "B") +(test #f string=? "a" "b") +(test #f string=? "9" "0") +(test #t string=? "A" "A") +(test #f string=? "A" "AB") +(test #t string=? ax ax2) +(test #f string=? ax abigx) +(test #f string=? ax ay) +(test #f string=? ay ax) + +(test #t string? "A" "B") +(test #f string>? "a" "b") +(test #t string>? "9" "0") +(test #f string>? "A" "A") +(test #f string>? "A" "AB") +(test #t string>? "AB" "A") +(test #f string>? ax ax2) +(test #f string>? ax ay) +(test #t string>? ay ax) + +(test #t string<=? "A" "B") +(test #t string<=? "a" "b") +(test #f string<=? "9" "0") +(test #t string<=? "A" "A") +(test #t string<=? "A" "AB") +(test #f string<=? "AB" "A") +(test #t string<=? ax ax2) +(test #t string<=? ax ay) +(test #f string<=? ay ax) + +(test #f string>=? "A" "B") +(test #f string>=? "a" "b") +(test #t string>=? "9" "0") +(test #t string>=? "A" "A") +(test #f string>=? "A" "AB") +(test #t string>=? "AB" "A") +(test #t string>=? ax ax2) +(test #f string>=? ax ay) +(test #t string>=? ay ax) + +(test #f string-ci=? "A" "B") +(test #f string-ci=? "a" "B") +(test #f string-ci=? "A" "b") +(test #f string-ci=? "a" "b") +(test #f string-ci=? "9" "0") +(test #t string-ci=? "A" "A") +(test #t string-ci=? "A" "a") +(test #f string-ci=? "A" "AB") +(test #t string-ci=? ax ax2) +(test #t string-ci=? ax abigx) +(test #f string-ci=? ax ay) +(test #f string-ci=? ay ax) +(test #f string-ci=? abigx ay) +(test #f string-ci=? ay abigx) + +(test #t string-ci? "A" "B") +(test #f string-ci>? "a" "B") +(test #f string-ci>? "A" "b") +(test #f string-ci>? "a" "b") +(test #t string-ci>? "9" "0") +(test #f string-ci>? "A" "A") +(test #f string-ci>? "A" "a") +(test #f string-ci>? "A" "AB") +(test #t string-ci>? "AB" "A") +(test #f string-ci>? ax ax2) +(test #f string-ci>? ax abigx) +(test #f string-ci>? ax ay) +(test #t string-ci>? ay ax) +(test #f string-ci>? abigx ay) +(test #t string-ci>? ay abigx) + +(test #t string-ci<=? "A" "B") +(test #t string-ci<=? "a" "B") +(test #t string-ci<=? "A" "b") +(test #t string-ci<=? "a" "b") +(test #f string-ci<=? "9" "0") +(test #t string-ci<=? "A" "A") +(test #t string-ci<=? "A" "a") +(test #t string-ci<=? "A" "AB") +(test #f string-ci<=? "AB" "A") +(test #t string-ci<=? ax ax2) +(test #t string-ci<=? ax abigx) +(test #t string-ci<=? ax ay) +(test #f string-ci<=? ay ax) +(test #t string-ci<=? abigx ay) +(test #f string-ci<=? ay abigx) + +(test #f string-ci>=? "A" "B") +(test #f string-ci>=? "a" "B") +(test #f string-ci>=? "A" "b") +(test #f string-ci>=? "a" "b") +(test #t string-ci>=? "9" "0") +(test #t string-ci>=? "A" "A") +(test #t string-ci>=? "A" "a") +(test #f string-ci>=? "A" "AB") +(test #t string-ci>=? "AB" "A") +(test #t string-ci>=? ax ax2) +(test #t string-ci>=? ax abigx) +(test #f string-ci>=? ax ay) +(test #t string-ci>=? ay ax) +(test #f string-ci>=? abigx ay) +(test #t string-ci>=? ay abigx) + +(map (lambda (pred) + (arity-test pred 1 -1) + (let ([predname (string->symbol + (primitive-name pred))]) + (error-test `(,predname "a" 1)) + (error-test `(,predname "a" "b" 5)) + (error-test `(,predname 1 "a")))) + (list string=? + string>? + string=? + string<=? + string-ci=? + string-ci>? + string-ci=? + string-ci<=?)) + +(define r (regexp "(-[0-9]*)+")) +(test '("-12--345" "-345") regexp-match r "a-12--345b") +(test '((1 . 9) (5 . 9)) regexp-match-positions r "a-12--345b") +(test '("--345" "-345") regexp-match r "a-12--345b" 2) +(test '("--34" "-34") regexp-match r "a-12--345b" 2 8) +(test '((4 . 9) (5 . 9)) regexp-match-positions r "a-12--345b" 2) +(test '((4 . 8) (5 . 8)) regexp-match-positions r "a-12--345b" 2 8) +(test '("a-b") regexp-match "a[-c]b" "a-b") +(test '("a-b") regexp-match "a[c-]b" "a-b") +(test #f regexp-match "x+" "12345") +(test "su casa" regexp-replace "mi" "mi casa" "su") +(define r2 (regexp "([Mm])i ([a-zA-Z]*)")) +(define insert "\\1y \\2") +(test "My Casa" regexp-replace r2 "Mi Casa" insert) +(test "my cerveza Mi Mi Mi" regexp-replace r2 "mi cerveza Mi Mi Mi" insert) +(test "my cerveza My Mi Mi" regexp-replace* r2 "mi cerveza Mi Mi Mi" insert) +(test "bbb" regexp-replace* "a" "aaa" "b") + +;; Test regexp with null chars: +(let* ([s (string #\a #\b #\nul #\c)] + [3s (string-append s s s)]) + (test #f regexp-match (string #\nul) "no nulls") + (test (list s) regexp-match s s) + (test (list 3s s) regexp-match (format "(~a)*" s) 3s) + (test (list (string #\b #\nul #\c)) regexp-match (string #\[ #\nul #\b #\] #\* #\c) s) + (test (list (string #\a #\b #\nul)) regexp-match (string #\a #\[ #\b #\nul #\] #\+) s) + (test "hihihi" regexp-replace* (string #\nul) (string #\nul #\nul #\nul) "hi")) +(test (string #\- #\nul #\+ #\- #\nul #\+ #\- #\nul #\+) + regexp-replace* "a" "aaa" (string #\- #\nul #\+)) + +;; Check extremely many subexpressions: +(for-each + (lambda (mx) + (let* ([v (make-vector mx null)] + [open (make-vector mx #t)]) + (let loop ([n 0][m 0][s null]) + (cond + [(and (= n mx) (zero? m)) + (let* ([s (list->string (reverse! s))] + [plain (regexp-replace* "[()]" s "")]) + (test (cons plain (map list->string (map reverse! (vector->list v)))) regexp-match s plain))] + [(or (= n mx) (< (random 10) 3)) + (if (and (positive? m) + (< (random 10) 7)) + (begin + (let loop ([p 0][m (sub1 m)]) + (if (vector-ref open p) + (if (zero? m) + (vector-set! open p #f) + (loop (add1 p) (sub1 m))) + (loop (add1 p) m))) + (loop n (sub1 m) (cons #\) s))) + + (let ([c (integer->char (+ (char->integer #\a) (random 26)))]) + (let loop ([p 0]) + (unless (= p n) + (when (vector-ref open p) + (vector-set! v p (cons c (vector-ref v p)))) + (loop (add1 p)))) + (loop n m (cons c s))))] + [else + (loop (add1 n) (add1 m) (cons #\( s))])))) + '(1 10 100 500)) + + +(define (test-bad-re-args who) + (error-test `(,who 'e "hello")) + (error-test `(,who "e" 'hello)) + (error-test `(,who "e" "hello" -1 5)) + (error-test `(,who "e" "hello" 1 +inf.0)) + (error-test `(,who "e" "" 0 1) exn:application:mismatch?) + (error-test `(,who "e" "hello" 3 2) exn:application:mismatch?) + (error-test `(,who "e" "hello" 3 12) exn:application:mismatch?) + (error-test `(,who "e" "hello" (expt 2 100) 5) exn:application:mismatch?)) +(test-bad-re-args 'regexp-match) +(test-bad-re-args 'regexp-match-positions) + +(arity-test regexp 1 1) +(arity-test regexp? 1 1) +(arity-test regexp-match 2 4) +(arity-test regexp-match-positions 2 4) +(arity-test regexp-replace 3 3) +(arity-test regexp-replace* 3 3) + +(SECTION 6 8) +(test #t vector? '#(0 (2 2 2 2) "Anna")) +(test #t vector? '#()) +(arity-test vector? 1 1) +(test '#(a b c) vector 'a 'b 'c) +(test '#() vector) +(test 3 vector-length '#(0 (2 2 2 2) "Anna")) +(test 0 vector-length '#()) +(arity-test vector-length 1 1) +(error-test '(vector-length "apple")) +(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) +(arity-test vector-ref 2 2) +(error-test '(vector-ref "apple" 3)) +(error-test '(vector-ref #(4 5 6) 3) exn:application:mismatch?) +(error-test '(vector-ref #() 0) exn:application:mismatch?) +(error-test '(vector-ref #() (expt 2 100)) exn:application:mismatch?) +(error-test '(vector-ref #(4 5 6) -1)) +(error-test '(vector-ref #(4 5 6) 2.0)) +(error-test '(vector-ref #(4 5 6) "2")) +(test '#(0 ("Sue" "Sue") "Anna") 'vector-set + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) +(test '#(hi hi) make-vector 2 'hi) +(test '#() make-vector 0) +(test '#() make-vector 0 'a) +(arity-test make-vector 1 2) +(error-test '(make-vector "a" 'a)) +(error-test '(make-vector 1.0 'a)) +(error-test '(make-vector 10.2 'a)) +(error-test '(make-vector -1 'a)) +(error-test '(make-vector 1000000000000000000000 'a) exn:misc:out-of-memory?) +(arity-test vector-set! 3 3) +(error-test '(vector-set! #() 0 'x) exn:application:mismatch?) +(error-test '(vector-set! #(1 2 3) -1 'x)) +(error-test '(vector-set! #(1 2 3) 3 'x) exn:application:mismatch?) +(error-test '(vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?) +(error-test '(vector-set! '(1 2 3) 2 'x)) +(error-test '(vector-set! #(1 2 3) "2" 'x)) +(define v (quote #(1 2 3))) +(vector-fill! v 0) +(test (quote #(0 0 0)) 'vector-fill! v) +(arity-test vector-fill! 2 2) +(error-test '(vector-fill! '(1 2 3) 0)) + +(SECTION 6 9) +(test #t procedure? car) +(test #f procedure? 'car) +(test #t procedure? (lambda (x) (* x x))) +(test #f procedure? '(lambda (x) (* x x))) +(test #t call-with-current-continuation procedure?) +(test #t call-with-escape-continuation procedure?) +(test #t procedure? (case-lambda ((x) x) ((x y) (+ x y)))) +(arity-test procedure? 1 1) + +(test 7 apply + (list 3 4)) +(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) +(test 17 apply + 10 (list 3 4)) +(test '() apply list '()) +(define compose (lambda (f g) (lambda args (f (apply g args))))) +(test 30 (compose sqrt *) 12 75) +(error-test '(apply) exn:application:arity?) +(error-test '(apply (lambda x x)) exn:application:arity?) +(error-test '(apply (lambda x x) 1)) +(error-test '(apply (lambda x x) 1 2)) +(error-test '(apply (lambda x x) 1 '(2 . 3))) + +(test '(b e h) map cadr '((a b) (d e) (g h))) +(test '(5 7 9) map + '(1 2 3) '(4 5 6)) +(test '#(0 1 4 9 16) 'for-each + (let ((v (make-vector 5))) + (for-each (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(define (map-tests map) + (let ([size? exn:application:mismatch?] + [non-list? type?]) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '1)) + (error-test `(,map (lambda (x y) (+ x y)) '2 '(1 2))) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 3)) size?) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2)) size?) + (error-test `(,map (lambda (x) (+ x)) '(1 2 . 3)) non-list?) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2)) non-list?) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2 3)) non-list?) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 . 3)) non-list?) + (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2 . 3)) non-list?) + (error-test `(,map) exn:application:arity?) + (error-test `(,map (lambda (x y) (+ x y))) exn:application:arity?) + (error-test `(,map (lambda () 10) null) exn:application:mismatch?) + (error-test `(,map (case-lambda [() 9] [(x y) 10]) '(1 2 3)) exn:application:mismatch?) + (error-test `(,map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?))) +(map-tests 'map) +(map-tests 'for-each) +(map-tests 'andmap) +(map-tests 'ormap) + +(test (void) for-each (lambda (x) (values 1 2)) '(1 2)) +(error-test '(map (lambda (x) (values 1 2)) '(1 2)) arity?) + +(test #t andmap add1 null) +(test #f ormap add1 null) +(test #f andmap positive? '(1 -2 3)) +(test #t ormap positive? '(1 -2 3)) +(test #f andmap negative? '(1 -2 3)) +(test #t ormap negative? '(1 -2 3)) +(test 4 andmap add1 '(1 2 3)) +(test 2 ormap add1 '(1 2 3)) + +(error-test '(ormap (lambda (x) (values 1 2)) '(1 2)) arity?) +(error-test '(andmap (lambda (x) (values 1 2)) '(1 2)) arity?) + +(error-test '(ormap (lambda (x) (values 1 2)) '(1)) arity?) +(error-test '(andmap (lambda (x) (values 1 2)) '(1)) arity?) + +(test -3 call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x))) + '(54 0 37 -3 245 19)) + #t)) +(define list-length + (lambda (obj) + (call-with-current-continuation + (lambda (return) + (letrec ((r (lambda (obj) (cond ((null? obj) 0) + ((pair? obj) (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) +(test 4 list-length '(1 2 3 4)) +(test #f list-length '(a b . c)) +(test '() map cadr '()) + +;;; This tests full conformance of call-with-current-continuation. It +;;; is a separate test because some schemes do not support call/cc +;;; other than escape procedures. I am indebted to +;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this +;;; code. The function leaf-eq? compares the leaves of 2 arbitrary +;;; trees constructed of conses. +(define (next-leaf-generator obj eot) + (letrec ((return #f) + (cont (lambda (x) + (recurx obj) + (set! cont (lambda (x) (return eot))) + (cont #f))) + (recurx (lambda (obj) + (if (pair? obj) + (for-each recurx obj) + (call-with-current-continuation + (lambda (c) + (set! cont c) + (return obj))))))) + (lambda () (call-with-current-continuation + (lambda (ret) (set! return ret) (cont #f)))))) +(define (leaf-eq? x y) + (let* ((eot (list 'eot)) + (xf (next-leaf-generator x eot)) + (yf (next-leaf-generator y eot))) + (letrec ((loop (lambda (x y) + (cond ((not (eq? x y)) #f) + ((eq? eot x) #t) + (else (loop (xf) (yf))))))) + (loop (xf) (yf))))) +(define (test-cont) + (newline) + (display ";testing continuations; ") + (SECTION 6 9) + (test #t leaf-eq? '(a (b (c))) '((a) b c)) + (test #f leaf-eq? '(a (b (c))) '((a) b c d)) + '(report-errs)) + +(define (test-cc-values test-call/cc) + (test '(a b c) + call-with-values + (lambda () + (test-call/cc + (lambda (k) + (dynamic-wind + void + (lambda () + (k 'a 'b 'c)) + (lambda () + (values 1 2)))))) + list) + + (test 1 dynamic-wind + (lambda () (test-call/cc void)) + (lambda () 1) + (lambda () (test-call/cc void))) + + ; Try devious jumping with pre- and post-thunks: + (test 2 test-call/cc + (lambda (exit) + (dynamic-wind + (lambda () (exit 2)) + void + void))) + (test 3 test-call/cc + (lambda (exit) + (dynamic-wind + void + void + (lambda () (exit 3))))) + + (let ([rv + (lambda (get-v) + (let ([x 0]) + (test-call/cc + (lambda (exit) + (dynamic-wind + void + (lambda () (exit)) + (lambda () (set! x (get-v)))))) + x))] + [r56 + (lambda () + (let ([x 0] + [y 1] + [c1 #f]) + (dynamic-wind + (lambda () (set! x (add1 x))) + (lambda () + (let/cc k (set! c1 k)) + (if (>= x 5) + (set! c1 #f))) + (lambda () (set! y (add1 y)))) + (when c1 (c1)) + (list x y)))] + [rx.y + (lambda (get-x get-y) + (let ([c1 #f] + [x 0] + [y 0]) + (let ([v + (dynamic-wind + (lambda () (set! y x)) + (lambda () (let/cc k (set! c1 k))) + (lambda () + (set! x (get-x)) + (when c1 + ((begin0 + c1 + (set! c1 #f)) + (get-y)))))]) + (cons y v))))] + [rv2 + (lambda (get-v) + (let ([c1 #f] + [give-up #f]) + (test-call/cc + (lambda (exit) + (dynamic-wind + (lambda () (when give-up (give-up (get-v)))) + (lambda () (let/cc k (set! c1 k))) + (lambda () (set! give-up exit) (c1)))))))] + [r10-11-12 + (lambda () + (let ([c2 #f] + [x 10] + [y 11]) + (let ([v (dynamic-wind + (lambda () (set! y (add1 y))) + (lambda () (begin0 x (set! x (add1 x)))) + (lambda () (let/cc k (set! c2 k))))]) + (when c2 ((begin0 + c2 + (set! c2 #f)))) + (list v x y))))] + [r13.14 + (lambda () + (let ([c0 #f] + [x 11] + [y 12]) + (dynamic-wind + (lambda () (let/cc k (set! c0 k))) + (lambda () (set! x (add1 x))) + (lambda () (set! y (add1 y)) + (when c0 ((begin0 + c0 + (set! c0 #f)))))) + (cons x y)))] + [ra-b-a-b + (lambda (get-a get-b) + (let ([l null]) + (let ((k-in (test-call/cc (lambda (k1) + (dynamic-wind + (lambda () (set! l (append l (list (get-a))))) + (lambda () + (call/cc (lambda (k2) (k1 k2)))) + (lambda () (set! l (append l (list (get-b)))))))))) + (k-in (lambda (v) l)))))]) + + (test 4 rv (lambda () 4)) + (test '(5 6) r56) + + (test '(7 . 8) rx.y (lambda () 7) (lambda () 8)) + + (test 9 rv2 (lambda () 9)) + + (test '(10 11 12) r10-11-12) + + (test '(13 . 14) r13.14) + + ; !!! fixed in 50: + (test '(enter exit enter exit) + ra-b-a-b (lambda () 'enter) (lambda () 'exit)) + + (test '((13 . 14) (10 11 12) (13 . 14) (10 11 12)) + ra-b-a-b r13.14 r10-11-12) + (test '((10 11 12) (13 . 14) (10 11 12) (13 . 14)) + ra-b-a-b r10-11-12 r13.14) + + (test '((enter exit enter exit) + (exit enter exit enter) + (enter exit enter exit) + (exit enter exit enter)) + ra-b-a-b + (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))) + (lambda () (ra-b-a-b (lambda () 'exit) (lambda () 'enter)))) + + (test '(enter exit enter exit) + rv (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))) + (test '(enter exit enter exit) + rv2 (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))) + + (test '(10 11 12) rv r10-11-12) + (test '(10 11 12) rv2 r10-11-12) + + (test '(13 . 14) rv r13.14) + (test '(13 . 14) rv2 r13.14) + + (test 12 'dw/ec (test-call/cc + (lambda (k0) + (test-call/cc + (lambda (k1) + (test-call/cc + (lambda (k2) + (dynamic-wind + void + (lambda () (k1 6)) + (lambda () (k2 12)))))))))) + + ;; !!! fixed in 53 (for call/ec) + (test 13 'dw/ec (test-call/cc + (lambda (k0) + (test-call/cc + (lambda (k1) + (test-call/cc + (lambda (k2) + (dynamic-wind + void + (lambda () (k1 6)) + (lambda () (k2 12))))) + (k0 13)))))) + + )) + + +(test-cc-values call/cc) +(test-cc-values call/ec) + +(test 'ok + 'ec-cc-exn-combo + (with-handlers ([void (lambda (x) 'ok)]) + (define f + (let ([k #f]) + (lambda (n) + (case n + [(0) (let/ec r (r (set! k (let/cc k k))))] + [(1) (k)])))) + (f 0) + (f 1))) + +(test '(1 2 3 4 1 2 3 4) 'dyn-wind-pre/post-order + (let ([x null] + [go-back #f]) + (dynamic-wind + (lambda () (set! x (cons 4 x))) + (lambda () (dynamic-wind + (lambda () (set! x (cons 3 x))) + (lambda () (set! go-back (let/cc k k))) + (lambda () (set! x (cons 2 x))))) + (lambda () (set! x (cons 1 x)))) + (if (procedure? go-back) + (go-back 1) + x))) + +(test '(5 . 5) 'suspended-cont-escape + (let ([retry #f]) + (let ([v (let/ec exit + (dynamic-wind + void + (lambda () (exit 5)) + (lambda () + (let/ec inner-escape + (set! retry (let/cc k k)) + (inner-escape 12) + 10))))]) + (if (procedure? retry) + (retry 10) + (cons v v))))) + +(test '(here) 'escape-interrupt-full-jump-up + (let ([b #f] + [v null]) + (define (f g) + (dynamic-wind + void + g + (lambda () + (set! v (cons 'here v)) + (b 10)))) + + (let/ec big + (set! b big) + (let/cc ok + (f (lambda () + (ok #f))))) + + v)) + + +(arity-test call/cc 1 1) +(arity-test call/ec 1 1) +(error-test '(call/cc 4)) +(error-test '(call/cc (lambda () 0))) +(error-test '(call/ec 4)) +(error-test '(call/ec (lambda () 0))) + +(test #t primitive? car) +(test #f primitive? leaf-eq?) +(arity-test primitive? 1 1) + +(test 1 arity arity) +(test 2 arity cons) +(test (make-arity-at-least 1) arity >) +(test (list 0 1) arity current-output-port) +(test (list 1 3 (make-arity-at-least 5)) + arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2])) +(arity-test arity 1 1) + +(test #t procedure-arity-includes? cons 2) +(test #f procedure-arity-includes? cons 0) +(test #f procedure-arity-includes? cons 3) +(test #t procedure-arity-includes? list 3) +(test #t procedure-arity-includes? list 3000) +(test #t procedure-arity-includes? (lambda () 0) 0) +(test #f procedure-arity-includes? (lambda () 0) 1) +(test #f procedure-arity-includes? cons 10000000000000000000000000000) +(test #t procedure-arity-includes? list 10000000000000000000000000000) +(test #t procedure-arity-includes? (lambda x x) 10000000000000000000000000000) + +(error-test '(procedure-arity-includes? cons -1)) +(error-test '(procedure-arity-includes? cons 1.0)) +(error-test '(procedure-arity-includes? 'cons 1)) + +(arity-test procedure-arity-includes? 2 2) + +(newline) +(display ";testing scheme 4 functions; ") +(SECTION 6 7) +(test '(#\P #\space #\l) string->list "P l") +(test '() string->list "") +(test "1\\\"" list->string '(#\1 #\\ #\")) +(test "" list->string '()) +(arity-test list->string 1 1) +(arity-test string->list 1 1) +(error-test '(string->list 'hello)) +(error-test '(list->string 'hello)) +(error-test '(list->string '(#\h . #\e))) +(SECTION 6 8) +(test '(dah dah didah) vector->list '#(dah dah didah)) +(test '() vector->list '#()) +(test '#(dididit dah) list->vector '(dididit dah)) +(test '#() list->vector '()) +(arity-test list->vector 1 1) +(arity-test vector->list 1 1) +(error-test '(vector->list 'hello)) +(error-test '(list->vector 'hello)) +(error-test '(list->vector '(#\h . #\e))) + +(test-cont) + +(report-errs) + +"last item in file" diff --git a/collects/tests/mzscheme/censor.ss b/collects/tests/mzscheme/censor.ss new file mode 100644 index 00000000..52ef2628 --- /dev/null +++ b/collects/tests/mzscheme/censor.ss @@ -0,0 +1,30 @@ + +; run a thunk using a censor that removes dangerous chars from a +; string for printing to a terminal +(lambda (thunk) + (let ([censor (lambda (s) + (list->string + (let loop ([s (string->list s)]) + (if (null? s) + null + (let ([c (car s)]) + (cond + [(and (not (char-whitespace? c)) (or (char<=? c #\space) (char>=? c #\200))) + (append (cons #\{ (string->list + (number->string + (char->integer c)))) + (cons #\} (loop (cdr s))))] + [else + (cons c (loop (cdr s)))]))))))]) + (let* ([oldp (current-output-port)] + [cp (make-output-port + (lambda (s) + (display (censor s) oldp)) + void)]) + (dynamic-wind + (lambda () (current-output-port cp)) + thunk + (lambda () + (current-output-port oldp)))))) + + diff --git a/collects/tests/mzscheme/chkdoc.ss b/collects/tests/mzscheme/chkdoc.ss new file mode 100644 index 00000000..c4249aeb --- /dev/null +++ b/collects/tests/mzscheme/chkdoc.ss @@ -0,0 +1,28 @@ + +(require-library "mzlib.ss") + +(define actual-definitions + (filter (lambda (s) + (let ([s (symbol->string s)]) + (not (char=? (string-ref s 0) #\#)))) + (map car (make-global-value-list)))) + +(define doc-path (collection-path "doc")) + +(define r5rs-keywords (with-input-from-file (build-path doc-path "r5rs" "keywords") read)) +(define mzscheme-keywords (with-input-from-file (build-path doc-path "mzscheme" "keywords") read)) + +(define documented + (map string->symbol (map car (append r5rs-keywords mzscheme-keywords)))) + +(for-each + (lambda (doc) + (unless (memq doc actual-definitions) + (printf "Documented but doesn't exist: ~a~n" doc))) + documented) + +(for-each + (lambda (act) + (unless (memq act documented) + (printf "Undocumented: ~a~n" act))) + actual-definitions) diff --git a/collects/tests/mzscheme/classd.ss b/collects/tests/mzscheme/classd.ss new file mode 100644 index 00000000..7288413a --- /dev/null +++ b/collects/tests/mzscheme/classd.ss @@ -0,0 +1,147 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + + +(SECTION 'class/d) + +(require-library "classd.ss") + +(syntax-test '(class/d object% ((public x)) (define (x) 1))) +(syntax-test '(class/d object% () ((public x)))) +;; Should this be an error? +; (syntax-test '(class/d object% () ((public x x)) (define x 10))) + +(test + 1 + 'test-1 + (send (make-object (class/d object% () ((public y)) (define (y) 1) (super-init))) y)) + +(test + 1 + 'test-2 + (send (make-object (class/d object% () ((public y)) (define (y) 1) (define (z) 1) (super-init))) y)) + +(test + 3 + 'test-3 + (let ([x 1]) + (make-object + (class/d object% () () + (set! x 2) + (set! x 3) + (super-init))) + x)) + +(test + 2 + 'test-4 + (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) + () + ((override x)) + (super-init) + (define (x) 2))) + x)) + + +(test + 2 + 'test-5 + (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) + () + ((inherit x) + (public y)) + (super-init) + (define (y) (+ (x) (x))))) + y)) + +(test + 2 + 'test-6 + (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) + () + ((rename [super-x x]) + (public y)) + (super-init) + (define (y) (+ (super-x) (super-x))))) + y)) + +(test + 2 + 'test-7 + (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) + () + ((rename [super-x x]) + (override x)) + (super-init) + (define (x) (+ (super-x) (super-x))))) + x)) + +(test + 2 + 'test-8 + (send (make-object (class/d object% (xxx) + ((public x)) + (define (x) xxx) + (super-init)) + 2) + x)) + +(test + 1 + 'test-9 + (send (make-object (class/d*/names (local-this local-super-init) + object% + ((interface ())) + () + ((public x)) + (define (x) 1) + (local-super-init))) + x)) + +(test + 1 + 'test-10 + (send (make-object (class/d* object% + ((interface ())) + () + ((public x)) + (define (x) 1) + (super-init))) + x)) + +(test + 77 + 'test-10 + (ivar (make-object (class/d object% () + ((public x)) + (define y 77) + (define x y) + (super-init))) + x)) + +(test + (cons 78 16) + 'test-10 + (ivar (make-object (class/d (class object% () (public [x 16]) (sequence (super-init))) () + ((override x) + (rename [super-x x])) + (super-init) + (define y 78) + (define x (cons y super-x)))) + x)) + +(test + (cons 79 29) + 'test-10 + (ivar (make-object (class (class/d object% () + ((public x z)) + (define y 79) + (define x 19) + (define z (cons y x)) + (super-init)) () + (override + [x 29]) + (sequence + (super-init)))) + z)) diff --git a/collects/tests/mzscheme/cmdline.ss b/collects/tests/mzscheme/cmdline.ss new file mode 100644 index 00000000..618422db --- /dev/null +++ b/collects/tests/mzscheme/cmdline.ss @@ -0,0 +1,159 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'COMMAND-LINE) + +(require-library "cmdline.ss") + +(define (r-append opt . rest) + (append opt (list (list->vector rest)))) + +(test '("-bye" #()) + parse-command-line + "test" + #("--hi" "-bye") + (list + (list + 'multi + (list (list "--hi") + (lambda (flag v) v) + (list "Hello" "x")))) + r-append + '("arg")) + +(test '("1" "2" #("3")) + parse-command-line + "test" + #("-xi" "1" "2" "3") + (list + (list + 'multi + (list (list "-x" "-i") + (lambda (flag v) v) + (list "x or i" "x")))) + r-append + '("arg")) + +(test '(("-x" "a" "b") ("-i") #()) + parse-command-line + "test" + #("-xi" "a" "b") + (list + (list + 'multi + (list (list "-x" "-i") + list + (list "xi")))) + r-append + '("arg")) + +(test '("--simple" ("-x" . "a") ("-i" . "b") #()) + parse-command-line + "test" + #("--simple" "-xi" "a" "b") + (list + (list + 'multi + (list (list "--simple") (lambda (v) v) (list "S")) + (list (list "-x" "-i") + cons + (list "xi" "v")))) + r-append + '("arg")) + +(test '(("-x" "a" "c") ("-i" . "b") #("d")) + parse-command-line + "test" + #("-xi" "a" "c" "b" "d") + (list + (list + 'multi + (list (list "-x") + (lambda (x y z) (list x y z)) + (list "X" "y" "z")) + (list (list "-i") + cons + (list "i" "v")))) + r-append + '("arg")) + +(define (test-end-flags v include?) + (test (list + (list->vector + (let ([l '("-xi" "--bad" "--")]) + (if include? + (cons v l) + l)))) + parse-command-line + "test" + (vector v "-xi" "--bad" "--") + (list + (list + 'multi + (list (list "-x" "-i") + list + (list "xi")))) + r-append + '("arg"))) + +(test-end-flags "1" #t) +(test-end-flags "+" #t) +(test-end-flags "-" #t) +(test-end-flags "--" #f) +(test-end-flags "-1" #t) +(test-end-flags "+1" #t) +(test-end-flags "-1.4" #t) +(test-end-flags "+1999.0" #t) + +(define (test-bad-flag v name) ; -h and -i defined + (test 'yes-it-worked + (lambda (x-ignored y-ignored) + (with-handlers ([void + (lambda (exn) + (if (regexp-match + (format "unknown flag: ~s" name) + (exn-message exn)) + 'yes-it-worked + exn))]) + (parse-command-line + "test" + (vector name "--") + (list + (list + 'multi + (list (list "-x" "-i") + list + (list "x i")))) + r-append + '("arg")))) + v name)) + +(test-bad-flag "--ok" "--ok") +(test-bad-flag "-xbi" "-b") + +(test (void) parse-command-line "test" #() null void '("arg")) +(test (void) parse-command-line "test" #() (list (list 'once-each (list null void '("")))) void '("arg")) +(test (void) parse-command-line "test" #() (list (list 'once-any (list null void '("")))) void '("arg")) +(test (void) parse-command-line "test" #() (list (list 'multi (list null void '("")))) void '("arg")) +(test (void) parse-command-line "test" #() (list (list 'multi)) void '("arg")) + +(test "2" parse-command-line "test" #("1" "2") null (lambda (a b c) c) '("b" "c")) + +(error-test '(parse-command-line 'test #() null void '("arg"))) +(error-test '(parse-command-line "test" 9 null void '("arg"))) +(error-test '(parse-command-line "test" #() (list 0) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'malti)) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list 0 void '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list 0) void '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "hi") void '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--") void '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "-xi") void '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "-x") (lambda () null) '("")))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--xi") void ""))) void '("arg"))) +(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--xi") void '("" a)))) void '("arg"))) +(error-test '(parse-command-line "test" #() null (lambda () null) null)) + +(error-test '(parse-command-line "test" #() null (lambda (x y) null) null) exn:user?) + +(report-errs) diff --git a/collects/tests/mzscheme/compfile.ss b/collects/tests/mzscheme/compfile.ss new file mode 100644 index 00000000..4cd91819 --- /dev/null +++ b/collects/tests/mzscheme/compfile.ss @@ -0,0 +1,11 @@ + +(require-library "compat.ss") +(require-library "compat.ss") +(require-library "compat.ss") + +(defmacro test (x y) (string-append x y)) + +(test "a" "b") + +(load x) +(require-library) diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss new file mode 100644 index 00000000..a252c1f8 --- /dev/null +++ b/collects/tests/mzscheme/compile.ss @@ -0,0 +1,86 @@ + +; Tests compilation and writing/reading compiled code +; by setting the eval handler and running all tests + +(unless (defined? 'compile-load) + (global-defined-value 'compile-load "all.ss")) + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(define file + (if #f + (open-output-file "x" 'replace) + (make-output-port void void))) + +(define try-one + (lambda (e) + (let ([c (compile e)] + [p (open-output-string)]) + (write c p) + (let ([s (get-output-string p)]) + ; (write (string->list s)) (newline) + (let ([e (parameterize ([read-accept-compiled #t]) + (read (open-input-string s)))]) + (eval e)))))) + +(letrec ([orig (current-eval)] + [orig-load (current-load)] + [my-load + (lambda (filename) + (let ([f (open-input-file filename)]) + (dynamic-wind + void + (lambda () + (let loop ([results (list (void))]) + (let ([v (parameterize ([read-accept-compiled #t]) + (read f))]) + (if (eof-object? v) + (apply values results) + (loop (call-with-values + (lambda () (my-eval v orig)) + list)))))) + (lambda () + (close-input-port f)))))] + [my-eval + (case-lambda + [(x next-eval) + (let ([p (open-output-string)] + [c (compile x)]) + (write c p) + (let ([s (get-output-string p)]) + ; (display s file) (newline file) + (let ([e (parameterize ([read-accept-compiled #t]) + (read (open-input-string s)))]) + ; (write e file) (newline file) + (parameterize ([current-eval next-eval]) + (orig e)))))] + [(x) (my-eval x orig)])]) + (dynamic-wind + (lambda () + (set! teval (lambda (x) (my-eval x my-eval))) + ; (read-accept-compiled #t) + (current-eval my-eval) + (current-load my-load)) + (lambda () + (load-relative compile-load)) + (lambda () + (set! teval eval) + (close-output-port file) + ; (read-accept-compiled #f) + (current-eval orig) + (current-load orig-load)))) + +; Check compiled number I/O: +(let ([l (let loop ([n -512][l null]) + (if (= n 513) + l + (loop (add1 n) (cons n l))))] + [p (open-output-string)]) + (write (compile `(quote ,l)) p) + (let ([s (open-input-string (get-output-string p))]) + (let ([l2 (parameterize ([read-accept-compiled #t]) + (eval (read s)))]) + (test #t equal? l l2)))) + +(report-errs) diff --git a/collects/tests/mzscheme/compilex.ss b/collects/tests/mzscheme/compilex.ss new file mode 100644 index 00000000..5e417fb0 --- /dev/null +++ b/collects/tests/mzscheme/compilex.ss @@ -0,0 +1,14 @@ + +; Tests simple compilation by setting the eval handler and +; running all tests + +(let ([orig (current-eval)]) + (dynamic-wind + (lambda () + (current-eval + (lambda (x) + (orig (compile x))))) + (lambda () + (load "all.ss")) + (lambda () + (current-eval orig)))) diff --git a/collects/tests/mzscheme/contmark.ss b/collects/tests/mzscheme/contmark.ss new file mode 100644 index 00000000..bdc4ba2e --- /dev/null +++ b/collects/tests/mzscheme/contmark.ss @@ -0,0 +1,214 @@ + + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'continuation-marks) + +(define (extract-current-continuation-marks key) + (continuation-mark-set->list (current-continuation-marks) key)) + +(test null extract-current-continuation-marks 'key) + +(test '(10) 'wcm (with-continuation-mark 'key 10 + (extract-current-continuation-marks 'key))) +(test '(11) 'wcm (with-continuation-mark 'key 10 + (with-continuation-mark 'key 11 + (extract-current-continuation-marks 'key)))) +(test '(9) 'wcm (with-continuation-mark 'key 10 + (with-continuation-mark 'key2 9 + (with-continuation-mark 'key 11 + (extract-current-continuation-marks 'key2))))) +(test '() 'wcm (with-continuation-mark 'key 10 + (with-continuation-mark 'key2 9 + (with-continuation-mark 'key 11 + (extract-current-continuation-marks 'key3))))) + +(test '() 'wcm (let ([x (with-continuation-mark 'key 10 (list 100))]) + (extract-current-continuation-marks 'key))) + +(test '(11) 'wcm (with-continuation-mark 'key 11 + (let ([x (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))]) + (extract-current-continuation-marks 'key)))) + +(test '((11) (10 11) (11)) 'wcm (with-continuation-mark 'key 11 + (list (extract-current-continuation-marks 'key) + (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key)) + (extract-current-continuation-marks 'key)))) + +(test '(11) 'wcm-invoke/tail (with-continuation-mark 'x 10 + (invoke-unit + (unit + (import) + (export) + + (with-continuation-mark 'x 11 + (continuation-mark-set->list + (current-continuation-marks) + 'x)))))) + +(test '(11 10) 'wcm-invoke/nontail (with-continuation-mark 'x 10 + (invoke-unit + (unit + (import) + (export) + + (define l (with-continuation-mark 'x 11 + (continuation-mark-set->list + (current-continuation-marks) + 'x))) + l)))) + +(test '(11 10) 'wcm-begin0 (with-continuation-mark 'x 10 + (begin0 + (with-continuation-mark 'x 11 + (extract-current-continuation-marks 'x)) + (+ 2 3)))) +(test '(11 10) 'wcm-begin0/const (with-continuation-mark 'x 10 + (begin0 + (with-continuation-mark 'x 11 + (extract-current-continuation-marks 'x)) + 'constant))) + +(define (get-marks) + (extract-current-continuation-marks 'key)) + +(define (tail-apply f) + (with-continuation-mark 'key 'tail + (f))) + +(define (non-tail-apply f) + (with-continuation-mark 'key 'non-tail + (car (cons (f) null)))) + +(test '(tail) tail-apply get-marks) +(test '(non-tail) non-tail-apply get-marks) +(test '(tail non-tail) non-tail-apply (lambda () (tail-apply get-marks))) +(test '(non-tail) tail-apply (lambda () (non-tail-apply get-marks))) + +(define (mark-x f) + (lambda () + (with-continuation-mark 'key 'x (f)))) + +(test '(x) tail-apply (mark-x get-marks)) +(test '(x non-tail) non-tail-apply (mark-x get-marks)) + +(test '(x) tail-apply (lambda () (tail-apply (mark-x get-marks)))) +(test '(x non-tail non-tail) non-tail-apply (lambda () (non-tail-apply (mark-x get-marks)))) +(test '(x non-tail) tail-apply (lambda () (non-tail-apply (mark-x get-marks)))) +(test '(x non-tail) non-tail-apply (lambda () (tail-apply (mark-x get-marks)))) + +;; Make sure restoring continuations restores the marks: +(let ([l null]) + (let ([did-once? #f] + [did-twice? #f] + [try-again #f] + [get-marks #f]) + + (with-continuation-mark + 'key (let/cc k (set! try-again k) 1) + (begin + (unless did-once? + (set! get-marks (let/cc k k))) + (set! l (cons (extract-current-continuation-marks 'key) l)))) + + (if did-once? + (unless did-twice? + (set! did-twice? #t) + (get-marks #f)) + (begin + (set! did-once? #t) + (try-again 2)))) + + (test '((1) (2) (1)) 'call/cc-restore-marks l)) + +(define (p-equal? a b) + (let loop ([a a][b b]) + (cond + [(eq? a b) #t] + [(equal? (car a) (car b)) + (loop (cdr a) (cdr b))] + [else + (printf "a: ~s~n" a) + (printf "b: ~s~n" b) + #f]))) + +;; Create a deep stack with a deep mark stack +(test #t + 'deep-stacks + (p-equal? + (let loop ([n 1000][l null]) + (if (zero? n) + l + (loop (sub1 n) (cons n l)))) + (let loop ([n 1000]) + (if (zero? n) + (extract-current-continuation-marks 'x) + (let ([x (with-continuation-mark 'x n (loop (sub1 n)))]) + x))))) + +;; Create a deep mark stack 10 times +(let loop ([n 10]) + (unless (zero? n) + (let* ([max 1000] + [r (add1 (random max))]) + (test (list 0 r) + `(loop ,n) + (with-continuation-mark 'base 0 + (let loop ([n max]) + (if (zero? n) + (append + (extract-current-continuation-marks 'base) + (extract-current-continuation-marks r)) + (with-continuation-mark n n + (loop (sub1 n)))))))) + (loop (sub1 n)))) + +;; Make sure marks are separate in separate threads +(let ([s1 (make-semaphore 0)] + [s2 (make-semaphore 0)] + [result null]) + (thread (lambda () + (with-continuation-mark 'key 'b.1 + (begin + (semaphore-wait s1) + (with-continuation-mark 'key 'b.2 + (begin + (semaphore-post s2) + (semaphore-wait s1) + (with-continuation-mark 'key 'b.4 + (begin + (set! result (extract-current-continuation-marks 'key)) + (semaphore-post s2))) + 'ok)) + 'ok)))) + (thread-wait + (thread (lambda () + (with-continuation-mark 'key 'a.1 + (begin + (semaphore-post s1) + (with-continuation-mark 'key 'a.2 + (begin + (semaphore-wait s2) + (with-continuation-mark 'key 'a.3 + (begin + (semaphore-post s1) + (with-continuation-mark 'key 'a.4 + (begin + (semaphore-wait s2) + (set! result (append (extract-current-continuation-marks 'key) result)))) + 'ok)) + 'ok)) + 'ok))))) + (test '(a.4 a.3 a.2 a.1 b.4 b.2 b.1) 'thread-marks result)) + +(arity-test current-continuation-marks 0 0) +(arity-test continuation-mark-set->list 2 2) +(arity-test continuation-mark-set? 1 1) + +(error-test '(continuation-mark-set->list 5 1)) + +(test #f continuation-mark-set? 5) +(test #t continuation-mark-set? (current-continuation-marks)) + +(report-errs) diff --git a/collects/tests/mzscheme/date.ss b/collects/tests/mzscheme/date.ss new file mode 100644 index 00000000..10671b78 --- /dev/null +++ b/collects/tests/mzscheme/date.ss @@ -0,0 +1,42 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'date) + +(require-library "date.ss") + +(define (test-find s m h d mo y) + (let* ([secs (find-seconds s m h d mo y)] + [date (seconds->date secs)]) + (test #t 'same + (and (= s (date-second date)) + (= m (date-minute date)) + (= h (date-hour date)) + (= d (date-day date)) + (= mo (date-month date)) + (= y (date-year date)))))) + +(test-find 0 0 0 1 4 1975) +(test-find 0 0 0 1 4 2005) + +; Bad dates +(error-test '(find-seconds 0 0 0 0 0 1990) exn:user?) +(error-test '(find-seconds 0 0 0 0 1 1990) exn:user?) +(error-test '(find-seconds 0 0 0 1 0 1990) exn:user?) + +; Early/late +(error-test '(find-seconds 0 0 0 1 1 1490) exn:user?) +(error-test '(find-seconds 0 0 0 1 1 2890) exn:user?) + +; 1990 April 1 was start of daylight savings: +(test-find 0 0 1 1 4 1990) ; ok +(let ([s (find-seconds 1 0 3 1 4 1990)]) ; ok + (when (date-dst? (seconds->date s)) + ; We have daylight savings here; 2:01 AM doesn't exist + (error-test '(find-seconds 0 1 2 1 4 1990) exn:user?) + ; This date is ambiguous; find-seconds should find + ; one of the two possible values, though: + (test-find 0 30 1 27 10 1996))) + +(report-errs) diff --git a/collects/tests/mzscheme/deep.ss b/collects/tests/mzscheme/deep.ss new file mode 100644 index 00000000..6cf30e78 --- /dev/null +++ b/collects/tests/mzscheme/deep.ss @@ -0,0 +1,126 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'deep) + +; Test deep stacks + +(define (nontail-loop n esc) + (let loop ([n n]) + (if (zero? n) + (esc 0) + (sub1 (loop (sub1 n)))))) + +(define (time-it t) + (let ([s (current-process-milliseconds)]) + (t) + (- (current-process-milliseconds) s))) + +(define (find-depth go) + ; Find depth that triggers a stack overflow by looking + ; for an incongruous change in the running time. + (let find-loop ([d 100][t (time-it (lambda () (go 100)))]) + (if (zero? t) + (find-loop (* 2 d) (time-it (lambda () (go (* 2 d))))) + (begin + ; (printf "~a in ~a~n" d t) + (let* ([d2 (* 2 d)] + [t2 (time-it (lambda () (go d2)))]) + (if (> (/ t2 d2) (* 2.2 (/ t d))) + d2 + (find-loop d2 t2))))))) + +(define proc-depth (find-depth (lambda (n) (nontail-loop n (lambda (x) x))))) +(printf "non-tail loop overflows at ~a~n" proc-depth) + +(test (- proc-depth) 'deep-recursion (nontail-loop proc-depth (lambda (x) x))) + +(test 0 'deep-recursion-escape/ec + (let/ec k + (nontail-loop proc-depth k))) + +(test 0 'deep-recursion-escape/cc + (let/cc k + (nontail-loop proc-depth k))) + +(define (read-deep depth) + (define paren-port + (let* ([depth depth] + [closing? #f] + [count depth]) + (make-input-port + (lambda () + (cond + [closing? + (if (= count depth) + eof + (begin + (set! count (add1 count)) + #\) ))] + [else + (set! count (sub1 count)) + (when (zero? count) + (set! closing? #t)) + #\(])) + (lambda () #t) + void))) + (read paren-port)) + +(define read-depth (find-depth read-deep)) +(printf "nested paren read overflows at ~a~n" read-depth) + +(define deep-list (read-deep read-depth)) + +(test #t 'read-deep (pair? deep-list)) + +(define s (open-output-string)) +(display deep-list s) +(test 'ok 'display 'ok) + +(test #t 'equal? (equal? deep-list (read (open-input-string (get-output-string s))))) + +(define going? #t) +(define (equal?-forever l1 l2) + (let ([t (thread (lambda () + (equal? l1 l2) ; runs forever; could run out of memory + (set! going? #f)))]) + (sleep 1) + (kill-thread t) + going?)) + + +(define l1 (cons 0 #f)) +(set-cdr! l1 l1) +(define l2 (cons 0 #f)) +(set-cdr! l2 l2) +(test #t 'equal?-forever (equal?-forever l1 l2)) + +(define l1 (cons 0 #f)) +(set-car! l1 l1) +(define l2 (cons 0 #f)) +(set-car! l2 l2) +(test #t 'equal?-forever/memory (equal?-forever l1 l2)) + +(define l1 (vector 0)) +(vector-set! l1 0 l1) +(define l2 (vector 0)) +(vector-set! l2 0 l2) +(test #t 'equal?-forever/vector (equal?-forever l1 l2)) + +(define-struct a (b c)) +(define l1 (make-a 0 #f)) +(set-a-b! l1 l1) +(define l2 (make-a 0 #f)) +(set-a-b! l2 l2) +(test #t 'equal?-forever/struct (equal?-forever l1 l2)) + +(define l1 (box 0)) +(set-box! l1 l1) +(define l2 (box 0)) +(set-box! l2 l2) +(test #t 'equal?-forever/struct (equal?-forever l1 l2)) + +(test #t 'equal?-forever/struct (call-in-nested-thread (lambda () (equal?-forever l1 l2)))) + +(report-errs) diff --git a/collects/tests/mzscheme/em-imp.ss b/collects/tests/mzscheme/em-imp.ss new file mode 100644 index 00000000..69a97a09 --- /dev/null +++ b/collects/tests/mzscheme/em-imp.ss @@ -0,0 +1,467 @@ +;;; -*- scheme -*- +;;; Fortran-style implementation of an EM clustering algorithm. +;;; +;;; Written by Jeffrey Mark Siskind (qobi@cs.toronto.edu) +;;; R4RS-ified by by Lars Thomas Hansen (lth@cs.uoregon.edu) +;;; Random number generator by Ozan Yigit. +;;; +;;; To run: (run-benchmark) +;;; You must provide your own timer function. +;;; +;;; Some benchmark times: +;;; +;;; Chez Scheme 4.1 for SunOS running on Sparc 10/51 (1MB,96MB,50MHz), Solaris: +;;; Optimize-level 2: 112s run (CPU), 2.8s gc, 326 MB allocated, 1181 GCs +;;; Optimize-level 3: 79s run (CPU), 2.8s gc, 326 MB allocated, 1163 GCs + +(define make-model vector) +(define (model-pi model) (vector-ref model 0)) +(define (set-model-pi! model x) (vector-set! model 0 x)) +(define (model-mu model) (vector-ref model 1)) +(define (model-sigma model) (vector-ref model 2)) +(define (model-log-pi model) (vector-ref model 3)) +(define (set-model-log-pi! model x) (vector-set! model 3 x)) +(define (model-sigma-inverse model) (vector-ref model 4)) +(define (model-log-determinant-sigma model) (vector-ref model 5)) +(define (set-model-log-sigma-determinant! model x) (vector-set! model 5 x)) + +;--------------------------------------------------------------------------- +; Minimal Standard Random Number Generator +; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version. +; better constants, as proposed by Park. +; By Ozan Yigit + +(define *seed* 1) + +(define (srand seed) + (set! *seed* seed) + *seed*) + +(define (rand) + (let ((A 48271) + (M 2147483647) + (Q 44488) + (R 3399)) + (let* ((hi (quotient *seed* Q)) + (lo (modulo *seed* Q)) + (test (- (* A lo) (* R hi)))) + (if (> test 0) + (set! *seed* test) + (set! *seed* (+ test M))))) + *seed*) + +;--------------------------------------------------------------------------- + +(define (panic s) (error 'panic s)) + +(define *rand-max* 2147483648) + +(define log-math-precision 35.0) + +(define minus-infinity (- *rand-max*)) + +(define first car) + +(define second cadr) + +(define rest cdr) + +(define (reduce f l i) + (cond ((null? l) i) + ((null? (rest l)) (first l)) + (else (let loop ((l (rest l)) (c (first l))) + (if (null? l) c (loop (rest l) (f c (first l)))))))) + +(define (every-n p n) + (let loop ((i 0)) (or (>= i n) (and (p i) (loop (+ i 1)))))) + +(define (sum f n) + (let loop ((n (- n 1)) (c 0.0)) + (if (negative? n) c (loop (- n 1) (+ c (f n)))))) + +(define (add-exp e1 e2) + (let* ((e-max (max e1 e2)) + (e-min (min e1 e2)) + (factor (floor e-min))) + (if (= e-max minus-infinity) + minus-infinity + (if (> (- e-max factor) log-math-precision) + e-max + (+ (log (+ (exp (- e-max factor)) (exp (- e-min factor)))) + factor))))) + +(define (map-n f n) + (let loop ((i 0) (c '())) + (if (< i n) (loop (+ i 1) (cons (f i) c)) (reverse c)))) + +(define (map-n-vector f n) + (let ((v (make-vector n))) + (let loop ((i 0)) + (if (< i n) + (begin (vector-set! v i (f i)) + (loop (+ i 1))))) + v)) + +(define (remove-if-not p l) + (let loop ((l l) (c '())) + (cond ((null? l) (reverse c)) + ((p (first l)) (loop (rest l) (cons (first l) c))) + (else (loop (rest l) c))))) + +(define (positionv x l) + (let loop ((l l) (i 0)) + (cond ((null? l) #f) + ((eqv? x (first l)) i) + (else (loop (rest l) (+ i 1)))))) + +(define (make-matrix m n) + (map-n-vector (lambda (i) (make-vector n)) m)) + +(define (make-matrix-initial m n initial) + (map-n-vector (lambda (i) (make-vector n initial)) m)) + +(define (matrix-rows a) (vector-length a)) + +(define (matrix-columns a) (vector-length (vector-ref a 0))) + +(define (matrix-ref a i j) (vector-ref (vector-ref a i) j)) + +(define (matrix-set! a i j x) (vector-set! (vector-ref a i) j x)) + +(define (matrix-row-ref a i) (vector-ref a i)) + +(define (matrix-row-set! a i v) (vector-set! a i v)) + +(define (determinant a) + (if (not (= (matrix-rows a) (matrix-columns a))) + (panic "Can only find determinant of a square matrix")) + (call-with-current-continuation + (lambda (return) + (let* ((n (matrix-rows a)) + (b (make-matrix n n)) + (d 1.0)) + (do ((i 0 (+ i 1))) ((= i n)) + (do ((j 0 (+ j 1))) ((= j n)) (matrix-set! b i j (matrix-ref a i j)))) + (do ((i 0 (+ i 1))) ((= i n)) + ;; partial pivoting reduces rounding errors + (let ((greatest (abs (matrix-ref b i i))) + (index i)) + (do ((j (+ i 1) (+ j 1))) ((= j n)) + (let ((x (abs (matrix-ref b j i)))) + (if (> x greatest) (begin (set! index j) (set! greatest x))))) + (if (= greatest 0.0) (return 0.0)) + (if (not (= index i)) + (let ((v (matrix-row-ref b i))) + (matrix-row-set! b i (matrix-row-ref b index)) + (matrix-row-set! b index v) + (set! d (- d)))) + (let ((c (matrix-ref b i i))) + (set! d (* d c)) + (do ((j i (+ j 1))) ((= j n)) + (matrix-set! b i j (/ (matrix-ref b i j) c))) + (do ((j (+ i 1) (+ j 1))) ((= j n)) + (let ((e (matrix-ref b j i))) + (do ((k (+ i 1) (+ k 1))) ((= k n)) + (matrix-set! + b j k (- (matrix-ref b j k) (* e (matrix-ref b i k)))))))))) + d)))) + +(define (invert-matrix! a b) + (if (not (= (matrix-rows a) (matrix-columns a))) + (panic "Can only invert a square matrix")) + (let* ((n (matrix-rows a)) + (c (make-matrix n n))) + (do ((i 0 (+ i 1))) ((= i n)) + (do ((j 0 (+ j 1))) ((= j n)) + (matrix-set! b i j 0.0) + (matrix-set! c i j (matrix-ref a i j)))) + (do ((i 0 (+ i 1))) ((= i n)) (matrix-set! b i i 1.0)) + (do ((i 0 (+ i 1))) ((= i n)) + (if (zero? (matrix-ref c i i)) + (call-with-current-continuation + (lambda (return) + (do ((j 0 (+ j 1))) ((= j n)) + (if (and (> j i) (not (zero? (matrix-ref c j i)))) + (begin + (let ((e (vector-ref c i))) + (vector-set! c i (vector-ref c j)) + (vector-set! c j e)) + (let ((e (vector-ref b i))) + (vector-set! b i (vector-ref b j)) + (vector-set! b j e)) + (return #f)))) + (panic "Matrix is singular")))) + (let ((d (/ (matrix-ref c i i)))) + (do ((j 0 (+ j 1))) ((= j n)) + (matrix-set! c i j (* d (matrix-ref c i j))) + (matrix-set! b i j (* d (matrix-ref b i j)))) + (do ((k 0 (+ k 1))) ((= k n)) + (let ((d (- (matrix-ref c k i)))) + (if (not (= k i)) + (do ((j 0 (+ j 1))) ((= j n)) + (matrix-set! + c k j (+ (matrix-ref c k j) (* d (matrix-ref c i j)))) + (matrix-set! + b k j (+ (matrix-ref b k j) (* d (matrix-ref b i j)))))))))))) + +(define (jacobi! a) + (if (not (and (= (matrix-rows a) (matrix-columns a)) + (every-n (lambda (i) + (every-n (lambda (j) + (= (matrix-ref a i j) (matrix-ref a j i))) + (matrix-rows a))) + (matrix-rows a)))) + (panic "Can only compute eigenvalues/eigenvectors of a symmetric matrix")) + (let* ((n (matrix-rows a)) + (d (make-vector n)) + (v (make-matrix-initial n n 0.0)) + (b (make-vector n)) + (z (make-vector n 0.0))) + (do ((ip 0 (+ ip 1))) ((= ip n)) + (matrix-set! v ip ip 1.0) + (vector-set! b ip (matrix-ref a ip ip)) + (vector-set! d ip (matrix-ref a ip ip))) + (let loop ((i 0)) + (if (> i 50) (panic "Too many iterations in JACOBI!")) + (let ((sm (sum (lambda (ip) + (sum (lambda (ir) + (let ((iq (+ ip ir 1))) + (abs (matrix-ref a ip iq)))) + (- n ip 1))) + (- n 1)))) + (if (not (zero? sm)) + (begin + (let ((tresh (if (< i 3) (/ (* 0.2 sm) (* n n)) 0.0))) + (do ((ip 0 (+ ip 1))) ((= ip (- n 1))) + (do ((ir 0 (+ ir 1))) ((= ir (- n ip 1))) + (let* ((iq (+ ip ir 1)) + (g (* 100.0 (abs (matrix-ref a ip iq))))) + (cond + ((and (> i 3) + (= (+ (abs (vector-ref d ip)) g) + (abs (vector-ref d ip))) + (= (+ (abs (vector-ref d iq)) g) + (abs (vector-ref d iq)))) + (matrix-set! a ip iq 0.0)) + ((> (abs (matrix-ref a ip iq)) tresh) + (let* ((h (- (vector-ref d iq) (vector-ref d ip))) + (t (if (= (+ (abs h) g) (abs h)) + (/ (matrix-ref a ip iq) h) + (let ((theta (/ (* 0.5 h) + (matrix-ref a ip iq)))) + (if (negative? theta) + (- (/ (+ (abs theta) + (sqrt (+ (* theta theta) 1.0))))) + (/ (+ (abs theta) + (sqrt (+ (* theta theta) 1.0)))))))) + (c (/ (sqrt (+ (* t t) 1.0)))) + (s (* t c)) + (tau (/ s (+ c 1.0))) + (h (* t (matrix-ref a ip iq)))) + (define (rotate a i j k l) + (let ((g (matrix-ref a i j)) + (h (matrix-ref a k l))) + (matrix-set! a i j (- g (* s (+ h (* g tau))))) + (matrix-set! a k l (+ h (* s (- g (* h tau))))))) + (vector-set! z ip (- (vector-ref z ip) h)) + (vector-set! z iq (+ (vector-ref z iq) h)) + (vector-set! d ip (- (vector-ref d ip) h)) + (vector-set! d iq (+ (vector-ref d iq) h)) + (matrix-set! a ip iq 0.0) + (do ((j 0 (+ j 1))) ((= j n)) + (cond ((< j ip) (rotate a j ip j iq)) + ((< ip j iq) (rotate a ip j j iq)) + ((< iq j) (rotate a ip j iq j))) + (rotate v j ip j iq))))))))) + (do ((ip 0 (+ ip 1))) ((= ip n)) + (vector-set! b ip (+ (vector-ref b ip) (vector-ref z ip))) + (vector-set! d ip (vector-ref b ip)) + (vector-set! z ip 0.0)) + (loop (+ i 1)))))) + (do ((i 0 (+ i 1))) ((= i (- n 1))) + (let ((k i) + (p (vector-ref d i))) + (do ((l 0 (+ l 1))) ((= l (- n i 1))) + (let* ((j (+ i l 1))) + (if (>= (vector-ref d j) p) + (begin (set! k j) (set! p (vector-ref d j)))))) + (if (not (= k i)) + (begin (vector-set! d k (vector-ref d i)) + (vector-set! d i p) + (do ((j 0 (+ j 1))) ((= j n)) + (let ((p (matrix-ref v j i))) + (matrix-set! v j i (matrix-ref v j k)) + (matrix-set! v j k p))))))) + (list d v))) + +(define (clip-eigenvalues! a v) + (let* ((j (jacobi! a)) + (l (first j)) + (e (second j))) + (do ((k1 0 (+ k1 1))) ((= k1 (vector-length a))) + (let ((a-k1 (vector-ref a k1)) + (e-k1 (vector-ref e k1))) + (do ((k2 0 (+ k2 1))) ((= k2 (vector-length a-k1))) + (let ((e-k2 (vector-ref e k2)) + (s 0.0)) + (do ((k 0 (+ k 1))) ((= k (vector-length a))) + (set! s (+ s (* (max (vector-ref v k) (vector-ref l k)) + (vector-ref e-k1 k) + (vector-ref e-k2 k))))) + (vector-set! a-k1 k2 s))))))) + +;;; EM + +(define (e-step! x z models) + (do ((i 0 (+ i 1))) ((= i (vector-length x))) + (let ((xi (vector-ref x i)) + (zi (vector-ref z i))) + (do ((j 0 (+ j 1))) ((= j (vector-length models))) + ;; Compute for each model. + (let* ((model (vector-ref models j)) + (log-pi (model-log-pi model)) + (mu (model-mu model)) + (sigma-inverse (model-sigma-inverse model)) + (log-determinant-sigma (model-log-determinant-sigma model)) + (t 0.0)) + ;; Compute likelihoods (note: up to constant for all models). + (set! t 0.0) + (do ((k1 0 (+ k1 1))) ((= k1 (vector-length xi))) + (let ((sigma-inverse-k1 (vector-ref sigma-inverse k1))) + (do ((k2 0 (+ k2 1))) ((= k2 (vector-length xi))) + (set! t (+ t (* (- (vector-ref xi k1) (vector-ref mu k1)) + (vector-ref sigma-inverse-k1 k2) + (- (vector-ref xi k2) (vector-ref mu k2)))))))) + (vector-set! zi j (- log-pi (* 0.5 (+ log-determinant-sigma t)))))))) + (let ((l 0.0)) + (do ((i 0 (+ i 1))) ((= i (vector-length x))) + (let ((s minus-infinity) + (zi (vector-ref z i))) + ;; Normalize ownerships to sum to one. + (do ((j 0 (+ j 1))) ((= j (vector-length models))) + (set! s (add-exp s (vector-ref zi j)))) + (do ((j 0 (+ j 1))) ((= j (vector-length models))) + (vector-set! zi j (exp (- (vector-ref zi j) s)))) + (set! l (+ l s)))) + ;; Return log likelihood. + l)) + +(define (m-step! x models z clip) + (let ((kk (vector-length (vector-ref x 0)))) + ;; For each model, optimize parameters. + (do ((j 0 (+ j 1))) ((= j (vector-length models))) + (let* ((model (vector-ref models j)) + (mu (model-mu model)) + (sigma (model-sigma model)) + (s 0.0)) + ;; Optimize values. + (do ((k 0 (+ k 1))) ((= k kk)) + (do ((i 0 (+ i 1))) ((= i (vector-length x))) + (set! s (+ s (vector-ref (vector-ref z i) j))))) + (do ((k 0 (+ k 1))) ((= k kk)) + (let ((m 0.0)) + (do ((i 0 (+ i 1))) ((= i (vector-length x))) + (set! m (+ m (* (vector-ref (vector-ref z i) j) + (vector-ref (vector-ref x i) k))))) + (vector-set! mu k (/ m s)))) + (do ((k1 0 (+ k1 1))) ((= k1 kk)) + (let ((sigma-k1 (vector-ref sigma k1)) + (mu-k1 (vector-ref mu k1))) + (do ((k2 0 (+ k2 1))) ((= k2 kk)) + (let ((mu-k2 (vector-ref mu k2)) + (m 0.0)) + (do ((i 0 (+ i 1))) ((= i (vector-length x))) + (set! m (+ m (* (vector-ref (vector-ref z i) j) + (- (vector-ref (vector-ref x i) k1) mu-k1) + (- (vector-ref (vector-ref x i) k2) mu-k2))))) + (vector-set! sigma-k1 k2 (/ m s)))))) + (clip-eigenvalues! sigma clip) + (set-model-pi! model (/ s (vector-length x))) + (set-model-log-pi! model (log (/ s (vector-length x)))) + (invert-matrix! sigma (model-sigma-inverse model)) + (set-model-log-sigma-determinant! model (log (determinant sigma))))))) + +(define (em! x z models clip em-kick-off-tolerance em-convergence-tolerance) + (let loop ((old-log-likelihood minus-infinity) (starting? #t)) + (let ((log-likelihood (e-step! x z models))) + (cond + ((or (and starting? (> log-likelihood old-log-likelihood)) + (> log-likelihood (+ old-log-likelihood em-convergence-tolerance))) + (m-step! x models z clip) + (loop log-likelihood + (and starting? + (not (= (vector-length models) 1)) + (or (= old-log-likelihood minus-infinity) + (< log-likelihood + (+ old-log-likelihood em-kick-off-tolerance)))))) + (else old-log-likelihood))))) + +(define (noise epsilon) (- (* 2.0 epsilon (/ (rand) *rand-max*)) epsilon)) + +(define (initial-z ii jj) + (map-n-vector + (lambda (i) + (let ((zi (map-n-vector (lambda (j) (+ (/ jj) (noise (/ jj)))) jj)) + (s 0.0)) + (do ((j 0 (+ j 1))) ((= j jj)) (set! s (+ s (vector-ref zi j)))) + (do ((j 0 (+ j 1))) ((= j jj)) (vector-set! zi j (/ (vector-ref zi j) s))) + zi)) + ii)) + +(define (ems x clip em-kick-off-tolerance em-convergence-tolerance + ems-convergence-tolerance) + (let loop ((jj 1) + (old-z #f) + (old-models #f) + (old-log-likelihood minus-infinity)) + (let* ((kk (vector-length (vector-ref x 0))) + (z (initial-z (vector-length x) jj)) + (models (map-n-vector + (lambda (j) + (make-model 0.0 + (make-vector kk) + (make-matrix kk kk) + 0.0 + (make-matrix kk kk) + 0.0)) + jj))) + (m-step! x models z clip) + (let ((new-log-likelihood + (em! + x z models clip em-kick-off-tolerance em-convergence-tolerance))) + (if (> (- (/ old-log-likelihood new-log-likelihood) 1.0) + ems-convergence-tolerance) + (loop (+ jj 1) z models new-log-likelihood) + (list old-z old-models)))))) + +(define (em-clusterer x clip em-kick-off-tolerance em-convergence-tolerance + ems-convergence-tolerance) + (let* ((z-models (ems x clip em-kick-off-tolerance + em-convergence-tolerance + ems-convergence-tolerance)) + (z (first z-models)) + (models (second z-models))) + (e-step! x z models) + (let ((clusters + (map-n (lambda (i) + (let ((zi (vector->list (vector-ref z i)))) + (list i (positionv (reduce max zi minus-infinity) zi)))) + (vector-length z)))) + (map-n (lambda (j) + (map (lambda (cluster) (vector-ref x (first cluster))) + (remove-if-not (lambda (cluster) (= (second cluster) j)) + clusters))) + (vector-length (vector-ref z 0)))))) + +(define (go) + (em-clusterer + '#(#(1.0) #(2.0) #(3.0) #(11.0) #(12.0) #(13.0)) '#(1.0) 10.0 1.0 0.01)) + +(define (run-benchmark) + (srand 1) + (do ((i 0 (+ i 1))) ((= i 100)) + (write (go)) + (newline))) + +; eof + diff --git a/collects/tests/mzscheme/expand.ss b/collects/tests/mzscheme/expand.ss new file mode 100644 index 00000000..ab184a17 --- /dev/null +++ b/collects/tests/mzscheme/expand.ss @@ -0,0 +1,26 @@ + +; Tests macro expansion by setting the eval handler and +; running all tests + +(unless (defined? 'expand-load) + (global-defined-value 'expand-load "all.ss")) + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(let ([orig (current-eval)]) + (dynamic-wind + (lambda () + (current-eval + (lambda (x) + (set! mz-test-syntax-errors-allowed? #t) + (let ([x (expand-defmacro + (expand-defmacro + (expand-defmacro-once + (expand-defmacro-once x))))]) + (set! mz-test-syntax-errors-allowed? #f) + (orig x))))) + (lambda () + (load-relative expand-load)) + (lambda () + (current-eval orig)))) diff --git a/collects/tests/mzscheme/fact.ss b/collects/tests/mzscheme/fact.ss new file mode 100644 index 00000000..d991f2fc --- /dev/null +++ b/collects/tests/mzscheme/fact.ss @@ -0,0 +1,6 @@ +(define fact + (lambda (n) + (let loop ([n n][res 1]) + (if (zero? n) + res + (loop (sub1 n) (* n res)))))) diff --git a/collects/tests/mzscheme/file.ss b/collects/tests/mzscheme/file.ss new file mode 100644 index 00000000..e345ff86 --- /dev/null +++ b/collects/tests/mzscheme/file.ss @@ -0,0 +1,677 @@ + + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(define testing.ss (build-path (current-load-relative-directory) "testing.ss")) + +(SECTION 6 10 1) +(test #t input-port? (current-input-port)) +(test #t output-port? (current-output-port)) +(test #t output-port? (current-error-port)) +(test (void) current-input-port (current-input-port)) +(test (void) current-output-port (current-output-port)) +(test (void) current-error-port (current-error-port)) +(test #t call-with-input-file testing.ss input-port?) +(define this-file (open-input-file testing.ss)) +(test #t input-port? this-file) +(close-input-port this-file) +(define this-file (open-input-file testing.ss 'binary)) +(test #t input-port? this-file) +(close-input-port this-file) +(define this-file (open-input-file testing.ss 'text)) +(test #t input-port? this-file) +(arity-test input-port? 1 1) +(arity-test output-port? 1 1) +(arity-test current-input-port 0 1) +(arity-test current-output-port 0 1) +(arity-test current-error-port 0 1) +(error-test '(current-input-port 8)) +(error-test '(current-output-port 8)) +(error-test '(current-error-port 8)) +(error-test '(current-input-port (current-output-port))) +(error-test '(current-output-port (current-input-port))) +(error-test '(current-error-port (current-input-port))) +(SECTION 6 10 2) +(test #\; peek-char this-file) +(arity-test peek-char 0 1) +(test #\; read-char this-file) +(arity-test read-char 0 1) +(test '(define cur-section '()) read this-file) +(arity-test read 0 1) +(test #\( peek-char this-file) +(test '(define errs '()) read this-file) +(close-input-port this-file) +(close-input-port this-file) +(arity-test close-input-port 1 1) +(arity-test close-output-port 1 1) +(error-test '(peek-char 5)) +(error-test '(peek-char (current-output-port))) +(error-test '(read-char 5)) +(error-test '(read-char (current-output-port))) +(error-test '(read 5)) +(error-test '(read (current-output-port))) +(error-test '(close-input-port 5)) +(error-test '(close-output-port 5)) +(error-test '(close-input-port (current-output-port))) +(error-test '(close-output-port (current-input-port))) +(define (check-test-file name) + (define test-file (open-input-file name)) + (test #t 'input-port? + (call-with-input-file + name + (lambda (test-file) + (test load-test-obj read test-file) + (test #t eof-object? (peek-char test-file)) + (test #t eof-object? (read-char test-file)) + (input-port? test-file)))) + (test #\; read-char test-file) + (test display-test-obj read test-file) + (test load-test-obj read test-file) + (close-input-port test-file)) +(SECTION 6 10 3) +(define write-test-obj + '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) +(define display-test-obj + '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) +(define load-test-obj + (list 'define 'foo (list 'quote write-test-obj))) +(let ([f (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))]) + (test #t call-with-output-file + "tmp1" f 'truncate)) +(check-test-file "tmp1") + +(test (string #\null #\null #\" #\null #\") + 'write-null + (let ([p (open-output-string)]) + (write-char #\null p) + (display (string #\null) p) + (write (string #\null) p) + (let ([s (get-output-string p)]) + s))) + +; Test string ports with file-position: +(let ([s (open-output-string)]) + (test (string) get-output-string s) + (test 0 file-position s) + (display "a" s) + (test (string #\a) get-output-string s) + (test 1 file-position s) + (test (void) file-position s 10) + (test 10 file-position s) + (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul) get-output-string s) + (display "z" s) + (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\z) get-output-string s) + (test 11 file-position s) + (test (void) file-position s 3) + (display "mmm" s) + (test (string #\a #\nul #\nul #\m #\m #\m #\nul #\nul #\nul #\nul #\z) get-output-string s) + (test 6 file-position s) + (display "banana" s) + (test (string #\a #\nul #\nul #\m #\m #\m #\b #\a #\n #\a #\n #\a) get-output-string s) + (test 12 file-position s)) +(let ([s (open-input-string "hello")]) + (test 0 file-position s) + (test #\h read-char s) + (test 1 file-position s) + (test #\e read-char s) + (test (void) file-position s 0) + (test 0 file-position s) + (test #\h read-char s) + (test (void) file-position s 4) + (test 4 file-position s) + (test #\o read-char s) + (test 5 file-position s) + (test eof read-char s) + (test 5 file-position s) + (test (void) file-position s 502) + (test eof read-char s) + (test eof read-char s) + (test 502 file-position s) + (test (void) file-position s 2) + (test #\l read-char s) + (test 3 file-position s)) + +(define s (open-output-string)) +(error-test '(file-position 's 1)) +(error-test '(file-position s 'one)) +(error-test '(file-position s -1)) +(error-test '(file-position s (expt 2 100)) exn:application:mismatch?) +(error-test '(file-position (make-input-port void void void) 100) exn:application:mismatch?) +(error-test '(file-position (make-output-port void void) 100) exn:application:mismatch?) +(arity-test file-position 1 2) + +(define (test-read-line r1 r2 s1 s2 flags sep) + (let ([p (open-input-string (string-append s1 + (apply string sep) + s2))]) + (test r1 apply read-line p flags) + (test r2 apply read-line p flags))) +(define (add-return s t) (string-append s (string #\return) t)) +(define (add-linefeed s t) (string-append s (string #\linefeed) t)) + +(test-read-line "ab" "cd" "ab" "cd" null '(#\linefeed)) +(test-read-line (add-return "ab" "cd") eof "ab" "cd" null '(#\return)) +(test-read-line (add-return "ab" "") "cd" "ab" "cd" null '(#\return #\linefeed)) +(test-read-line "ab" "cd" "ab" "cd" '(return) '(#\return)) +(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return) '(#\linefeed)) +(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return) '(#\return #\linefeed)) +(test-read-line (add-return "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\return)) +(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\linefeed)) +(test-read-line "ab" "cd" "ab" "cd" '(return-linefeed) '(#\return #\linefeed)) +(test-read-line (add-return "ab" "") "cd" "ab" "cd" '(return-linefeed) '(#\return #\return #\linefeed)) +(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return-linefeed) '(#\return #\linefeed #\linefeed)) +(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return)) +(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\linefeed)) +(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return #\linefeed)) +(test-read-line "ab" "" "ab" "cd" '(any) '(#\linefeed #\return)) +(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\return)) +(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\linefeed)) +(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\return #\linefeed)) +(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\linefeed #\return)) + +(arity-test read-line 0 2) +(error-test '(read-line 8)) +(error-test '(read-line 'any)) +(error-test '(read-line (current-input-port) 8)) +(error-test '(read-line (current-input-port) 'anyx)) + +(arity-test open-input-file 1 2) +(error-test '(open-input-file 8)) +(error-test '(open-input-file "x" 8)) +(error-test '(open-input-file "x" 'something-else)) +(error-test '(open-input-file "badfile") exn:i/o:filesystem?) + +(arity-test open-output-file 1 3) +(error-test '(open-output-file 8)) +(error-test '(open-output-file "x" 8)) +(error-test '(open-output-file "x" 'something-else)) +(let ([conflict? exn:application:mismatch?] + [modes '(binary text)] + [replacement '(error replace truncate append truncate/replace update)]) + (for-each + (lambda (ones) + (for-each + (lambda (one) + (error-test `(open-output-file "x" ',one 'bad)) + (error-test `(open-output-file "x" ',one 8)) + (error-test `(open-output-file "x" 'bad ',one)) + (error-test `(open-output-file "x" 8 ',one)) + (error-test `(call-with-output-file "x" void ',one 'bad)) + (error-test `(call-with-output-file "x" void ',one 8)) + (error-test `(call-with-output-file "x" void 'bad ',one)) + (error-test `(call-with-output-file "x" void 8 ',one)) + (error-test `(with-output-to-file "x" void ',one 8)) + (error-test `(with-output-to-file "x" void ',one 'bad)) + (error-test `(with-output-to-file "x" void 8 ',one)) + (error-test `(with-output-to-file "x" void 'bad ',one)) + (for-each + (lambda (two) + (error-test `(open-output-file "x" ',one ',two) conflict?) + (error-test `(call-with-output-file "x" void ',one ',two) conflict?) + (error-test `(with-output-to-file "x" void ',one ',two) conflict?)) + ones)) + ones)) + `(,modes ,replacement))) +(error-test '(open-output-file (build-path (current-directory) "baddir" "x")) + exn:i/o:filesystem?) + +(when (file-exists? "tmp4") + (delete-file "tmp4")) +(close-output-port (open-output-file "tmp4")) +(error-test '(let ([c (make-custodian)]) + (let ([p (parameterize ([current-custodian c]) + (open-output-file "tmp4" 'replace))]) + (custodian-shutdown-all c) + (display 'hi p))) + exn:i/o:port:closed?) +(error-test '(open-output-file "tmp4" 'error) exn:i/o:filesystem?) +(define p (open-output-file "tmp4" 'replace)) +(display 7 p) +(display "" p) +(close-output-port p) +(close-output-port (open-output-file "tmp4" 'truncate)) +(define p (open-input-file "tmp4")) +(test eof read p) +(close-input-port p) +(define p (open-output-file "tmp4" 'replace)) +(display 7 p) +(close-output-port p) +(define p (open-output-file "tmp4" 'append)) +(display 7 p) +(close-output-port p) +(error-test '(display 9 p) exn:i/o:port:closed?) +(error-test '(write 9 p) exn:i/o:port:closed?) +(error-test '(write-char #\a p) exn:i/o:port:closed?) + +(error-test '(let ([c (make-custodian)]) + (let ([p (parameterize ([current-custodian c]) + (open-input-file "tmp4"))]) + (custodian-shutdown-all c) + (read p))) + exn:i/o:port:closed?) +(define p (open-input-file "tmp4")) +(test 77 read p) +(close-input-port p) +(error-test '(read p) exn:i/o:port:closed?) +(error-test '(read-char p) exn:i/o:port:closed?) +(error-test '(char-ready? p) exn:i/o:port:closed?) + +(define p (open-output-file "tmp4" 'update)) +(display 6 p) +(close-output-port p) +(test 2 file-size "tmp4") +(define p (open-input-file "tmp4")) +(test 67 read p) +(test eof read p) +(close-input-port p) + +(define p (open-output-file "tmp4" 'update)) +(file-position p 1) +(display 68 p) +(close-output-port p) +(test 3 file-size "tmp4") +(define p (open-input-file "tmp4")) +(test 0 file-position p) +(test 668 read p) +(test 3 file-position p) +(test eof read p) +(test 3 file-position p) +(file-position p 1) +(test 1 file-position p) +(test #\6 read-char p) +(test #\8 read-char p) +(file-position p 0) +(test 0 file-position p) +(test #\6 read-char p) +(test 1 file-position p) +(file-position p 2) +(test #\8 read-char p) +(test 3 file-position p) +(close-input-port p) + +(close-output-port (open-output-file "tmp4" 'truncate/replace)) +(define p (open-input-file "tmp4")) +(test eof read p) +(close-input-port p) + +(arity-test call-with-input-file 2 3) +(arity-test call-with-output-file 2 4) +(arity-test with-input-from-file 2 3) +(arity-test with-output-to-file 2 4) + +(error-test '(call-with-input-file "x" 8)) +(error-test '(call-with-input-file 8 (lambda (x) x))) +(error-test '(call-with-input-file 8 (lambda () 9))) +(error-test '(call-with-input-file "x" (lambda (x) x) 8)) +(error-test '(call-with-input-file "x" (lambda (x) x) 'bad)) + +(error-test '(call-with-output-file "x" 8)) +(error-test '(call-with-output-file 8 (lambda (x) x))) +(error-test '(call-with-output-file 8 (lambda () 9))) +(error-test '(call-with-output-file "x" (lambda (x) x) 8)) +(error-test '(call-with-output-file "x" (lambda (x) x) 'bad)) + +(error-test '(with-input-from-file "x" 8)) +(error-test '(with-input-from-file 8 (lambda () 9))) +(error-test '(with-input-from-file 8 (lambda (x) x))) +(error-test '(with-input-from-file "x" (lambda () 9) 8)) +(error-test '(with-input-from-file "x" (lambda () 9) 'bad)) + +(error-test '(with-output-to-file "x" 8)) +(error-test '(with-output-to-file 8 (lambda () 9))) +(error-test '(with-output-to-file 8 (lambda (x) x))) +(error-test '(with-output-to-file "x" (lambda () 9) 8)) +(error-test '(with-output-to-file "x" (lambda () 9) 'bad)) + +(define s (open-output-string)) +(test #f input-port? s) +(test #t output-port? s) +(let ([c (current-output-port)]) + (current-output-port s) + (display 8) + (current-output-port c)) +(test "8" get-output-string s) +(let ([c (current-error-port)]) + (current-error-port s) + (display 9 (current-error-port)) + (current-error-port c)) +(test "89" get-output-string s) +(define s (open-input-string (get-output-string s))) +(test #t input-port? s) +(test #f output-port? s) +(test 89 + 0 + (let ([c (current-input-port)]) + (current-input-port s) + (begin0 + (read) + (current-input-port c)))) +(test eof read s) + +(arity-test open-output-string 0 0) +(arity-test open-input-string 1 1) +(arity-test get-output-string 1 1) + +(error-test '(get-output-string 9)) +(error-test '(get-output-string (current-output-port))) + +(define-values (out in) (make-pipe)) +(test #t input-port? out) +(test #t output-port? in) +(let loop ([n 1000]) + (unless (zero? n) + (display n in) + (newline in) + (loop (sub1 n)))) +(let loop ([n 999]) + (unless (zero? n) + (read out) + (loop (sub1 n)))) +(test 1 read out) +(close-output-port in) +(test eof read out) +(close-input-port out) +(arity-test make-pipe 0 0) + +(test #t input-port? (make-input-port void void void)) +(error-test '(read (make-input-port void void void)) + exn:i/o:port:user?) +(arity-test make-input-port 3 4) +(error-test '(make-input-port 8 void void)) +(error-test '(make-input-port void 8 void)) +(error-test '(make-input-port void void 8)) +(error-test '(make-input-port add1 void void)) +(error-test '(make-input-port void add1 void)) +(error-test '(make-input-port void void add1)) + +(test #t output-port? (make-output-port void void)) +(arity-test make-output-port 2 2) +(error-test '(make-output-port 8 void)) +(error-test '(make-output-port void 8)) +(error-test '(make-output-port (lambda () 9) void)) +(error-test '(make-output-port void add1)) + +(let ([p (make-input-port + (lambda () #\a) + (lambda () #t) + void + (lambda () #\b))]) + (test #\a read-char p) + (test #\b peek-char p) + (test #\a read-char p) + (test #\b peek-char p) + (test #\b peek-char p) + (test #\a read-char p) + (test 3 file-position p)) + +(let* ([s (open-input-string "(apple \"banana\" [coconut])")] + [p (make-input-port + (lambda () (read-char s)) + (lambda () #t) + void + (lambda () (peek-char s)))]) + (test '(apple "banana" [coconut]) read p)) + +(define test-file + (open-output-file "tmp2" 'truncate)) +(write-char #\; test-file) +(display write-test-obj test-file) +(newline test-file) +(write load-test-obj test-file) +(test #t output-port? test-file) +(close-output-port test-file) +(check-test-file "tmp2") + +(define ui (make-input-port (lambda () #\") (lambda () #t) void)) +(test "" read ui) +(arity-test (port-read-handler ui) 1 1) +(error-test '((port-read-handler ui) 8)) +(let ([old (port-read-handler ui)]) + (port-read-handler ui (lambda (x) "hello")) + (test "hello" read ui) + (port-read-handler ui old) + (test "" read ui)) +(arity-test port-read-handler 1 2) +(error-test '(port-read-handler 1)) +(error-test '(port-read-handler ui 8)) +(error-test '(port-read-handler (current-output-port) 8)) +(error-test '(port-read-handler ui (lambda () 9))) +(error-test '(port-read-handler ui (lambda (x y) 9))) + +(define sp (open-output-string)) +(test (void) display "hello" sp) +(test "hello" get-output-string sp) +(test (void) write "hello" sp) +(test "hello\"hello\"" get-output-string sp) +(arity-test (port-display-handler sp) 2 2) +(arity-test (port-write-handler sp) 2 2) +(arity-test (port-print-handler sp) 2 2) +(error-test '((port-display-handler sp) 8 8)) +(error-test '((port-write-handler sp) 8 8)) +(error-test '((port-print-handler sp) 8 8)) +(let ([oldd (port-display-handler sp)] + [oldw (port-write-handler sp)] + [oldp (port-print-handler sp)] + [adding (let ([s "hello\"hello\""]) + (lambda (a) + (set! s (string-append s a)) + s))]) + (port-display-handler sp (lambda (v p) (oldd "X" p) (values 1 2))) + (test (void) display "hello" sp) + (test (adding "X") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + (test (void) print "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + + (port-write-handler sp (lambda (v p) (oldd "Y" p) 5)) + (test (void) display "hello" sp) + (test (adding "X") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "Y") get-output-string sp) + (test (void) print "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + (parameterize ([global-port-print-handler display]) + (test (void) print "hello" sp) + (test (adding "X") get-output-string sp)) + (parameterize ([global-port-print-handler oldd]) + (test (void) print "hello" sp) + (test (adding "hello") get-output-string sp)) + (test (void) print "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + + + (port-print-handler sp (lambda (v p) (oldd "Z" p) 5)) + (test (void) display "hello" sp) + (test (adding "X") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "Y") get-output-string sp) + (test (void) print "hello" sp) + (test (adding "Z") get-output-string sp) + (parameterize ([global-port-print-handler display]) + (test (void) print "hello" sp) + (test (adding "Z") get-output-string sp)) + (test (void) print "hello" sp) + (test (adding "Z") get-output-string sp) + + (port-display-handler sp oldd) + (test (void) display "hello" sp) + (test (adding "hello") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "Y") get-output-string sp) + + (port-write-handler sp oldw) + (test (void) display "hello" sp) + (test (adding "hello") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + + (port-display-handler sp oldw) + (port-write-handler sp oldd) + (port-print-handler sp oldp) + (test (void) display "hello" sp) + (test (adding "\"hello\"") get-output-string sp) + (test (void) write "hello" sp) + (test (adding "hello") get-output-string sp) + (test (void) print "goodbye" sp) + (test (adding "\"goodbye\"") get-output-string sp) + (port-display-handler sp oldd) + (port-write-handler sp oldw)) +(error-test '(port-display-handler 1)) +(error-test '(port-display-handler sp 8)) +(error-test '(port-display-handler (current-input-port) 8)) +(error-test '(port-display-handler sp (lambda (x) 9))) +(error-test '(port-display-handler sp (lambda (x y z) 9))) +(error-test '(port-write-handler 1)) +(error-test '(port-write-handler sp 8)) +(error-test '(port-write-handler (current-input-port) 8)) +(error-test '(port-write-handler sp (lambda (x) 9))) +(error-test '(port-write-handler sp (lambda (x y z) 9))) + +(SECTION 6 10 4) +(load "tmp1") +(test write-test-obj 'load foo) + +(SECTION 'INEXACT-I/IO) +(define wto write-test-obj) +(define dto display-test-obj) +(define lto load-test-obj) +(define f-3.25 (string->number "-3.25")) +(define f.25 (string->number ".25")) +(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. +(set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) +(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) +(let ([f (lambda (test-file) + (write-char #\; test-file) + (display write-test-obj test-file) + (newline test-file) + (write load-test-obj test-file) + (output-port? test-file))]) + (test #t call-with-output-file + "tmp3" f 'truncate)) +(check-test-file "tmp3") +(set! write-test-obj wto) +(set! display-test-obj dto) +(set! load-test-obj lto) + +(define badc-range-start 0) +(define badc-range-end 255) + +(SECTION 'PRINTF) +(define (test-format format format-name) + (test "~" format "~~") + (test "hello---~---there" format "~a---~~---~a" "hello" 'there) + (test "\"hello\"---~---there" format "~s---~~---~s" "hello" 'there) + (test "\"hello\"---~---there" format "~v---~~---~v" "hello" 'there) + (test (string #\a #\newline #\b #\newline #\c) format "a~nb~%c") + (let ([try-newline-stuff + (lambda (newlines) + (test "12" format (apply string `(#\1 #\~ #\space ,@newlines #\space #\2))) + (test "12" format (apply string `(#\1 #\~ ,@newlines #\space #\2))) + (test "12" format (apply string `(#\1 #\~ ,@newlines #\2))) + (test (apply string `(#\1 ,@newlines #\2)) + format (apply string `(#\1 #\~ ,@newlines #\space ,@newlines #\2))))]) + (for-each try-newline-stuff '((#\return) (#\newline) (#\return #\newline)))) + (test "twenty=20..." format "twenty=~s..." 20) + (test "twenty=20..." format "twenty=~v..." 20) + (test "twenty=20..." format "twenty=~e..." 20) + (test "twenty=14..." format "twenty=~x..." 20) + (test "twenty=24..." format "twenty=~o..." 20) + (test "twenty=10100..." format "twenty=~b..." 20) + (test "zee=z..." format "zee=~c..." #\z) + + (test #\. + (lambda (s) (string-ref s (sub1 (string-length s)))) + (parameterize ([error-print-width 40]) + (format "~e" (make-string 200 #\v)))) + + (let() + (define bads + (let loop ([i badc-range-end]) + (cond + [(eq? i badc-range-start) (list (integer->char i))] + [else (let ([c (integer->char i)] + [rest (loop (sub1 i))]) + (case c + [(#\~ #\% #\n #\a #\s #\c #\o #\x #\b #\v #\e + #\N #\A #\S #\C #\O #\X #\B #\V #\E) + rest] + [else (if (char-whitespace? c) + rest + (cons c rest))]))]))) + + (define with-censor (load-relative "censor.ss")) + + ; test for all bad tags; the string we generate shouldn't + ; be printed to a terminal directly because it can contain contain + ; control characters; censor it + (unless (defined? 'building-flat-tests) + (with-censor + (lambda () + (for-each (lambda (c) + (error-test `(,@format-name ,(format "a~~~cb" c) 0))) + bads))))) + + (error-test `(,@format-name 9)) + (error-test `(,@format-name "apple~")) + (error-test `(,@format-name "~")) + (error-test `(,@format-name "~~~")) + (error-test `(,@format-name "~o") exn:application:mismatch?) + (error-test `(,@format-name "~o" 1 2) exn:application:mismatch?) + (error-test `(,@format-name "~c" 1) exn:application:mismatch?) + (error-test `(,@format-name "~x" 'a) exn:application:mismatch?) + (error-test `(,@format-name "~x" 4.0) exn:application:mismatch?) + (error-test `(,@format-name "~x" 5+4.0i) exn:application:mismatch?)) + +(test-format format '(format)) +(test-format + (lambda args + (let ([p (open-output-string)]) + (apply fprintf p args) + (get-output-string p))) + '(fprintf (current-output-port))) +(test-format + (lambda args + (let ([p (open-output-string)]) + (parameterize ([current-output-port p]) + (apply printf args)) + (get-output-string p))) + '(printf)) + +(arity-test format 1 -1) +(arity-test printf 1 -1) +(arity-test fprintf 2 -1) + +(define success-1? (putenv "APPLE" "AnApple")) +(define success-2? (putenv "BANANA" "AnotherApple")) +(error-test `(getenv 7)) +(error-test `(getenv (string #\a #\nul #\b))) +(error-test `(putenv 7 "hi")) +(error-test `(putenv "hi" 7)) +(error-test `(putenv (string #\a #\nul #\b) "hi")) +(error-test `(putenv "hi" (string #\a #\nul #\b))) +(collect-garbage) +(unless (eq? (system-type) 'macos) + (test #t 'success-1 success-1?) + (test #t 'success-2 success-2?) + (test "AnApple" getenv "APPLE") + (test "AnotherApple" getenv "BANANA")) +(test #f getenv "AnUndefinedEnvironmentVariable") + +(arity-test getenv 1 1) +(arity-test putenv 2 2) + +(arity-test read-eval-print-loop 0 0) +(test (void) 'r-e-p-l-return + (parameterize ([current-input-port (make-input-port + (lambda () eof) + void + void)]) + (read-eval-print-loop))) + +(report-errs) diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss new file mode 100644 index 00000000..ca366b27 --- /dev/null +++ b/collects/tests/mzscheme/function.ss @@ -0,0 +1,69 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'function) + +(require-library "function.ss") + +(test (list 1 2 3 4) foldl cons '() (list 4 3 2 1)) +(test (list 1 2 3 4) foldr cons '() (list 1 2 3 4)) +(test + (list (list 5 6) (list 3 4) (list 1 2)) + foldl (lambda (x y sofar) (cons (list x y) sofar)) + '() + (list 1 3 5) + (list 2 4 6)) +(test + (list (list 1 2) (list 3 4) (list 5 6)) + foldr (lambda (x y sofar) (cons (list x y) sofar)) + '() + (list 1 3 5) + (list 2 4 6)) + +(arity-test foldl 3 -1) +(arity-test foldr 3 -1) + +(test 0 (compose add1 sub1) 0) +(test 2 (compose add1 (lambda () 1))) +(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4) +(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3) +(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2)))) +(test 'ok (compose (lambda () 'ok) (lambda () (values)))) +(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5) +(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1))) + +(error-test '(compose 5)) +(error-test '(compose add1 sub1 5)) +(error-test '(compose add1 5 sub1)) +(error-test '(compose 5 add1 sub1)) +(error-test '((compose add1 (lambda () (values 1 2)))) exn:application:arity?) +(error-test '((compose add1 sub1)) exn:application:arity?) +(error-test '((compose (lambda () 1) add1) 8) exn:application:arity?) + +(arity-test compose 1 -1) + +(test '(1 2 3) filter number? '(1 a 2 b 3 c d)) +(test '() filter string? '(1 a 2 b 3 c d)) +(error-test '(filter string? '(1 2 3 . 4)) exn:application:mismatch?) +(error-test '(filter 2 '(1 2 3))) +(error-test '(filter cons '(1 2 3))) +(arity-test filter 2 2) + +(test 0 assf add1 '(0 1 2)) +(test 0 assf number? '(a 0 1 2 c)) +(test "ok" assf string? '(a 0 1 "ok" 2 c)) +(error-test '(assf cons '(1 2 3))) +(error-test '(assf string? '(1 2 3 . 4)) exn:application:mismatch?) + +(test '("a" "b" "c" "c" "d" "e" "f") + quicksort + '("d" "f" "e" "c" "a" "c" "b") + string. + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(define bad#%? + (if (defined? 'read/zodiac) + exn? + syntaxe?)) + +; Masking names shouldn't hurt the #% versions.. + +(define car 3) +(test 3 #%car (cons 3 2)) +(define car #%car) + +(let ((lambda 2)) + (test #t equal? 2 ((#%lambda (x) x) lambda))) + +; You can't mask the #% versions. + +(error-test '(define #%lambda 2) bad#%?) +(error-test '(set! #%lambda 2) bad#%?) + +; We allow random #% things to be set!'ed and define'd. + +(test #t equal? (void) (eval '(define #%foo 3))) +(test #t equal? 4 (begin (set! #%foo 4) #%foo)) + +; But you can't bind #% things either. + +(error-test '(let ((#%car 3)) 3) syntaxe?) +(error-test '(let ((#%lambda 3)) 3) syntaxe?) + +; Let's try out all #% syntax to make sure it's immune. (We'll skip +; the macro stuff.) + +(map (lambda (s) + (error-test `(define ,s 3) bad#%?) + (error-test `(set! ,s 3) bad#%?)) + '(#%lambda #%let-values #%letrec-values #%define-values #%quote + #%if #%begin #%set! #%begin0 #%case-lambda #%struct)) + +; And a few primitives, for good measure. + +(map (lambda (s) + (error-test `(define ,s 3) bad#%?) + (error-test `(set! ,s 3) bad#%?)) + '(#%car #%cdr #%cons)) + +(newline) +(newline) + +; (printf "Done with #% test suite!~n~n") + +(report-errs) diff --git a/collects/tests/mzscheme/image.ss b/collects/tests/mzscheme/image.ss new file mode 100644 index 00000000..41219f06 --- /dev/null +++ b/collects/tests/mzscheme/image.ss @@ -0,0 +1,32 @@ + +; Tests image saving/loading by dumping an image +; and loading it with every report-errs + +(define dump/restore + (lambda () + (printf "Dumping image...~n") + (let ([result (write-image-to-file "tmp9")]) + (if (vector? result) + (printf "Continuing ~a~n" result) + (read-image-from-file "tmp9" #("after" "restore")))))) + +(define ll null) +(define load-relative + (lambda (f) + (set! ll (append ll (list f))))) + +(#%load-relative "all.ss") + +(define load-relative #%load-relative) + +(define go + (let ([d (current-load-relative-directory)]) + (lambda () + (parameterize ([current-load-relative-directory d]) + (for-each + (lambda (f) + (load-relative f) + (dump/restore)) + ll))))) + +(printf "Run `(go)'~n") diff --git a/collects/tests/mzscheme/ktest.ss b/collects/tests/mzscheme/ktest.ss new file mode 100644 index 00000000..86d2d0dd --- /dev/null +++ b/collects/tests/mzscheme/ktest.ss @@ -0,0 +1,11 @@ +(define k + (call-with-current-continuation + (lambda (exit) + (let loop ((n 60000)) + (if (zero? n) + (let ((v (call-with-current-continuation (lambda (k) k)))) + (if (number? v) + v + (exit v))) + (- (loop (- n 1)) 1)))))) + diff --git a/collects/tests/mzscheme/loadable.ss b/collects/tests/mzscheme/loadable.ss new file mode 100644 index 00000000..eb943a3f --- /dev/null +++ b/collects/tests/mzscheme/loadable.ss @@ -0,0 +1 @@ +"This is a simple file used by param.ss" diff --git a/collects/tests/mzscheme/loop.ss b/collects/tests/mzscheme/loop.ss new file mode 100644 index 00000000..18fde593 --- /dev/null +++ b/collects/tests/mzscheme/loop.ss @@ -0,0 +1,29 @@ + + +(define five +) + +(define (one v) + (if (equal? v 15) + (apply five (list 1 2 3 4 5)) + 15)) + +(define (dloop x d) + (if (zero? d) + 0 + (if (equal? x 15) + (let ([v (one 10)]) + (let ([c (one v)]) + (add1 (dloop c (sub1 d))))) + (dloop 15 d)))) + +(define (loop) + (let loop ([n 0]) + (let ([v (dloop 0 n)]) + (if (equal? n v) + (begin + (when (zero? (modulo n 100)) + (printf "~a~n" n)) + (loop (add1 n))) + (error 'loop "messed up: ~a != ~a~n" n v))))) + + diff --git a/collects/tests/mzscheme/ltest.ss b/collects/tests/mzscheme/ltest.ss new file mode 100644 index 00000000..5765a97c --- /dev/null +++ b/collects/tests/mzscheme/ltest.ss @@ -0,0 +1,88 @@ +(printf "nested loop~n") +(time + (let loop ([n 10000]) + (unless (zero? n) + (let loop2 ([m 10]) + (if (zero? m) + (loop (sub1 n)) + (loop2 (sub1 m))))))) + +(printf "single loop~n") +(time + (let loop ([n 100000]) + (unless (zero? n) + (loop (sub1 n))))) + +(printf "Y loop~n") +(time + ((lambda (f n) (f f n)) + (lambda (loop n) + (unless (zero? n) + (loop loop (sub1 n)))) + 100000)) + + +(printf "let closure recur~n") +(time + (let ([f (lambda (x) (sub1 x))]) + (let loop ([n 100000]) + (unless (zero? n) + (loop (f n)))))) + +(printf "direct closure recur~n") +(time + (let loop ([n 100000]) + (unless (zero? n) + (loop ((lambda (x) (sub1 x)) n))))) + +(printf "direct closure recur if~n") +(time + (let loop ([n 100000]) + (if (zero? n) + (void) + (loop ((lambda (x) (sub1 x)) n))))) + +(printf "let closure top-level~n") +(define loop + (let ([f (lambda (x) (sub1 x))]) + (lambda (n) + (unless (zero? n) + (loop (f n)))))) +(time (loop 100000)) + +(printf "direct closure top-level~n") +(define loop + (lambda (n) + (unless (zero? n) + (loop ((lambda (x) (sub1 x)) n))))) +(time (loop 100000)) + + +; > (load "ltest.ss") +; cpu time: 1820 real time: 1826 +; cpu time: 1420 real time: 1422 +; cpu time: 1960 real time: 1957 +; cpu time: 2630 real time: 2626 +; > (load "ltest.ss") +; cpu time: 1790 real time: 1803 +; cpu time: 1430 real time: 1468 +; cpu time: 2150 real time: 2159 +; cpu time: 2820 real time: 2824 + +; > (load "ltest.ss") +; nested loop +; cpu time: 1750 real time: 1817 +; single loop +; cpu time: 1430 real time: 1425 +; Y loop +; cpu time: 1500 real time: 1500 +; let closure recur +; cpu time: 1830 real time: 1835 +; direct closure recur +; cpu time: 1790 real time: 1791 +; direct closure recur if +; cpu time: 1800 real time: 1793 +; let closure top-level +; cpu time: 1810 real time: 1804 +; direct closure top-level +; cpu time: 1760 real time: 1758 diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss new file mode 100644 index 00000000..3b752fff --- /dev/null +++ b/collects/tests/mzscheme/macro.ss @@ -0,0 +1,35 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + + +(SECTION 'MACRO) + +(define-macro mx + (lambda (x) + (list x 1 8))) +(test 9 'macro (mx +)) +(test -7 'macro (mx -)) +(test 18 'macro (let ([mx (lambda (x) (x 1 8 9))]) (mx +))) +(when (defined? 'let-macro) + (teval '(test 13 'let-macro (let-macro mx (lambda (x) (list x 6 7)) (mx +)))) + (teval '(test -7 'let-macro (let-macro mx2 (lambda (x y) (list 'mx y)) (mx2 + -)))) + (teval '(test '(10) 'let-macro ((lambda () (let-macro x (lambda x (cons 'list x)) (x 10)))))) + (teval '(test '(10) 'let-macro (let () (define-macro x (lambda x (cons 'list x))) (x 10)))) + ; (test '(10) eval '((lambda () (define-macro x (lambda x (cons 'list x))) (x 10)))) + ) + +(define a-global-var 1) +(define-macro a-macro (lambda () a-global-var)) +(test 1 'macro (a-macro)) + +(when (defined? 'let-macro) + (teval '(define (defmacro-test) + (define-macro define-alias (lambda (x y) `(define ,x ,y))) + (test 45 'define + (let ((x 5)) + (define-alias foo (lambda (y) (bar x y))) + (define-alias bar (lambda (a b) (+ (* a b) a))) + (foo (+ x 3))))))) + +(report-errs) diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss new file mode 100644 index 00000000..1a7803b3 --- /dev/null +++ b/collects/tests/mzscheme/macrolib.ss @@ -0,0 +1,195 @@ + +(if (not (defined? 'SECTION)) + (load "testing.ss")) + +(SECTION 'macrolib) + +(require-library "macro.ss") + +(let ([u (letrec ([x x]) x)]) + (let ([l1 + (let+ ([rec a a] + [recs [b c] [c b]] + [rec d 1] + [val e 1] + [val x 1] + [val y 2] + [vals (x y) (y x)] + [rec (values f) (values 1)] + [vals [(values g h) (values 2 3)]] + [val i 3] + [_ (set! i 4) + (set! i 5)]) + 'x + (list a b c d e x y f g h i))] + [l2 (list u u u 1 1 2 1 1 2 3 5)]) + (test l1 'let-plus l2))) + +(require-library "shared.ss") + +(test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) # 3 3)" + 'shared + (let ([s (open-output-string)]) + (display + (shared ((a (cons 'car 'cdr)) + (b (vector 'one 'two 'three 'four 'five 'six)) + (c (box 'box)) + (d (list 'list1 'list2 'list3 'list4)) + (e (make-weak-box 'weak-box)) + (f (+ 1 2)) + (g 3)) + (list a b c d e f g)) + s) + (get-output-string s))) + +(test 'hi 'local (local () 'hi)) +(define x 7) +(test 6 'local (local ((define x 6)) x)) +(test 7 'local x) +(test 6 vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1) +(test #t 'local (local [(define o (lambda (x) (if (zero? x) #f (e (sub1 x))))) + (define e (lambda (x) (if (zero? x) #t (o (sub1 x)))))] + (e 10))) +(test 'second 'local (local ((define x 10) (define u 'second)) (cons x 1) u)) +(test-values '(4 6) (lambda () (local ((define y 6) (define x 4)) (values x y)))) +(test 10 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) (y)))) +(test 5 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) x))) +(test 8 'local (let ([lambda 9]) (local [(define lambda 8)] lambda))) +(test 9 'local (let ([lambda 10]) (local [(define lambda 9) (define lambda2 lambda)] lambda2))) +(test 19 'local (local [(define lambda 19) (define lambda2 lambda)] lambda2)) +(test 1 'local (local ((define-values (a b c) (values 1 2 3))) a)) +(test 1 (lambda () (local ((define-values (a b c) (values 1 2 3))) a))) +(test 8 'local (local [(define lambda 8)] lambda)) +(test 12 'local (local [(define (f y) (add1 y))] (f 11))) +(test 120 'local (local [(define (f y) 'ignore-me (add1 y))] (f 119))) +(test 17 'local (local [(define-values (apple b) (values 12 17))] b)) +(test 4 'local (local [(define-struct cons (car cdr))] (cons-car (make-cons 4 5)))) +(test 40 'local (local [(define-struct (cons struct:exn) (car cdr))] (cons-car (make-cons "" (void) 40 50)))) +(syntax-test '(local)) +(syntax-test '(local . 1)) +(syntax-test '(local ())) +(syntax-test '(local () . 1)) +(syntax-test '(local 1 1)) +(syntax-test '(local (1) 1)) +(syntax-test '(local (x) 1)) +(syntax-test '(local ((+ 1 2)) 1)) +(syntax-test '(local ((define x)) 1)) +(syntax-test '(local ((define x 4) (+ 1 2)) 1)) +(syntax-test '(local ((define x 4) (+ 1 2) (define y 10)) 1)) +(syntax-test '(local ((define (x 8) 4)) 1)) +(syntax-test '(local ((define (x . 8) 4)) 1)) +(syntax-test '(local ((define x 8 4)) 1)) +(syntax-test '(local ((define 1 8 4)) 1)) +(syntax-test '(let ([define 10]) (local ((define x 4)) 10))) +(syntax-test '(let ([define-values 10]) (local ((define-values (x) 4)) 10))) +(syntax-test '(let ([define-struct 10]) (local ((define-struct x ())) 10))) + +(for-each syntax-test + (list '(evcase) + '(evcase 1 (a)) + '(evcase 1 (a b) a) + '(evcase 1 (a . b) a) + '(evcase 1 [else 5] [1 10]))) +(define => 17) +(test (void) 'void-evcase (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1))) +(define save-comp (compile-allow-cond-fallthrough)) +(compile-allow-cond-fallthrough #f) +(test #t andmap (lambda (x) (= x 17)) + (list + (evcase 3 [3 17]) + (evcase 3 [(+ 1 2) 17] [3 1]) + (evcase 3 [3 4 5 17]) + (evcase 3 [4 1] [3 4 5 17]) + (evcase 3 [4 1 2 3 4] [3 4 5 17]) + (evcase 3 [4 4] [2 10] [else 17]) + (let ([else 10]) (evcase 3 [4 4] [2 10] [else 15] [3 17])) + (let ([else 3]) (evcase 3 [else 17] [2 14])) + (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1)) + (evcase 3 [3 =>]) + (evcase 3 [3 => 17]) + (let ([=> 12]) (evcase 3 [3 => 17])) + (let ([=> 17]) (evcase 3 [3 =>])))) +(compile-allow-cond-fallthrough save-comp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require-library "invoke.ss") + +(define make-z + (lambda (x-val) + (unit + (import z) + (export (x z) y) + + (define x x-val) + (define y (lambda () (- z x)))))) + +(define z1 (make-z 8)) +(define z2 (make-z 7)) + +(define m3 + (compound-unit + (import) + (link [Z1 (z1 (Z2 z))][Z2 (z2 (Z1 z))]) + (export [Z1 (y y1) (z x1)][Z2 (y y2) (z x2)]))) + +(define-values/invoke-unit (y1 x1 y2 x2) m3) +(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2)) + +; Linking environments + +(when (defined? 'x) + (undefine 'x)) + +(define (make--eval) + (let ([n (make-namespace)]) + (lambda (e) + (let ([orig (current-namespace)]) + (dynamic-wind + (lambda () (current-namespace n)) + (lambda () + (require-library "invoke.ss") + (eval e)) + (lambda () (current-namespace orig))))))) + +(define u + (unit + (import) + (export x) + (define x 5))) +(define e (make--eval)) +(e (list 'define-values/invoke-unit '(x) u #f)) +(test #f defined? 'x) +(test #t e '(defined? 'x)) + +(define u2 + (let ([u u]) + (unit + (import) + (export) + (global-define-values/invoke-unit (x) u #f)))) +(define e (make--eval)) +(e (list 'define-values/invoke-unit '() u2 #f)) +(test #f defined? 'x) +(test #t e '(defined? 'x)) + + +; Export var from embedded unit: + +(define-signature e ((unit w : (embedded-v)))) +(define-values/invoke-unit/sig (embedded-v) + (compound-unit/sig + (import) + (link [E : e ((compound-unit/sig + (import) + (link [w : (embedded-v) ((unit/sig (embedded-v) + (import) + (define embedded-v 0)))]) + (export (unit w))))]) + (export (var ((E w) embedded-v))))) +(test 0 'embedded-v embedded-v) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(report-errs) + diff --git a/collects/tests/mzscheme/makeflat.ss b/collects/tests/mzscheme/makeflat.ss new file mode 100644 index 00000000..73ca6755 --- /dev/null +++ b/collects/tests/mzscheme/makeflat.ss @@ -0,0 +1,60 @@ + +(unless (defined? 'flat-load) + (global-defined-value 'flat-load "all.ss")) +(unless (defined? 'lines-per-file) + (global-defined-value 'lines-per-file +inf.0)) + +(require-library "pretty.ss") + + +(define line-count 0) +(define file-count 0) + +(define flatp (open-output-file "flat.ss" 'replace)) +(define old-eval (current-eval)) +(define old-namespace (current-namespace)) + +(pretty-print '(define error-test void) flatp) +(pretty-print '(define building-flat-tests #t) flatp) +(pretty-print '(define section #f) flatp) + +(define (flat-pp v) + (pretty-print v flatp) + (set! line-count (add1 line-count)) + (when (>= line-count lines-per-file) + (set! line-count 0) + (set! file-count (add1 file-count)) + (close-output-port flatp) + (set! flatp + (open-output-file + (format "flat~a.ss" file-count) + 'replace)))) + +(define error-test + (case-lambda + [(expr) (error-test expr #f)] + [(expr exn?) + (unless (eq? exn? exn:syntax?) + (flat-pp `(thunk-error-test (lambda () ,expr) + (quote ,expr) + ,@(if exn? + (list (string->symbol + (primitive-name + exn?))) + null))))])) + +(define building-flat-tests #t) + +(dynamic-wind + (lambda () + (current-eval + (lambda (e) + (unless (or (and (pair? e) + (memq (car e) '(load load-relative error-test))) + (not (eq? (current-namespace) old-namespace))) + (flat-pp e)) + (old-eval e)))) + (lambda () + (load-relative flat-load)) + (lambda () + (current-eval old-eval))) diff --git a/collects/tests/mzscheme/multi-expand.ss b/collects/tests/mzscheme/multi-expand.ss new file mode 100644 index 00000000..07393b16 --- /dev/null +++ b/collects/tests/mzscheme/multi-expand.ss @@ -0,0 +1,82 @@ +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(define counter 0) +(define-macro counterM (lambda () (set! counter (add1 counter)) 88)) + +(let* ([test-counter + (lambda (sexp) + (set! counter 0) + (eval sexp) + counter)]) + (test 1 test-counter '(begin0 1 (begin (counterM)))) + (test 1 test-counter '(begin0 (begin (counterM)))) + (test 1 test-counter '(lambda () + (counterM) + 1)) + (test 2 test-counter '(lambda () + (counterM) + (counterM) + 1)) + (test 2 test-counter '(lambda () + (define x (counterM)) + (define y (counterM)) + 1)) + (test 2 test-counter '(lambda () + (lambda () (counterM)) + (lambda () (counterM)) + 1)) + (test 1 test-counter '(lambda () + (begin (counterM)) + 1)) + (test 2 test-counter '(lambda () + (begin (counterM)) + (begin (counterM)) + 1)) + (test 3 test-counter '(lambda () + (begin (counterM)) + (begin (counterM)) + (begin (counterM)) + 1)) + (test 1 test-counter '(cond [1 (begin (counterM))])) + (test 1 test-counter '(begin (cond [1 (counterM)]))) + (test 1 test-counter '(begin0 (cond [1 (counterM)]) 1)) + (test 1 test-counter '(let () (begin (counterM)))) + (test 1 test-counter '(begin (let () (counterM)))) + (test 1 test-counter '(begin0 (let () (counterM)) 1)) + + (test 1 test-counter '(unit (import) (export) (counterM))) + (test 2 test-counter '(unit (import) (export) (counterM) (counterM))) + (test 1 test-counter '(unit (import) (export) (begin (counterM)))) + (test 2 test-counter '(unit (import) (export) (begin (counterM)) (begin (counterM)))) + (test 1 test-counter '(unit (import) (export) (begin0 (counterM)))) + (test 2 test-counter '(unit (import) (export) (begin0 (counterM)) (begin (counterM)))) + (test 1 test-counter '(unit (import) (export) (unit (import) (export) (counterM)))) + + + (test 1 test-counter '(begin (unit (import) (export) (counterM)))) + (test 2 test-counter '(begin (unit (import) (export) (counterM) (counterM)))) + (test 1 test-counter '(begin (unit (import) (export) (begin (counterM))))) + (test 2 test-counter '(begin (unit (import) (export) (begin (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin (unit (import) (export) (begin0 (counterM))))) + (test 2 test-counter '(begin (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin (unit (import) (export) (unit (import) (export) (counterM))))) + + (test 1 test-counter '(begin0 (unit (import) (export) (counterM)))) + (test 2 test-counter '(begin0 (unit (import) (export) (counterM) (counterM)))) + (test 1 test-counter '(begin0 (unit (import) (export) (begin (counterM))))) + (test 2 test-counter '(begin0 (unit (import) (export) (begin (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin0 (unit (import) (export) (begin0 (counterM))))) + (test 2 test-counter '(begin0 (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin0 (unit (import) (export) (unit (import) (export) (counterM))))) + + (test 1 test-counter '(begin0 1 (unit (import) (export) (counterM)))) + (test 2 test-counter '(begin0 1 (unit (import) (export) (counterM) (counterM)))) + (test 1 test-counter '(begin0 1 (unit (import) (export) (begin (counterM))))) + (test 2 test-counter '(begin0 1 (unit (import) (export) (begin (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin0 1 (unit (import) (export) (begin0 (counterM))))) + (test 2 test-counter '(begin0 1 (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) + (test 1 test-counter '(begin0 1 (unit (import) (export) (unit (import) (export) (counterM))))) +) + +(report-errs) diff --git a/collects/tests/mzscheme/mzlib.ss b/collects/tests/mzscheme/mzlib.ss new file mode 100644 index 00000000..184b8503 --- /dev/null +++ b/collects/tests/mzscheme/mzlib.ss @@ -0,0 +1,32 @@ + +; Test MzLib +; See also pptest.ss and ztest.ss + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(load-relative "function.ss") + +(load-relative "date.ss") + +(load-relative "cmdline.ss") + +(load-relative "pconvert.ss") + +(load-relative "pretty.ss") + +(load-relative "classd.ss") + +; Last - so macros are not present by accident +(load-relative "macrolib.ss") + +(require-library "core.ss") +(test #t 'invoke-core-in-#%-space + (begin + (let ([l (require-library "corer.ss")]) + (parameterize ([current-namespace (make-namespace 'hash-percent-syntax)]) + (invoke-unit/sig l))) + #t)) + + +(report-errs) diff --git a/collects/tests/mzscheme/mzthr.ss b/collects/tests/mzscheme/mzthr.ss new file mode 100644 index 00000000..18b4f51e --- /dev/null +++ b/collects/tests/mzscheme/mzthr.ss @@ -0,0 +1,75 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'mzlib-threads) + +(require-library "thread.ss") + +(define sema (make-semaphore)) +(define sema2 (make-semaphore)) +(define c-out 0) +(define SLEEP-TIME 0.1) + +;;; consumer-thread ;;; + +(define-values (th g) (consumer-thread (case-lambda + [(f arg) (set! c-out (f arg)) + (semaphore-post sema)] + [(f arg1 arg2) (set! c-out (f arg1 arg2)) + (semaphore-post sema)]))) +(g + 1 2) +(semaphore-wait sema) +(test 3 'consumer-thread c-out) + +; queue 2 +(g car '(4 5)) +(g semaphore-wait sema2) +(semaphore-wait sema) +(test 4 'consumer-thread c-out) +(semaphore-post sema2) +(semaphore-wait sema) +(test (void) 'consumer-thread c-out) + +; queue 3 +(g / 2) +(g semaphore-wait sema2) +(g (lambda (s) (semaphore-wait s) 5) sema2) +(semaphore-wait sema) +(test 1/2 'consumer-thread c-out) +(semaphore-post sema2) +(semaphore-wait sema) +(test (void) 'consumer-thread c-out) +(semaphore-post sema2) +(semaphore-wait sema) +(test 5 'consumer-thread c-out) + +; kill the consumer +(kill-thread th) +(g - 7) +(sleep SLEEP-TIME) +(test 5 'consumer-thread c-out) + +(arity-test consumer-thread 1 2) +(error-test '(consumer-thread 9)) +(arity-test g 2 3) + +;;; semaphore-wait-multiple ;;; + +(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) +(semaphore-post sema) +(test sema semaphore-wait-multiple (list sema sema2)) +(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) +(semaphore-post sema2) +(test sema2 semaphore-wait-multiple (list sema sema2)) +(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) +(semaphore-post sema) +(semaphore-post sema2) +(let ([first (semaphore-wait-multiple (list sema sema2))]) + (test #t semaphore? first) + (test (if (eq? first sema) sema2 sema) semaphore-wait-multiple (list sema sema2))) +(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) + +(arity-test semaphore-wait-multiple 1 3) + +(report-errs) diff --git a/collects/tests/mzscheme/name.ss b/collects/tests/mzscheme/name.ss new file mode 100644 index 00000000..9f2b34bd --- /dev/null +++ b/collects/tests/mzscheme/name.ss @@ -0,0 +1,105 @@ + +; Test MzScheme's name inference + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'NAMES) + +(arity-test inferred-name 1 1) +(test #f inferred-name 0) +(test #f inferred-name 'hello) +(test #f inferred-name "hi") + +; Test ok when no name for proc +(test #f inferred-name (lambda () 0)) +(test #f inferred-name (case-lambda)) +(test #f inferred-name (case-lambda [(x) 9])) +(test #f inferred-name (case-lambda [(x) 9][(y z) 12])) + +; Test constructs that don't provide a name +(test #f inferred-name (let ([x (cons (lambda () 10) 0)]) (car x))) +(test #f inferred-name (let ([x (let ([y (lambda (x) x)]) (y (lambda () 10)))]) x)) + +; Test ok when name for proc +(define f (lambda () 0)) +(define f2 (lambda (a) 0)) +(define f3 (case-lambda)) +(define f4 (case-lambda [(x) 9])) +(define f5 (case-lambda [(x) 9][(y z) 10])) + +(test 'f inferred-name f) +(test 'f2 inferred-name f2) +(test 'f3 inferred-name f3) +(test 'f4 inferred-name f4) +(test 'f5 inferred-name f5) + +; Test constructs that do provide a name +(test 'a inferred-name (let ([a (lambda () 0)]) a)) +(test 'a inferred-name (let ([a (lambda () 0)]) (let ([b a]) b))) +(test 'b inferred-name (let* ([b (lambda () 0)]) b)) +(test 'c inferred-name (letrec ([c (lambda () 0)]) c)) +(test 'loop inferred-name (let loop () loop)) + +(test 'd inferred-name (let ([d (begin (lambda () x))]) d)) +(test 'e inferred-name (let ([e (begin0 (lambda () x))]) e)) + +(test 'd2 inferred-name (let ([d2 (begin 7 (lambda () x))]) d2)) +(test 'e2 inferred-name (let ([e2 (begin0 (lambda () x) 7)]) e2)) + +(test 'd3 inferred-name (let ([d3 (begin (cons 1 2) (lambda () x))]) d3)) +(test 'e3 inferred-name (let ([e3 (begin0 (lambda () x) (cons 1 2))]) e3)) + +(test 'f inferred-name (let ([f (begin0 (begin (cons 1 2) (lambda () x)) (cons 1 2))]) f)) + +(test 'g1 inferred-name (let ([g1 (if (cons 1 2) (lambda () x) #f)]) g1)) +(test 'g2 inferred-name (let ([g2 (if (negative? (car (cons 1 2))) #t (lambda () x))]) g2)) + +(test 'w inferred-name (let ([w (let ([x 5]) (lambda () x))]) w)) +(test 'z inferred-name (let ([z (let ([x 5]) (cons 1 2) (lambda () x))]) z)) + +(set! f (lambda () 10)) +(test 'f inferred-name f) + +; Test class stuff ok when no name +(test #f inferred-name (class object% () (sequence (super-init)))) +(test #f inferred-name (interface ())) + +; Test class stuff ok when name +(test 'c1 inferred-name (let ([c1 (class object% () (sequence (super-init)))]) c1)) +(test 'i1 inferred-name (let ([i1 (interface ())]) i1)) +(test 'm inferred-name + (ivar + (make-object + (class object% () + (public + [m (lambda () 10)]) + (sequence (super-init)))) + m)) + ; Use external name: +(test 'mex inferred-name + (ivar + (make-object + (class object% () + (public + [(m mex) (lambda () 10)]) + (sequence (super-init)))) + mex)) + +; Test unit stuff ok when no name +(test #f inferred-name (unit (import) (export))) +(test #f inferred-name (compound-unit (import) (link) (export))) + +; Test class stuff ok when name +(test 'u1 inferred-name (let ([u1 (unit (import) (export))]) u1)) +(test 'u2 inferred-name (let ([u2 (compound-unit (import) (link) (export))]) u2)) + +(test 'x inferred-name (invoke-unit + (unit (import) (export) (define x (lambda () 0)) x))) +(test 'x2 inferred-name (invoke-unit + (unit (import) (export x2) (define x2 (lambda () 0)) x2))) + ; Use external name: +(test 'x3 inferred-name (invoke-unit + (unit (import) (export (x x3)) (define x (lambda () 0)) x))) + +(report-errs) diff --git a/collects/tests/mzscheme/namespac.ss b/collects/tests/mzscheme/namespac.ss new file mode 100644 index 00000000..78da0ddb --- /dev/null +++ b/collects/tests/mzscheme/namespac.ss @@ -0,0 +1,104 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'namespaces) + +(define flag-map + (list (list 'keywords + 'no-keywords + '(#%let ([#%lambda 7]) (void)) + exn:syntax? + #f) + (list 'call/cc=call/ec + 'call/cc!=call/ec + '((call/cc (#%lambda (x) x)) void) + exn:application:continuation? + #f) + (list 'hash-percent-syntax + 'all-syntax + '(if #t (void)) + exn:variable? + #f))) + +(define (do-one-by-one more less) + (let loop ([n (length flag-map)]) + (unless (zero? n) + (let ([test-info + (let loop ([l flag-map][p 1]) + (if (null? l) + '() + (let* ([g (car l)] + [g++ (cdddr g)]) + (cons + (cond + [(= p n) (cons (less g) (less g++))] + [else (cons (more g) (more g++))]) + (loop (cdr l) (add1 p))))))]) + (let* ([flags (map car test-info)] + [namespace (apply make-namespace flags)]) + (printf "trying: ~s~n" flags) + (let loop ([tests (map caddr flag-map)] + [results (map cdr test-info)]) + (if (null? results) + '() + (begin + (if (car results) + (error-test + `(with-handlers ([(#%lambda (x) #f) void]) ; outside parameterize re-raises exns after escaping + (parameterize ([current-namespace ,namespace]) + (eval ',(car tests)))) + (car results)) + (with-handlers ([(lambda (x) #f) void]) + (parameterize ([current-namespace namespace]) + (test (void) eval (car tests))))) + (loop (cdr tests) (cdr results))))))) + (loop (sub1 n))))) + +(unless (defined? 'building-flat-tests) + (do-one-by-one car cadr) + (do-one-by-one cadr car)) + +; Test primitive-name +(let ([gvl (parameterize ([current-namespace (make-namespace)]) (make-global-value-list))] + [aliases (list (cons "call/cc" "call-with-current-continuation") + (cons "call/ec" "call-with-escape-continuation") + (cons "interaction-environment" "current-namespace") + (cons "unit/sig?" "unit-with-signature?") + (cons "unit/sig->unit" "unit-with-signature-unit") + (cons "unit-with-signature->unit" "unit-with-signature-unit"))]) + (test #t 'names + (andmap + (lambda (nv-pair) + (let ([name (car nv-pair)] + [value (cdr nv-pair)]) + (or (not (primitive? value)) + (let* ([s (symbol->string name)] + [sr (if (char=? #\# (string-ref s 0)) + (substring s 2 (string-length s)) + s)] + [st (let ([m (assoc sr aliases)]) + (if m + (cdr m) + sr))]) + (or (equal? st (primitive-name value)) + (and (fprintf (current-error-port) + "different: ~a ~a~n" st (primitive-name value)) + #f)))))) + gvl))) + +(define (test-empty . flags) + (let ([e (apply make-namespace flags)]) + (parameterize ([current-namespace e]) + (test null make-global-value-list) + (test 'unbound 'empty-namespace + (with-handlers ([void (lambda (exn) 'unbound)]) + (eval 'car))) + (test 'unbound 'empty-namespace + (with-handlers ([void (lambda (exn) 'unbound)]) + (eval '#%car))) + (global-defined-value 'hello 5) + (test 5 'empty-namespace (eval 'hello)) + (test '((hello . 5)) make-global-value-list)))) +(test-empty 'empty) +(apply test-empty (append '(empty) (map car flag-map) (map cadr flag-map))) diff --git a/collects/tests/mzscheme/nch.ss b/collects/tests/mzscheme/nch.ss new file mode 100644 index 00000000..45398e6f --- /dev/null +++ b/collects/tests/mzscheme/nch.ss @@ -0,0 +1,30 @@ + +(define (fact n) + (if (zero? n) + 1 + (* n (fact (- n 1))))) + +(define f1000 (fact 1000)) + +(define (divall n d) + (if (<= n 1) + d + (divall (/ n d) (+ 1 d)))) + +(define (nch n c) + (/ (fact n) (fact (- n c)) (fact c))) + +(define (snch n) + (letrec ((loop + (lambda (i) + (if (> i n) + 0 + (+ (nch n i) (loop (+ i 1))))))) + (loop 0))) + +(define (fsum n) + (if (zero? n) + 1 + (+ (fact n) (fsum (- n 1))))) + + diff --git a/collects/tests/mzscheme/number.ss b/collects/tests/mzscheme/number.ss new file mode 100644 index 00000000..9090f806 --- /dev/null +++ b/collects/tests/mzscheme/number.ss @@ -0,0 +1,1797 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'numbers) + +(SECTION 6 5 5) +(test #f number? 'a) +(test #f complex? 'a) +(test #f real? 'a) +(test #f rational? 'a) +(test #f integer? 'a) + +(test #t number? 3) +(test #t complex? 3) +(test #t real? 3) +(test #t rational? 3) +(test #t integer? 3) + +(test #t number? 3.0) +(test #t complex? 3.0) +(test #t real? 3.0) +(test #t rational? 3.0) +(test #t integer? 3.0) + +(test #t number? 3.1) +(test #t complex? 3.1) +(test #t real? 3.1) +(test #t rational? 3.1) +(test #f integer? 3.1) + +(test #t number? 3/2) +(test #t complex? 3/2) +(test #t real? 3/2) +(test #t rational? 3/2) +(test #f integer? 3/2) + +(test #t number? 3+i) +(test #t complex? 3+i) +(test #f real? 3+i) +(test #f rational? 3+i) +(test #f integer? 3+i) + +(test #t number? 3.0+0i) +(test #t complex? 3.0+0i) +(test #t real? 3.0+0i) +(test #t rational? 3.0+0i) +(test #t integer? 3.0+0i) + +(test #t number? 3.0+0.0i) +(test #t complex? 3.0+0.0i) +(test #t real? 3.0+0.0i) +(test #t rational? 3.0+0.0i) +(test #t integer? 3.0+0.0i) + +(test #t number? 3.1+0.0i) +(test #t complex? 3.1+0.0i) +(test #t real? 3.1+0.0i) +(test #t rational? 3.1+0.0i) +(test #f integer? 3.1+0.0i) + +(test #t exact? 3) +(test #t exact? 3/4) +(test #f exact? 3.0) +(test #t exact? (expt 2 100)) +(test #t exact? 3+4i) +(test #f exact? 3.0+4i) + +(test #f inexact? 3) +(test #f inexact? 3/4) +(test #t inexact? 3.0) +(test #f inexact? (expt 2 100)) +(test #f inexact? 3+4i) +(test #t inexact? 3.0+4i) +(test #t inexact? 0+4.0i) +(test #t inexact? 4+0.i) + +(test #t complex? -4.242154731064108e-5-6.865001427422244e-5i) +(test #f exact? -4.242154731064108e-5-6.865001427422244e-5i) +(test #t inexact? -4.242154731064108e-5-6.865001427422244e-5i) + +(test #t complex? -4.242154731064108f-5-6.865001427422244f-5i) +(test #f exact? -4.242154731064108f-5-6.865001427422244f-5i) +(test #t inexact? -4.242154731064108f-5-6.865001427422244f-5i) + +(test #t number? +inf.0) +(test #t complex? +inf.0) +(test #t real? +inf.0) +(test #t rational? +inf.0) +(test #t integer? +inf.0) + +(test #t number? -inf.0) +(test #t complex? -inf.0) +(test #t real? -inf.0) +(test #t rational? -inf.0) +(test #t integer? -inf.0) + +(test #t number? +nan.0) +(test #t complex? +nan.0) +(test #t real? +nan.0) +(test #t rational? +nan.0) +(test #f integer? +nan.0) + +(arity-test inexact? 1 1) +(arity-test number? 1 1) +(arity-test complex? 1 1) +(arity-test real? 1 1) +(arity-test rational? 1 1) +(arity-test integer? 1 1) +(arity-test exact? 1 1) +(arity-test inexact? 1 1) + +(error-test '(exact? 'a)) +(error-test '(inexact? 'a)) + +(test "+inf.0" number->string +inf.0) +(test "-inf.0" number->string -inf.0) +(test "+nan.0" number->string +nan.0) +(test "+nan.0" number->string +nan.0) + +(test #t = 0.0 -0.0) +(test #f eqv? 0.0 -0.0) + +(test #t = 0) +(test #t > 0) +(test #t < 0) +(test #t >= 0) +(test #t <= 0) +(test #t = 22 22 22) +(test #t = 22 22) +(test #f = 34 34 35) +(test #f = 34 35) +(test #t > 3 -6246) +(test #f > 9 9 -2424) +(test #t >= 3 -4 -6246) +(test #t >= 9 9) +(test #f >= 8 9) +(test #t < -1 2 3 4 5 6 7 8) +(test #f < -1 2 3 4 4 5 6 7) +(test #t <= -1 2 3 4 5 6 7 8) +(test #t <= -1 2 3 4 4 5 6 7) +(test #f < 1 3 2) +(test #f >= 1 3 2) + +(define (test-compare lo m hi) ; all positive! + (define -lo (- lo)) + (define -m (- m)) + (define -hi (- hi)) + + (define (test-lh l h) + (test #f > l h) + (test #t < l h) + (test #f = l h) + (test #f >= l h) + (test #t <= l h)) + + (define (test-hl h l) + (test #t > h l) + (test #f < h l) + (test #f = h l) + (test #t >= h l) + (test #f <= h l)) + + (define (test-zero z) + (test-hl m z) + (test-lh -m z) + (test-hl z -m) + (test-lh z m)) + + (test-lh m hi) + (test-hl -m -hi) + + (test #f > m m) + (test #f < m m) + (test #t = m m) + (test #t >= m m) + (test #t <= m m) + + (test-hl m -m) + (test-lh -m m) + + (test-hl m lo) + (test-lh -m -lo) + + (test-zero 0) + (test-zero 0.0)) + +(test-compare 0.5 1.2 2.3) +(test-compare 2/5 1/2 2/3) +(test #t = 1/2 2/4) + +(test-compare 0.5 6/5 2.3) +(test-compare 1 11922615739/10210200 3000) +(test-compare 1.0 11922615739/10210200 3000.0) + +(test-compare 0.4+0.i 1/2 2.3+0.i) + +(test #f > 0 (/ 1 (expt 2 400))) + +(test #t < 0.5 2/3) +(test #f < 2/3 0.5) +(test #t = 0.5 1/2) +(test #t = +0.5i +1/2i) +(test #f = +0.5i 1+1/2i) +(test #t = 1 1.0+0i) +(test #t = 1 1.0+0.0i) +(test #f eqv? 1.0 1.0+0.0i) +(test #f eqv? 1.0-0.0i 1.0+0.0i) + +(test #f = 1+2i 2+i) + +(define (test-nan.0 f . args) + (apply test +nan.0 f args)) + +(define (test-i-nan.0 f . args) + (apply test (make-rectangular +nan.0 +nan.0) f args)) + +(define (test-nan c) + (test #f < +nan.0 c) + (test #f > +nan.0 c) + (test #f = +nan.0 c) + (test #f <= +nan.0 c) + (test #f >= +nan.0 c)) +(test-nan 0) +(test-nan 0.0) +(test-nan 0.3) +(test-nan +nan.0) +(test-nan +inf.0) +(test-nan -inf.0) +(test-nan 0.3+0.0i) +(test #f = +nan.0 1+2i) +(test #f = +nan.0 (make-rectangular +inf.0 -inf.0)) + +(test-compare 999999999999 1000000000000 1000000000001) +(define big-num (expt 2 1500)) +(test-compare (sub1 big-num) big-num (add1 big-num)) +(test-compare 1.0 (expt 10 100) 1e200) + +(define (inf-zero-test inf rx negnot) + (let ([inf-test-x + (lambda (r v) + (test r < v inf) + (test (not r) > v inf) + (test r <= v inf) + (test (not r) >= v inf) + + (test (not r) < inf v) + (test r > inf v) + (test (not r) <= inf v) + (test r >= inf v))]) + (inf-test-x rx 5) + (inf-test-x (negnot rx) -5) + (inf-test-x rx big-num) + (inf-test-x (negnot rx) (- big-num)) + (inf-test-x rx (/ big-num 3)) + (inf-test-x (negnot rx) (/ (- big-num) 3)) + (inf-test-x rx (/ 1 big-num)) + (inf-test-x (negnot rx) (/ 1 (- big-num))))) +(inf-zero-test +inf.0 #t (lambda (x) x)) +(inf-zero-test -inf.0 #f (lambda (x) x)) +(inf-zero-test 0.0 #f not) + +(error-test '(= 1 'a)) +(error-test '(= 1 1 'a)) +(error-test '(= 1 2 'a)) +(error-test '(= 'a 1)) +(error-test '(= 'a)) +(error-test '(> 1 'a)) +(error-test '(> 1 0 'a)) +(error-test '(> 1 2 'a)) +(error-test '(> 'a 1)) +(error-test '(> 0.5+0.1i 1)) +(error-test '(> 1 0.5+0.1i)) +(error-test '(< 1 'a)) +(error-test '(< 1 2 'a)) +(error-test '(< 1 0 'a)) +(error-test '(< 'a 1)) +(error-test '(< 0.5+0.1i 1)) +(error-test '(< 1 0.5+0.1i)) +(error-test '(>= 1 'a)) +(error-test '(>= 1 1 'a)) +(error-test '(>= 1 2 'a)) +(error-test '(>= 'a 1)) +(error-test '(>= 0.5+0.1i 1)) +(error-test '(>= 1 0.5+0.1i)) +(error-test '(<= 1 'a)) +(error-test '(<= 1 1 'a)) +(error-test '(<= 1 0 'a)) +(error-test '(<= 'a 1)) +(error-test '(<= 0.5+0.1i 1)) +(error-test '(<= 1 0.5+0.1i)) + +(arity-test = 1 -1) +(arity-test < 1 -1) +(arity-test > 1 -1) +(arity-test <= 1 -1) +(arity-test >= 1 -1) + +(test #t zero? 0) +(test #t zero? 0.0) +(test #t zero? +0.0i) +(test #t zero? -0.0i) +(test #t zero? 0.0+0.0i) +(test #f zero? 1.0+0.0i) +(test #f zero? 1.0+1.0i) +(test #f zero? 0.0+1.0i) +(test #t zero? 0/1) +(test #f zero? 1) +(test #f zero? -1) +(test #f zero? -100) +(test #f zero? 1.0) +(test #f zero? -1.0) +(test #f zero? 1/2) +(test #f zero? -1/2) +(test #f zero? -1/2+2i) +(test #f zero? +inf.0) +(test #f zero? -inf.0) +(test #f zero? +nan.0) +(test #f zero? (expt 2 37)) +(test #f zero? (expt -2 37)) +(test #t positive? 4) +(test #f positive? -4) +(test #f positive? 0) +(test #t positive? 4.0) +(test #f positive? -4.0) +(test #f positive? 0.0) +(test #t positive? 2/4) +(test #f positive? -2/4) +(test #f positive? 0/2) +(test #t positive? +inf.0) +(test #f positive? -inf.0) +(test #f positive? +nan.0) +(test #t positive? 5+0.0i) +(test #f positive? -5+0.0i) +(test #t positive? (expt 2 37)) +(test #f positive? (expt -2 37)) +(test #f negative? 4) +(test #t negative? -4) +(test #f negative? 0) +(test #f negative? 4.0) +(test #t negative? -4.0) +(test #f negative? 0.0) +(test #f negative? 2/4) +(test #t negative? -2/4) +(test #f negative? 0/4) +(test #f negative? (expt 2 37)) +(test #t negative? (expt -2 37)) +(test #f negative? +inf.0) +(test #t negative? -inf.0) +(test #f negative? +nan.0) +(test #f negative? 5+0.0i) +(test #t negative? -5+0.0i) +(test #t odd? 3) +(test #f odd? 2) +(test #f odd? -4) +(test #t odd? -1) +(test #t odd? +inf.0) +(test #t odd? -inf.0) +(test #t odd? 5+0.0i) +(test #f odd? 4+0.0i) +(test #f odd? (expt 2 37)) +(test #f odd? (expt -2 37)) +(test #t odd? (add1 (expt 2 37))) +(test #t odd? (sub1 (expt -2 37))) +(test #f even? 3) +(test #t even? 2) +(test #t even? -4) +(test #f even? -1) +(test #t even? +inf.0) +(test #t even? -inf.0) +(test #t even? 4+0.0i) +(test #f even? 5+0.0i) +(test #t even? (expt 2 37)) +(test #t even? (expt -2 37)) +(test #f even? (add1 (expt 2 37))) +(test #f even? (sub1 (expt -2 37))) + +(arity-test zero? 1 1) +(arity-test positive? 1 1) +(arity-test negative? 1 1) +(arity-test odd? 1 1) +(arity-test even? 1 1) + +(error-test '(positive? 2+i)) +(error-test '(negative? 2+i)) +(error-test '(odd? 4.1)) +(error-test '(odd? 4.1+0.0i)) +(error-test '(odd? 4+1i)) +(error-test '(even? 4.1)) +(error-test '(even? 4.1+0.0i)) +(error-test '(even? 4+1i)) +(error-test '(even? +nan.0)) + +(error-test '(positive? 'i)) +(error-test '(negative? 'i)) +(error-test '(odd? 'a)) +(error-test '(even? 'a)) +(error-test '(odd? 'i)) +(error-test '(even? 'i)) + +(test 5 max 5) +(test 5 min 5) +(test 38 max 34 5 7 38 6) +(test -24 min 3 5 5 330 4 -24) +(test 38.0 max 34 5.0 7 38 6) +(test -24.0 min 3 5 5 330 4 -24.0) +(test 2/3 max 1/2 2/3) +(test 2/3 max 2/3 1/2) +(test 2/3 max 2/3 -4/5) +(test 1/2 min 1/2 2/3) +(test 1/2 min 2/3 1/2) +(test -4/5 min 2/3 -4/5) +(test +inf.0 max +inf.0 0 -inf.0) +(test -inf.0 min +inf.0 0 -inf.0) +(test-nan.0 max +inf.0 +nan.0 0 -inf.0) +(test-nan.0 min +inf.0 0 +nan.0 -inf.0) +(test 9.0 min 9.0+0.0i 100) +(test 8.0 min 9.0+0.0i 8) +(test 9.0 min 100 9.0+0.0i) +(test 8.0 min 8 9.0+0.0i) +(test 100.0 max 9.0+0.0i 100) +(test 9.0 max 9.0+0.0i 8) +(test 100.0 max 100 9.0+0.0i) +(test 9.0 max 8 9.0+0.0i) + +(test (expt 5 27) max 9 (expt 5 27)) +(test (expt 5 29) max (expt 5 29) (expt 5 27)) +(test (expt 5 29) max (expt 5 27) (expt 5 29)) +(test (expt 5 27) max (expt 5 27) 9) +(test (expt 5 27) max (expt 5 27) (- (expt 5 29))) +(test (expt 5 27) max (- (expt 5 29)) (expt 5 27)) +(test (- (expt 5 27)) max (- (expt 5 27)) (- (expt 5 29))) +(test (- (expt 5 27)) max (- (expt 5 29)) (- (expt 5 27))) +(test 9 min 9 (expt 5 27)) +(test (expt 5 27) min (expt 5 29) (expt 5 27)) +(test (expt 5 27) min (expt 5 27) (expt 5 29)) +(test 9 min (expt 5 27) 9) +(test (- (expt 5 29)) min (expt 5 27) (- (expt 5 29))) +(test (- (expt 5 29)) min (- (expt 5 29)) (expt 5 27)) +(test (- (expt 5 29)) min (- (expt 5 27)) (- (expt 5 29))) +(test (- (expt 5 29)) min (- (expt 5 29)) (- (expt 5 27))) + +(error-test '(max 0 'a)) +(error-test '(min 0 'a)) +(error-test '(max 'a 0)) +(error-test '(min 'a 0)) +(error-test '(max 'a)) +(error-test '(min 'a)) +(error-test '(min 2 4+i)) +(error-test '(max 2 4+i)) +(error-test '(min 4+i)) +(error-test '(max 4+i)) + +(arity-test max 1 -1) +(arity-test min 1 -1) + +(test 0 +) +(test 7 + 3 4) +(test 6 + 1 2 3) +(test 7.0 + 3 4.0) +(test 6.0 + 1 2.0 3) +(test 19/12 + 1/4 1/3 1) +(test +i + +i) +(test 3/2+1i + 1 2+2i -i -3/2) +(test 3 + 3) +(test 0 +) +(test 4 * 4) +(test 16.0 * 4 4.0) +(test 1 *) +(test 6/25 * 3/5 1/5 2) +(test #i+6/25 * 3/5 1/5 2.0) +(test +6/25i * 3/5 1/5 2 +i) +(test (make-rectangular 0 #i+6/25) * 3/5 1/5 2.0 +i) +(test 18805208620685182736256260714897 + * (sub1 (expt 2 31)) + 8756857658476587568751) +(test 1073741874 + (- (expt 2 30) 50) 100) ; fixnum -> bignum for 32 bits +(test -1073741874 - (- 50 (expt 2 30)) 100) ; fixnum -> bignum for 32 bits +(test 10.0+0.0i + 9.0+0.0i 1) +(test 10.0+0.0i + 9.0+0.0i 1-0.0i) +(test 9.0+0.0i * 9.0+0.0i 1) +(test 10.0-1.0i + 9.0+0.0i 1-1.0i) +(test 0 * 0 10.0) +(test 0 * 0 +inf.0) +(test 0 * 0 +nan.0) +(test 0 / 0 0.0) +(test 0 / 0 +inf.0) +(test 0 / 0 -inf.0) +(test 0 / 0 +nan.0) +(test -0.0 + 0 -0.0) +(test -0.0 + -0.0 0) +(test -0.0 - -0.0 0) + +(test -0.0 - 0.0) +(test 0.0 - -0.0) +(test -0.0 - 0 0.0) +(test 0.0 - 0 -0.0) + +(arity-test * 0 -1) +(arity-test + 0 -1) +(arity-test - 1 -1) +(arity-test / 1 -1) + +(test 2 add1 1) +(test 0 add1 -1) +(test 2.0 add1 1.0) +(test 0.0 add1 -1.0) +(test 3/2 add1 1/2) +(test 1/2 add1 -1/2) +(test 2.0+i add1 1.0+i) +(test 0.0+i add1 -1.0+i) +(test 0.0+0.0i add1 -1+0.0i) +(test 0.0-0.0i add1 -1-0.0i) +(test 1073741824 add1 #x3FFFFFFF) ; fixnum boundary case + +(error-test '(add1 "a")) +(arity-test add1 1 1) + +(test 1 sub1 2) +(test -2 sub1 -1) +(test 1.0 sub1 2.0) +(test -2.0 sub1 -1.0) +(test -1/2 sub1 1/2) +(test -3/2 sub1 -1/2) +(test 1.0+i sub1 2.0+i) +(test -2.0+i sub1 -1.0+i) +(test -2.0+0.0i sub1 -1+0.0i) +(test -2.0-0.0i sub1 -1-0.0i) +(test -1073741824 sub1 -1073741823) ; fixnum boundary case + +(error-test '(sub1 "a")) +(arity-test sub1 1 1) + +(test 1024 expt 2 10) +(test 1/1024 expt 2 -10) +(arity-test expt 2 2) + +(test 0 apply + (map inexact->exact (list 3.2e+270 -2.4e+270 -8e+269))) +(test 0 apply + (map inexact->exact (list 3.2f+7 -2.4f+7 -8f+6))) + +(test #t positive? (inexact->exact 0.1)) +(test #t negative? (inexact->exact -0.1)) +(test 0 + (inexact->exact -0.1) (inexact->exact 0.1)) +(arity-test inexact->exact 1 1) +(error-test '(inexact->exact 'a)) +(test 1+i inexact->exact 1.0+1.0i) +(test 1 inexact->exact 1.0+0.0i) +(test 1 inexact->exact 1.0-0.0i) + +(test #t positive? (exact->inexact 1/10)) +(test #t negative? (exact->inexact -1/10)) +(test 0.0 + (exact->inexact -1/10) (exact->inexact 1/10)) +(arity-test exact->inexact 1 1) +(error-test '(exact->inexact 'a)) +(test 1.0+1.0i exact->inexact 1+1i) +(test 1.0+0.0i exact->inexact 1+0.0i) +(test (expt 7 30) inexact->exact (expt 7 30)) + +(error-test '(inexact->exact +inf.0)) +(error-test '(inexact->exact -inf.0)) +(error-test '(inexact->exact +nan.0)) + +(error-test '(* 'a 0)) +(error-test '(+ 'a 0)) +(error-test '(/ 'a 0)) +(error-test '(- 'a 0)) +(error-test '(+ 0 'a)) +(error-test '(* 0 'a)) +(error-test '(- 0 'a)) +(error-test '(/ 0 'a)) +(error-test '(+ 'a)) +(error-test '(* 'a)) +(error-test '(- 'a)) +(error-test '(/ 'a)) + +(define (test-inf-plus-times v) + (define (test+ +) + (test +inf.0 + v (+ +inf.0)) + (test -inf.0 + v (+ -inf.0)) + (test +inf.0 + (- v) (+ +inf.0)) + (test -inf.0 + (- v) (+ -inf.0)) + + (test +inf.0 + +inf.0 v) + (test -inf.0 + -inf.0 v) + (test +inf.0 + +inf.0 (- v)) + (test -inf.0 + -inf.0 (- v)) + + (test-nan.0 + +nan.0 v) + (test-nan.0 + v +nan.0)) + + (test+ +) + (test+ -) + + (test +inf.0 * +inf.0 v) + (test -inf.0 * -inf.0 v) + (test -inf.0 * +inf.0 (- v)) + (test +inf.0 * -inf.0 (- v)) + + (test +inf.0 * v +inf.0) + (test -inf.0 * v -inf.0) + (test -inf.0 * (- v) +inf.0) + (test +inf.0 * (- v) -inf.0) + + (test-nan.0 * +nan.0 v) + (test-nan.0 * v +nan.0)) + +(test-inf-plus-times 1) +(test-inf-plus-times 1.0) +(test-inf-plus-times (expt 2 100)) + +(test -inf.0 - +inf.0) +(test +inf.0 - -inf.0) +(test +inf.0 + +inf.0 +inf.0) +(test -inf.0 + -inf.0 -inf.0) +(test-nan.0 + +inf.0 -inf.0) +(test-nan.0 - +inf.0 +inf.0) +(test-nan.0 - -inf.0 -inf.0) +(test +inf.0 * +inf.0 +inf.0) +(test -inf.0 * +inf.0 -inf.0) +(test 0 * +inf.0 0) +(test-nan.0 * +inf.0 0.0) +(test-nan.0 + +nan.0 +nan.0) +(test-nan.0 - +nan.0 +nan.0) +(test-nan.0 * +nan.0 +nan.0) + +(test 1/2 / 1 2) +(test 1/2 / 1/4 1/2) +(test 0.5 / 1 2.0) +(test 0.5 / 1.0 2) +(test 1/2+3/2i / 1+3i 2) +(test 1/5-3/5i / 2 1+3i) +(test 0.5+0.0i / 1+0.0i 2) +(test 0.25-0.0i / 1 4+0.0i) +(test 0.25+0.0i / 1+0.0i 4+0.0i) + +(test +inf.0 / 1.0 0.0) +(test -inf.0 / -1.0 0.0) +(test +inf.0 / -1.0 -0.0) +(test -inf.0 / 1.0 -0.0) + +(define (make-test-inf-zero-div zero -zero inf -inf) + (lambda (v) + (test zero / v +inf.0) + (test -zero / v -inf.0) + (test -zero / (- v) +inf.0) + (test zero / (- v) -inf.0) + + (test inf / +inf.0 v) + (test -inf / -inf.0 v) + (test -inf / +inf.0 (- v)) + (test inf / -inf.0 (- v)) + + (unless (zero? v) + (test zero / 0.0 v) + (test -zero / 0.0 (- v)) + (test -zero / -0.0 v) + (test zero / -0.0 (- v)) + + (test inf / v 0.0) + (test -inf / (- v) 0.0) + (test -inf / v -0.0) + (test inf / (- v) -0.0)) + + (test-nan.0 / +nan.0 v) + (test-nan.0 / v +nan.0))) + +(define test-inf-zero-div (make-test-inf-zero-div 0.0 -0.0 +inf.0 -inf.0)) +(define test-neg-inf-zero-div (make-test-inf-zero-div -0.0 0.0 -inf.0 +inf.0)) + +(test-inf-zero-div big-num) +(test-inf-zero-div (/ big-num 3)) +(test-inf-zero-div 0.0) + +(test-neg-inf-zero-div (- big-num)) +(test-neg-inf-zero-div (- (/ big-num 3))) +(test-neg-inf-zero-div -0.0) + +(test-nan.0 / +inf.0 +inf.0) +(test-nan.0 / +inf.0 -inf.0) +(test-nan.0 / +nan.0 -nan.0) + +(test 1.0 exact->inexact (/ big-num (add1 big-num))) + +(error-test '(/ 0) exn:application:divide-by-zero?) +(error-test '(/ 1 0) exn:application:divide-by-zero?) +(error-test '(/ 1/2 0) exn:application:divide-by-zero?) +(error-test '(/ 1+2i 0) exn:application:divide-by-zero?) +(error-test '(/ 1.0 0) exn:application:divide-by-zero?) + +(test -1 - 3 4) +(test -3 - 3) +(test -1.0 - 3.0 4) +(test -3.0 - 3.0) +(test 7 abs -7) +(test 7.0 abs -7.0) +(test 7 abs 7) +(test 0 abs 0) +(test 1/2 abs 1/2) +(test 1/2 abs -1/2) +(test +inf.0 abs +inf.0) +(test +inf.0 abs -inf.0) +(test-nan.0 abs -nan.0) +(test 4.0 abs -4.0+0.0i) + +(arity-test abs 1 1) +(error-test '(-) exn:application:arity?) +(error-test '(abs 'a)) +(error-test '(abs +5i)) + +(test 5 quotient 35 7) +(test 5.0 quotient 35 7.0) +(test 5.0 quotient 36 7.0) +(test 5.0 quotient 36.0 7) +(test -5 quotient -35 7) +(test -5.0 quotient -35 7.0) +(test -5 quotient 35 -7) +(test -5.0 quotient 35 -7.0) +(test 5 quotient -35 -7) +(test 5.0 quotient -35 -7.0) +(test -5.0 quotient -36 7.0) +(test -5.0 quotient 36.0 -7) +(test -5.0 quotient 36.0 -7+0.0i) +(test -5.0 quotient 36.0+0.0i -7) +(test 1 modulo 13 4) +(test 1 remainder 13 4) +(test 1.0 modulo 13 4.0) +(test 1.0 remainder 13 4.0) +(test 3 modulo -13 4) +(test -1 remainder -13 4) +(test 3.0 modulo -13 4.0) +(test -1.0 remainder -13 4.0) +(test -3 modulo 13 -4) +(test 1 remainder 13 -4) +(test -3.0 modulo 13.0 -4) +(test 1.0 remainder 13.0 -4) +(test -1 modulo -13 -4) +(test -1 remainder -13 -4) +(test -1.0 modulo -13 -4.0) +(test -1.0 remainder -13 -4.0) +(test -1.0 modulo -13 -4.0+0.0i) +(test -1.0 remainder -13 -4.0+0.0i) +(test -1.0 modulo -13+0.0i -4.0) +(test -1.0 remainder -13+0.0i -4.0) +(test -2 remainder -3333333332 -3) +(test -2 modulo -3333333332 -3) +(test 2 remainder 3333333332 -3) +(test -1 modulo 3333333332 -3) +(test 0 modulo 4 2) +(test 0 modulo -4 2) +(test 0 modulo 4 -2) +(test 0 modulo -4 -2) +(test 0.0 modulo 4.0 2) +(test 0.0 modulo -4.0 2) +(test 0.0 modulo 4.0 -2) +(test 0.0 modulo -4.0 -2) +(test 0 remainder 4 2) +(test 0 remainder -4 2) +(test 0 remainder 4 -2) +(test 0 remainder -4 -2) +(test 0.0 remainder 4.0 2) +(test 0.0 remainder -4.0 2) +(test 0.0 remainder 4.0 -2) +(test 0.0 remainder -4.0 -2) +(define (divtest n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2)))) +(test #t divtest 238 9) +(test #t divtest -238 9) +(test #t divtest 238 -9) +(test #t divtest -238 -9) + +(test 13.0 quotient 1324.0 100) + +(error-test '(quotient 6 0) exn:application:divide-by-zero?) +(error-test '(modulo 6 0) exn:application:divide-by-zero?) +(error-test '(remainder 6 0) exn:application:divide-by-zero?) +(error-test '(quotient 6 0.0) exn:application:divide-by-zero?) +(error-test '(modulo 6 0.0) exn:application:divide-by-zero?) +(error-test '(remainder 6 0.0) exn:application:divide-by-zero?) +(error-test '(quotient 6 -0.0) exn:application:divide-by-zero?) +(error-test '(modulo 6 -0.0) exn:application:divide-by-zero?) +(error-test '(remainder 6 -0.0) exn:application:divide-by-zero?) + +(define (test-qrm-inf v) + (define iv (exact->inexact v)) + + (test 0.0 quotient v +inf.0) + (test -0.0 quotient v -inf.0) + (test iv remainder v +inf.0) + (test iv remainder v -inf.0) + (test iv modulo v +inf.0) + (test -inf.0 modulo v -inf.0) + + (test +inf.0 quotient +inf.0 v) + (test -inf.0 quotient -inf.0 v) + (test 0.0 remainder +inf.0 v) + (test 0.0 remainder -inf.0 v) + (test 0.0 modulo +inf.0 v) + (test 0.0 modulo -inf.0 v)) + +(test-qrm-inf 9) +(test-qrm-inf 9.0) +(test-qrm-inf (expt 2 100)) + +;; Check 0.0 combinations +(test -0.0 quotient -0.0 +inf.0) +(test 0.0 quotient -0.0 -inf.0) +(test -0.0 quotient -0.0 2.0) +(test 0.0 quotient -0.0 -2.0) +(test 0.0 quotient 0.0 +inf.0) +(test -0.0 quotient 0.0 -inf.0) +(test 0.0 quotient 0.0 2.0) +(test -0.0 quotient 0.0 -2.0) +(test 0.0 modulo -0.0 +inf.0) +(test 0.0 modulo -0.0 -inf.0) +(test 0.0 modulo -0.0 2.0) +(test 0.0 modulo -0.0 -2.0) +(test 0.0 modulo 0.0 +inf.0) +(test 0.0 modulo 0.0 -inf.0) +(test 0.0 modulo 0.0 2.0) +(test 0.0 modulo 0.0 -2.0) +(test 0.0 remainder -0.0 +inf.0) +(test 0.0 remainder -0.0 -inf.0) +(test 0.0 remainder -0.0 2.0) +(test 0.0 remainder -0.0 -2.0) +(test 0.0 remainder 0.0 +inf.0) +(test 0.0 remainder 0.0 -inf.0) +(test 0.0 remainder 0.0 2.0) +(test 0.0 remainder 0.0 -2.0) + +(arity-test quotient 2 2) +(arity-test modulo 2 2) +(arity-test remainder 2 2) + +(error-test '(quotient 'a 1)) +(error-test '(quotient 1 'a)) +(error-test '(quotient 1 +nan.0)) +(error-test '(quotient +nan.0 1)) +(error-test '(modulo 'a 1)) +(error-test '(modulo 1 'a)) +(error-test '(modulo +nan.0 1)) +(error-test '(modulo 1 +nan.0)) +(error-test '(remainder 'a 1)) +(error-test '(remainder 1 'a)) +(error-test '(remainder +nan.0 1)) +(error-test '(remainder 1 +nan.0)) +(error-test '(quotient 'a 1.0)) +(error-test '(quotient 1.0 'a)) +(error-test '(modulo 'a 1.0)) +(error-test '(modulo 1.0 'a)) +(error-test '(remainder 'a 1.0)) +(error-test '(remainder 1.0 'a)) +(error-test '(quotient 1/2 1)) +(error-test '(remainder 1/2 1)) +(error-test '(modulo 1/2 1)) +(error-test '(quotient 2 1/2)) +(error-test '(remainder 2 1/2)) +(error-test '(modulo 2 1/2)) +(error-test '(quotient 12.3 1)) +(error-test '(remainder 12.3 1)) +(error-test '(modulo 12.3 1)) +(error-test '(quotient 2 12.3)) +(error-test '(remainder 2 12.3)) +(error-test '(modulo 2 12.3)) +(error-test '(quotient 1+2i 1)) +(error-test '(remainder 1+2i 1)) +(error-test '(modulo 1+2i 1)) +(error-test '(quotient 2 1+2i)) +(error-test '(remainder 2 1+2i)) +(error-test '(modulo 2 1+2i)) + +(test 10 bitwise-ior 10) +(test 10 bitwise-and 10) +(test 10 bitwise-xor 10) +(test 7 bitwise-ior 3 4) +(test 0 bitwise-and 3 4) +(test 7 bitwise-xor 3 4) +(test 7 bitwise-ior 3 4 1) +(test 1 bitwise-and 3 5 1) +(test 6 bitwise-xor 3 4 1) + +(test #x1ffff7777 bitwise-ior #x1aaaa5555 #x155553333) +(test #x100001111 bitwise-and #x1aaaa5555 #x155553333) +(test #x0ffff6666 bitwise-xor #x1aaaa5555 #x155553333) + +(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333) +(test #x000001111 bitwise-and #x2aaaa5555 #x155553333) +(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333) + +(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333) +(test #x000001111 bitwise-and #x2aaaa5555 #x155553333) +(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333) + +(test #xfffffffffffffe bitwise-not #x-FFFFFFFFFFFFFF) +(test #x-100000000000000 bitwise-not #xFFFFFFFFFFFFFF) + +(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555aaaa)) + bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555aaaa)) +(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-155553333)) + bitwise-not (bitwise-ior #x-2aaaa5555 #x-155553333)) +(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555333)) + bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555333)) + +(test #x-155553333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-155553333)) +(test #x-15555333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-15555333)) + +(arity-test bitwise-ior 1 -1) +(arity-test bitwise-and 1 -1) +(arity-test bitwise-xor 1 -1) +(arity-test bitwise-not 1 1) + +(define error-test-bitwise-procs + (lambda (v) + (error-test `(bitwise-ior ,v)) + (error-test `(bitwise-and ,v)) + (error-test `(bitwise-xor ,v)) + (error-test `(bitwise-not ,v)) + (error-test `(bitwise-ior 1 ,v)) + (error-test `(bitwise-and 1 ,v)) + (error-test `(bitwise-xor 1 ,v)) + (error-test `(bitwise-ior ,v 1)) + (error-test `(bitwise-and ,v 1)) + (error-test `(bitwise-xor ,v 1)))) + +(error-test-bitwise-procs 1.0) +(error-test-bitwise-procs 1/2) +(error-test-bitwise-procs 1+2i) +(error-test-bitwise-procs 1.0+0.0i) +(error-test-bitwise-procs +inf.0) +(error-test-bitwise-procs ''a) + +(test 1 arithmetic-shift 1 0) +(test 1024 arithmetic-shift 1 10) +(test 1 arithmetic-shift 1024 -10) +(test 256 arithmetic-shift 1024 -2) +(test 0 arithmetic-shift 1024 -11) +(test 0 arithmetic-shift 1024 -20) +(test 0 arithmetic-shift 1024 -40) +(test 0 arithmetic-shift 1024 -20000000000000000000) +(test 0 arithmetic-shift 0 100) +(test 0 arithmetic-shift 0 -100) +(test 0 arithmetic-shift 17 -32) + +(test (expt 2 40) arithmetic-shift (expt 2 40) 0) +(test (expt 2 50) arithmetic-shift (expt 2 40) 10) +(test (expt 2 30) arithmetic-shift (expt 2 40) -10) ; somewhere close to here is a boundary... +(test (expt 2 29) arithmetic-shift (expt 2 40) -11) +(test (expt 2 31) arithmetic-shift (expt 2 40) -9) +(test 1 arithmetic-shift (expt 2 40) -40) +(test 0 arithmetic-shift (expt 2 40) -41) +(test 0 arithmetic-shift (expt 2 40) -100) + +(test -1 arithmetic-shift -1 0) +(test -1024 arithmetic-shift -1 10) +(test -1 arithmetic-shift -1024 -10) +(test -256 arithmetic-shift -1024 -2) +(test -1 arithmetic-shift -1024 -11) +(test -1 arithmetic-shift -1024 -20) +(test -1 arithmetic-shift -1024 -20000000000000000000) + +(test (- (expt 2 40)) arithmetic-shift (- (expt 2 40)) 0) +(test (- (expt 2 50)) arithmetic-shift (- (expt 2 40)) 10) +(test (- (expt 2 30)) arithmetic-shift (- (expt 2 40)) -10) ; somewhere close to here is a boundary... +(test (- (expt 2 29)) arithmetic-shift (- (expt 2 40)) -11) +(test (- (expt 2 31)) arithmetic-shift (- (expt 2 40)) -9) +(test -1 arithmetic-shift (- (expt 2 40)) -40) +(test -1 arithmetic-shift (- (expt 2 40)) -41) +(test -1 arithmetic-shift (- (expt 2 40)) -100) + +(test 0 arithmetic-shift (sub1 (expt 2 30)) -32) +(test 0 arithmetic-shift (sub1 (expt 2 31)) -32) +(test 0 arithmetic-shift (sub1 (expt 2 32)) -32) +(test 1 arithmetic-shift (expt 2 32) -32) + +(arity-test arithmetic-shift 2 2) +(error-test '(arithmetic-shift "a" 1)) +(error-test '(arithmetic-shift 1 "a")) +(error-test '(arithmetic-shift 1.0 1)) +(error-test '(arithmetic-shift 1 1.0)) +(error-test '(arithmetic-shift 1 1.0+0.0i)) +(error-test '(arithmetic-shift 1 (expt 2 80)) exn:misc:out-of-memory?) + +(test 4 gcd 0 4) +(test 4 gcd -4 0) +(test 4 gcd 32 -36) +(test 2 gcd 6 10 14) +(test 0 gcd) +(test 5 gcd 5) +(test 5.0 gcd 5.0 10) +(test 5.0 gcd -5.0 10) +(test 5.0 gcd 5.0 -10) +(test 5.0 gcd 5.0+0.0i 10) +(test 5.0 gcd 5.0 10+0.0i) +(test (expt 3 37) gcd (expt 9 35) (expt 6 37)) +(test (expt 3 37) gcd (- (expt 9 35)) (expt 6 37)) +(test (expt 3 37) gcd (expt 9 35) (- (expt 6 37))) +(test 201 gcd (* 67 (expt 3 20)) (* 67 3)) +(test 201 gcd (* 67 3) (* 67 (expt 3 20))) +(test 201.0 gcd (* 67 (expt 3 20)) (* 67. 3)) +(test 201.0 gcd (* 67. 3) (* 67 (expt 3 20))) +(test 9.0 gcd +inf.0 9) +(test 9.0 gcd -inf.0 9) +(test 288 lcm 32 -36) +(test 12 lcm 2 3 4) +(test 1 lcm) +(test 5 lcm 5) +(test 0 lcm 123 0) +(test 30.0 lcm 5 6.0) +(test 30.0 lcm 5 6.0+0.0i) +(test 30.0 lcm 5+0.0i 6.0) +(test 0.0 lcm 123 0.0) +(test 0.0 lcm 123 -0.0) +(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (expt 6 37)) +(test (* (expt 2 37) (expt 9 35)) lcm (- (expt 9 35)) (expt 6 37)) +(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (- (expt 6 37))) + +(error-test '(gcd +nan.0)) +(error-test '(gcd 'a)) +(error-test '(gcd 'a 1)) +(error-test '(gcd 1 'a)) +(error-test '(lcm +nan.0)) +(error-test '(lcm 'a)) +(error-test '(lcm 'a 1)) +(error-test '(lcm 1 'a)) +(error-test '(gcd 1/2)) +(error-test '(gcd 3 1/2)) +(error-test '(gcd 1/2 3)) +(error-test '(lcm 1/2)) +(error-test '(lcm 3 1/2)) +(error-test '(lcm 1/2 3)) +(error-test '(gcd 1+2i)) +(error-test '(lcm 1+2i)) +(error-test '(gcd 1 1+2i)) +(error-test '(lcm 1 1+2i)) +(error-test '(gcd +nan.0 5.0)) +(error-test '(gcd 5.0 +nan.0)) +(error-test '(lcm +nan.0 5.0)) +(error-test '(lcm 5.0 +nan.0)) + +(arity-test gcd 0 -1) +(arity-test lcm 0 -1) + +(test 2 floor 5/2) +(test 3 ceiling 5/2) +(test 2 round 5/2) +(test 2 truncate 5/2) +(test -3 floor -5/2) +(test -2 ceiling -5/2) +(test -2 round -5/2) +(test -2 truncate -5/2) + +(test 1 floor 4/3) +(test 2 ceiling 4/3) +(test 1 round 4/3) +(test 1 truncate 4/3) +(test -2 floor -4/3) +(test -1 ceiling -4/3) +(test -1 round -4/3) +(test -1 truncate -4/3) + +(test 1 floor 5/3) +(test 2 ceiling 5/3) +(test 2 round 5/3) +(test 1 truncate 5/3) +(test -2 floor -5/3) +(test -1 ceiling -5/3) +(test -2 round -5/3) +(test -1 truncate -5/3) + +(test 2 floor 11/4) +(test 3 ceiling 11/4) +(test 3 round 11/4) +(test 2 truncate 11/4) +(test -3 floor -11/4) +(test -2 ceiling -11/4) +(test -3 round -11/4) +(test -2 truncate -11/4) + +(test 2 floor 9/4) +(test 3 ceiling 9/4) +(test 2 round 9/4) +(test 2 truncate 9/4) +(test -3 floor -9/4) +(test -2 ceiling -9/4) +(test -2 round -9/4) +(test -2 truncate -9/4) + +(test 2.0 floor 2.4) +(test 3.0 ceiling 2.4) +(test 2.0 round 2.4) +(test 2.0 truncate 2.4) +(test -3.0 floor -2.4) +(test -2.0 ceiling -2.4) +(test -2.0 round -2.4) +(test -2.0 truncate -2.4) + +(test 2.0 floor 2.6) +(test 3.0 ceiling 2.6) +(test 3.0 round 2.6) +(test 2.0 truncate 2.6) +(test -3.0 floor -2.6) +(test -2.0 ceiling -2.6) +(test -3.0 round -2.6) +(test -2.0 truncate -2.6) + +(test 2.0 round 2.5) +(test -2.0 round -2.5) +(test 4.0 round 3.5) +(test -4.0 round -3.5) + +(test 2.0 floor 2.6+0.0i) +(test 3.0 ceiling 2.6+0.0i) +(test 3.0 round 2.6+0.0i) +(test 2.0 truncate 2.6+0.0i) + +(define (test-fcrt-int v) + (test v floor v) + (test v ceiling v) + (test v round v) + (test v truncate v)) + +(test-fcrt-int 2) +(test-fcrt-int 2.0) +(test-fcrt-int (expt 2 100)) +(test-fcrt-int +inf.0) +(test-fcrt-int -inf.0) + +(test-nan.0 floor +nan.0) +(test-nan.0 ceiling +nan.0) +(test-nan.0 round +nan.0) +(test-nan.0 truncate +nan.0) + +(arity-test round 1 1) +(arity-test floor 1 1) +(arity-test ceiling 1 1) +(arity-test truncate 1 1) + +(error-test '(floor 2+i)) +(error-test '(ceiling 2+i)) +(error-test '(truncate 2+i)) +(error-test '(round 2+i)) + +(error-test '(floor "a")) +(error-test '(ceiling "a")) +(error-test '(truncate "a")) +(error-test '(round "a")) + +(test 5 numerator 5) +(test 5000000000000 numerator 5000000000000) +(test 5.0 numerator 5.0) +(test 5.0 numerator 5.0+0.0i) +(test 1 denominator 5) +(test 1 denominator 5000000000000) +(test 1.0 denominator 5.0) +(test 1.0 denominator 5.0+0.0i) +(test 2 numerator 2/3) +(test 3 denominator 2/3) +(test 1000.0 round (* 10000.0 (/ (numerator 0.1) (denominator 0.1)))) + +(test +inf.0 numerator +inf.0) +(test -inf.0 numerator -inf.0) +(test-nan.0 numerator +nan.0) +(test 1.0 denominator +inf.0) +(test 1.0 denominator -inf.0) +(test-nan.0 denominator +nan.0) + +(error-test '(numerator 'a)) +(error-test '(numerator 1+2i)) +(error-test '(denominator 'a)) +(error-test '(denominator 1+2i)) + +(arity-test numerator 1 1) +(arity-test denominator 1 1) + +(define (test-on-reals f filter) + (test (filter 5) f 5) + (test (filter 5.0) f 5.0) + (test (filter 1/5) f 1/5) + (test (filter (expt 2 100)) f (expt 2 100))) + +(test 1+2i make-rectangular 1 2) +(test 1.0+2.0i make-rectangular 1.0 2) +(test 1.0+2.0i make-rectangular 1.0+0.0i 2) +(test 1.0+2.0i make-rectangular 1.0 2+0.0i) +(test-nan.0 real-part (make-rectangular +nan.0 1)) +(test 1.0 imag-part (make-rectangular +nan.0 1)) +(test-nan.0 imag-part (make-rectangular 1 +nan.0)) +(test 1.0 real-part (make-rectangular 1 +nan.0)) +(test +inf.0 real-part (make-rectangular +inf.0 -inf.0)) +(test -inf.0 imag-part (make-rectangular +inf.0 -inf.0)) + +(test (make-rectangular +inf.0 -inf.0) * 1. (make-rectangular +inf.0 -inf.0)) +(test (make-rectangular +inf.0 +inf.0) * +1.0i (make-rectangular +inf.0 -inf.0)) +(test (make-rectangular -inf.0 +inf.0) * -3. (make-rectangular +inf.0 -inf.0)) +(test (make-rectangular +inf.0 -inf.0) * (make-rectangular +inf.0 -inf.0) 1.) +(test (make-rectangular +inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) +1.0i) +(test (make-rectangular -inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) -3.) +(test (make-rectangular +inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) 1.) +(test (make-rectangular -inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) +1.0i) +(test (make-rectangular -inf.0 +inf.0) / (make-rectangular +inf.0 -inf.0) -3.) + +(test-i-nan.0 * 1.+0.i (make-rectangular +inf.0 -inf.0)) +(test-i-nan.0 * 0.+1.0i (make-rectangular +inf.0 -inf.0)) +(test-i-nan.0 * -3.+0.i (make-rectangular +inf.0 -inf.0)) +(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 1.+0.i) +(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 0.+1.0i) +(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) -3.+0.i) +(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 1.+0.i) +(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 0.+1.0i) +(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) -3.+0.i) + +(test 1 magnitude 1) +(test 1 magnitude -1) +(test 1.0 magnitude 1.0) +(test 1.0 magnitude -1.0) +(test big-num magnitude big-num) +(test big-num magnitude (- big-num)) +(test 3/4 magnitude 3/4) +(test 3/4 magnitude -3/4) +(test 10.0 magnitude 10.0+0.0i) +(test 10.0 magnitude -10.0+0.0i) + +(test 0 angle 1) +(test 0 angle 1.0) +(test 0 angle 0.0) +(test 0 angle big-num) +(test 0 angle 3/4) +(test 0.0 angle 3+0.0i) +(test-nan.0 angle +nan.0) +(let ([pi (atan 0 -1)]) + (test pi angle -1) + (test pi angle -1.0) + (test pi angle -0.0) + (test pi angle (- big-num)) + (test pi angle -3/4) + (test pi angle -3+0.0i)) +(test -inf.0 atan 0+i) +(test -inf.0 atan 0-i) + +(error-test '(angle 'a)) +(error-test '(angle 0) exn:application:divide-by-zero?) +(error-test '(magnitude 'a)) +(arity-test angle 1 1) +(arity-test magnitude 1 1) + +(test 1 real-part 1+2i) +(test 1.0 real-part 1+2.0i) +(test 1.0 real-part 1+0.0i) +(test 1/5 real-part 1/5+2i) +(test-on-reals real-part (lambda (x) x)) +(test 2.0 imag-part 1+2.0i) +(test 0.0 imag-part 1+0.0i) +(test -0.0 imag-part 1-0.0i) +(test 1/5 imag-part 1+1/5i) +(test-on-reals imag-part (lambda (x) 0)) +(test-nan.0 real-part +nan.0) +(test 0 imag-part +nan.0) +(test 6@1 (lambda (x) x) 6.0@1.0) +(test 324.0 floor (* 100 (real-part 6@1))) +(test 50488.0 floor (* 10000 (imag-part 6@1))) +(test 1 make-polar 1 0) +(test 1.0+0.0i make-polar 1 0.0) +(test 1.0 make-polar 1.0 0) +(test 1.0+0.0i make-polar 1.0 0.0) +(test 1.0+0.0i make-polar 1.0 0.0+0.0i) +(test 1.0+0.0i make-polar 1.0+0.0i 0.0) +(let ([v (make-polar 1 1)]) + (test 5403.0 floor (* 10000 (real-part v))) + (test 84147.0 floor (* 100000 (imag-part v))) + (test 10000.0 round (* 10000.0 (magnitude v)))) +(let ([v (make-polar 1 2)]) + (test -416.0 ceiling (* 1000 (real-part v))) + (test 909.0 floor (* 1000 (imag-part v))) + (test 1.0 magnitude v) + (test 2.0 angle v)) +(test-nan.0 make-polar +nan.0 0) +(test-i-nan.0 make-polar +nan.0 1) +(test-i-nan.0 make-polar 1 +nan.0) +(test-i-nan.0 make-polar 1 +inf.0) +(test-i-nan.0 make-polar 1 -inf.0) +(test +inf.0 make-polar +inf.0 0) +(test -inf.0 make-polar -inf.0 0) +(test (make-rectangular +inf.0 +inf.0) make-polar +inf.0 (atan 1 1)) +(test (make-rectangular -inf.0 +inf.0) make-polar +inf.0 (atan 1 -1)) +(test (make-rectangular +inf.0 -inf.0) make-polar +inf.0 (atan -1 1)) +(test 785.0 floor (* 1000 (angle (make-rectangular 1 1)))) +(test 14142.0 floor (* 10000 (magnitude (make-rectangular 1 1)))) + +(error-test '(make-rectangular 1 'a)) +(error-test '(make-rectangular 'a 1)) +(error-test '(make-rectangular 1+2i 1)) +(error-test '(make-rectangular 1 1+2i)) +(arity-test make-rectangular 2 2) + +(error-test '(make-polar 1 'a)) +(error-test '(make-polar 'a 1)) +(error-test '(make-polar 1+2i 1)) +(error-test '(make-polar 1 1+2i)) +(arity-test make-polar 2 2) + +(error-test '(real-part 'a)) +(error-test '(imag-part 'a)) +(arity-test real-part 1 1) +(arity-test imag-part 1 1) + +(define (z-round c) (make-rectangular (round (real-part c)) (round (imag-part c)))) + +(test -1 * +i +i) +(test 1 * +i -i) +(test 2 * 1+i 1-i) +(test +2i * 1+i 1+i) +(test 0.5 - (+ 0.5 +i) +i) +(test 1/2 - (+ 1/2 +i) +i) +(test 1.0+0.0i - (+ 1 +0.5i) +1/2i) + +(test 1 sqrt 1) +(test 1.0 sqrt 1.0) +(test 25 sqrt 625) +(test 3/7 sqrt 9/49) +(test 0.5 sqrt 0.25) +(test +1i sqrt -1) +(test +2/3i sqrt -4/9) +(test +1.0i sqrt -1.0) +(test 1+1i sqrt +2i) +(test 2+1i sqrt 3+4i) +(test 2.0+0.0i sqrt 4+0.0i) +(test +inf.0 sqrt +inf.0) +(test (make-rectangular 0 +inf.0) sqrt -inf.0) +(test-nan.0 sqrt +nan.0) + +(test (expt 5 13) sqrt (expt 5 26)) +(test 545915034.0 round (sqrt (expt 5 25))) +(test (make-rectangular 0 (expt 5 13)) sqrt (- (expt 5 26))) +(test (make-rectangular 0 545915034.0) z-round (sqrt (- (expt 5 25)))) + +(error-test '(sqrt "a")) +(arity-test sqrt 1 1) + +(test -13/64-21/16i expt -3/4+7/8i 2) +(let ([v (expt -3/4+7/8i 2+3i)]) + (test 3826.0 floor (* 10000000 (real-part v))) + (test -137.0 ceiling (* 100000 (imag-part v)))) +(test 49.0+0.0i expt 7 2+0.0i) +(test 49.0 floor (* 10 (expt 2 2.3))) +(test 189.0 floor (* 1000 (expt 2.3 -2))) +(test 1/4 expt 2 -2) +(test 1/1125899906842624 expt 2 -50) +(test 1/1024 expt 1/2 10) +(test 1024 expt 1/2 -10) +(test 707.0 floor (* 1000 (expt 1/2 1/2))) +(test 707.0 floor (* 1000 (expt 1/2 0.5))) +(test 707.0 floor (* 1000 (expt 0.5 1/2))) +(test 100.0+173.0i z-round (* 100 (expt -8 1/3))) +(test 100.0+173.0i z-round (* 100 (expt -8.0 1/3))) +(test 101.0+171.0i z-round (* 100 (expt -8 0.33))) +(test 101.0+171.0i z-round (* 100 (expt -8.0 0.33))) +(test 108.0+29.0i z-round (* 100 (expt 1+i 1/3))) +(test 25.0-43.0i z-round (* 100 (expt -8 -1/3))) + +(test +inf.0 expt 2 +inf.0) +(test +inf.0 expt +inf.0 10) +(test 1 expt +inf.0 0) +(test 1.0 expt +inf.0 0.) +(test 0.0 expt 2 -inf.0) +(test -inf.0 expt -inf.0 11) +(test +inf.0 expt -inf.0 10) +(test 1 expt -inf.0 0) +(test 1.0 expt -inf.0 0.0) +(test 1 expt +nan.0 0) +(test 0 expt 0 10) +(test 0 expt 0 10.0) +(test 0 expt 0 +inf.0) +(test-nan.0 expt 0 +nan.0) +(test 1 expt 1 +inf.0) +(test 1 expt 1 -inf.0) +(test 1 expt 1 -nan.0) +(test 0.0 expt 0.0 10) +(test 0.0 expt 0.0 +inf.0) +(test +inf.0 expt 0.0 -5) +(test -inf.0 expt -0.0 -5) +(test +inf.0 expt 0.0 -4) +(test +inf.0 expt -0.0 -4) +(test +inf.0 expt 0.0 -4.3) +(test +inf.0 expt -0.0 -4.3) +(test +inf.0 expt 0.0 -inf.0) +(test-nan.0 expt 0.0 +nan.0) +(test 1 expt 0 0) +(test 1.0 expt 0 0.0) ; to match (expt 0 0) +(test 1.0 expt 0 -0.0) +(test 1.0 expt 0.0 0.0) +(test 1.0 expt 0.0 0.0) +(test -0.0 expt -0.0 1) +(test-nan.0 expt +nan.0 10) +(test-nan.0 expt 2 +nan.0) + +(test 0 expt 0 1+i) +(test 0 expt 0 1-i) + +(test-nan.0 expt 1.0 +inf.0) +(test-nan.0 expt 1.0 -inf.0) +(test-nan.0 expt 1.0 +nan.0) + +(test 0.0 expt 0.0 5) +(test -0.0 expt -0.0 5) +(test 0.0 expt 0.0 4) +(test 0.0 expt -0.0 4) +(test 0.0 expt 0.0 4.3) +(test 0.0 expt -0.0 4.3) + +(test 0.0 expt 0.5 +inf.0) +(test +inf.0 expt 0.5 -inf.0) +(test +inf.0 expt 1.5 +inf.0) +(test 0.0 expt 1.5 -inf.0) +(test 0.0 expt -0.5 +inf.0) +(test +inf.0 expt -0.5 -inf.0) +(test +inf.0 expt -1.5 +inf.0) +(test 0.0 expt -1.5 -inf.0) + +(error-test '(expt 0 -1) exn:application:divide-by-zero?) +(error-test '(expt 0 -1.0) exn:application:divide-by-zero?) +(error-test '(expt 0 -inf.0) exn:application:divide-by-zero?) +(error-test '(expt 0 -1+2i) exn:application:divide-by-zero?) +(error-test '(expt 0 -1.0+2i) exn:application:divide-by-zero?) +(error-test '(expt 0 0+2i) exn:application:divide-by-zero?) +(error-test '(expt 0 0.0+2i) exn:application:divide-by-zero?) +(error-test '(expt 0 -0.0+2i) exn:application:divide-by-zero?) +(error-test '(expt 0 0+0.0i) exn:application:divide-by-zero?) + +(error-test '(expt 'a 0)) +(error-test '(expt 'a 1)) +(error-test '(expt 'a 3)) +(error-test '(expt 0 'a)) +(error-test '(expt 1 'a)) +(error-test '(expt 3 'a)) + +;;;;From: fred@sce.carleton.ca (Fred J Kaudel) +;;; Modified by jaffer. +(define f3.9 (string->number "3.9")) +(define f4.0 (string->number "4.0")) +(define f-3.25 (string->number "-3.25")) +(define f.25 (string->number ".25")) +(define f4.5 (string->number "4.5")) +(define f3.5 (string->number "3.5")) +(define f0.0 (string->number "0.0")) +(define f0.8 (string->number "0.8")) +(define f1.0 (string->number "1.0")) +(newline) +(display ";testing inexact numbers; ") +(newline) +(SECTION 6 5 5) +(test #t inexact? f3.9) +(test #f exact? f3.9) +(test #t 'inexact? (inexact? (max f3.9 4))) +(test f4.0 'max (max f3.9 4)) +(test f4.0 'exact->inexact (exact->inexact 4)) + +; Should at least be close... +(test 4.0 round (log (exp 4.0))) +(test 125.0 round (* 1000 (asin (sin 0.125)))) +(test 125.0 round (* 1000 (asin (sin 0.125+0.0i)))) +(test 125.0 round (* 1000 (asin (sin 1/8)))) +(test 125.0 round (* 1000 (acos (cos 0.125)))) +(test 125.0 round (* 1000 (acos (cos 0.125+0.0i)))) +(test 125.0 round (* 1000 (acos (cos 1/8)))) +(test 785.0 round (* 1000 (atan 1 1))) +(test 785.0 round (* 1000 (atan 1.0 1.0))) +(test 785.0 round (* 1000 (atan 1.0 1.0+0.0i))) +(test 785.0 round (* 1000 (atan 1.0+0.0i 1.0))) +(test 2356.0 round (* 1000 (atan 1 -1))) +(test -785.0 round (* 1000 (atan -1 1))) +(test 785.0 round (* 1000 (atan 1))) +(test 100.0 round (* 100 (tan (atan 1)))) +(test 100.0 round (* 100 (tan (+ +0.0i (atan 1))))) +(test 0.0 atan 0.0 0) +(error-test '(atan 0 0) exn:application:divide-by-zero?) +(test 1024.0 round (expt 2.0 10.0)) +(test 1024.0 round (expt -2.0 10.0)) +(test -512.0 round (expt -2.0 9.0)) +(test 32.0 round (sqrt 1024.0)) +(test 32.0 round (sqrt 1024.0+0.0i)) + +(test 1 exp 0) +(test 1.0 exp 0.0) +(test 1.0 exp -0.0) +(test 272.0 round (* 100 (exp 1))) + +(test 0 log 1) +(test 0.0 log 1.0) +(test -inf.0 log 0.0) +(test -inf.0 log -0.0) +(error-test '(log 0) exn:application:divide-by-zero?) + +(test 1 cos 0) +(test 1.0 cos 0.0) +(test 0 sin 0) +(test 0.0 sin 0.0) +(test -0.0 sin -0.0) +(test 0 tan 0) +(test 0.0 tan 0.0) +(test -0.0 tan -0.0) + +(test 0 atan 0) +(test 0.0 atan 0.0) +(test -0.0 atan -0.0) +(test 314.0 round (* 400 (atan 1))) +(test 314.0 round (* 400 (atan 1.0))) +(test 0 asin 0) +(test 0.0 asin 0.0) +(test -0.0 asin -0.0) +(test 314.0 round (* 200 (asin 1))) +(test 314.0 round (* 200 (asin 1.0))) +(test 0 acos 1) +(test 0.0 acos 1.0) +(test 314.0 round (* 200 (acos 0))) +(test 314.0 round (* 200 (acos 0.0))) +(test 314.0 round (* 200 (acos -0.0))) + +(define (test-inf-bad f) + (test-nan.0 f +inf.0) + (test-nan.0 f -inf.0) + (test-nan.0 f +nan.0)) + +(test-inf-bad tan) +(test-inf-bad sin) +(test-inf-bad cos) +(test-inf-bad asin) +(test-inf-bad acos) + +(test 11/7 rationalize (inexact->exact (atan +inf.0 1)) 1/100) +(test -11/7 rationalize (inexact->exact (atan -inf.0 1)) 1/100) +(test 0.0 atan 1 +inf.0) +(test 22/7 rationalize (inexact->exact (atan 1 -inf.0)) 1/100) + +; Note on the following tests with atan and inf.0: +; The IEEE standard makes this decision. I think it's a bad one, +; since (limit (atan (g x) (f x))) as x -> +inf.0 is not necessarily +; (atan 1 1) when (limit (f x)) and (limit (g x)) are +inf.0. +; Perhaps IEEE makes this choice because it's easiest to compute. +(test 7/9 rationalize (inexact->exact (atan +inf.0 +inf.0)) 1/100) +(test 26/11 rationalize (inexact->exact (atan +inf.0 -inf.0)) 1/100) +(test -7/9 rationalize (inexact->exact (atan -inf.0 +inf.0)) 1/100) + +(test-nan.0 atan +nan.0) +(test-nan.0 atan 1 +nan.0) +(test-nan.0 atan +nan.0 1) + +(test -1178.+173.i z-round (* 1000 (atan -2+1i))) + +(map (lambda (f fname) + (error-test `(,fname "a")) + (arity-test f 1 1)) + (list log exp asin acos tan) + `(log exp asin acos tan)) +(error-test '(atan "a" 1)) +(error-test '(atan 2+i 1)) +(error-test '(atan "a")) +(error-test '(atan 1 "a")) +(error-test '(atan 1 2+i)) +(arity-test atan 1 2) + +(test 3166.+1960.i z-round (* 1000 (sin 1+2i))) +(test -3166.-1960.i z-round (* 1000 (sin -1-2i))) +(test 0+1175.i z-round (* 1000 (sin 0+i))) +(test -642.-1069.i z-round (* 1000 (cos 2+i))) +(test -642.-1069.i z-round (* 1000 (cos -2-i))) +(test 1543. z-round (* 1000 (cos 0+i))) +(test 272-1084.i z-round (* 1000 (tan 1-i))) +(test -272+1084.i z-round (* 1000 (tan -1+i))) + +(test 693.+3142.i z-round (* 1000 (log -2))) +(test 1571.-1317.i z-round (* 1000 (asin 2))) +(test -1571.+1317.i z-round (* 1000 (asin -2))) +(test 0+3688.i z-round (* 1000 (acos 20))) +(test 3142.-3688.i z-round (* 1000 (acos -20))) + +(define (cs2 c) (+ (* (cos c) (cos c)) (* (sin c) (sin c)))) +(test 0.0 imag-part (cs2 2+3i)) +(test 1000.0 round (* 1000 (real-part (cs2 2+3i)))) +(test 0.0 imag-part (cs2 -2+3i)) +(test 1000.0 round (* 1000 (real-part (cs2 -2+3i)))) +(test 0.0 imag-part (cs2 2-3i)) +(test 1000.0 round (* 1000 (real-part (cs2 2-3i)))) + +(test #t positive? (real-part (sqrt (- 1 (* 2+3i 2+3i))))) + +(test (- f4.0) round (- f4.5)) +(test (- f4.0) round (- f3.5)) +(test (- f4.0) round (- f3.9)) +(test f0.0 round f0.0) +(test f0.0 round f.25) +(test f1.0 round f0.8) +(test f4.0 round f3.5) +(test f4.0 round f4.5) +(let ((x (string->number "4195835.0")) + (y (string->number "3145727.0"))) + (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) + +(test (exact->inexact 1/3) rationalize .3 1/10) +(test 1/3 rationalize 3/10 1/10) +(test (exact->inexact 1/3) rationalize .3 -1/10) +(test 1/3 rationalize 3/10 -1/10) +(test 0 rationalize 3/10 4/10) +(test 0.0 rationalize .3 4/10) +(test 0.0 rationalize .3+0.0i 4/10) +(test #i1/3 rationalize .3+0.0i 1/10) + +(define (test-rat-inf v) + (define zero (if (exact? v) 0 0.0)) + + (test +inf.0 rationalize +inf.0 v) + (test -inf.0 rationalize -inf.0 v) + (test-nan.0 rationalize +nan.0 v) + + (test zero rationalize v +inf.0) + (test zero rationalize v -inf.0) + (test-nan.0 rationalize v +nan.0)) + +(let loop ([i 100]) + (unless (= i -100) + (test (/ i 100) rationalize (inexact->exact (/ i 100.0)) 1/100000) + (loop (sub1 i)))) + +(arity-test rationalize 2 2) + +(define tb + (lambda (n1 n2) + (= n1 (+ (* n2 (quotient n1 n2)) + (remainder n1 n2))))) + + +(SECTION 6 5 5) + +(test -2147483648 - 2147483648) +(test 2147483648 - -2147483648) +(test #f = -2147483648 2147483648) +(test #t = -2147483648 -2147483648) +(test #t = 2147483648 2147483648) +(test 2147483647 sub1 2147483648) +(test 2147483648 add1 2147483647) +(test 2147483648 * 1 2147483648) + +(test 437893890380859375 expt 15 15) + +(test 0 modulo -2177452800 86400) +(test 0 modulo 2177452800 -86400) +(test 0 modulo 2177452800 86400) +(test 0 modulo -2177452800 -86400) + +(test 86399 modulo -2177452801 86400) +(test -1 modulo 2177452799 -86400) +(test 1 modulo 2177452801 86400) +(test -86399 modulo -2177452799 -86400) + +(test #t 'remainder (tb 281474976710655 65535)) +(test #t 'remainder (tb 281474976710654 65535)) +(SECTION 6 5 6) +(test 281474976710655 string->number "281474976710655") +(test "281474976710655" number->string 281474976710655) +(test "-4" number->string -4 16) +(test "-e" number->string -14 16) +(test "0" number->string 0 16) +(test "30000000" number->string #x30000000 16) + + +(SECTION 6 5 6) +(test "0" number->string 0) +(test "100" number->string 100) +(test "100" number->string 256 16) +(test 256 string->number "100" 16) +(test 15 string->number "#o17") +(test 15 string->number "#o17" 10) + +(load-relative "numstrs.ss") +(let loop ([l number-table]) + (unless (null? l) + (let* ([pair (car l)] + [v (car pair)] + [v (if (or (eq? v 'X) + (symbol? v) + (eof-object? v)) + #f + v)] + [s (cadr pair)]) + (test v string->number s)) + (loop (cdr l)))) + +;; Test special inexact names in complex combinations: +(let ([parts '(+inf.0 -inf.0 +nan.0 1 0 0.0 1/2)]) + (for-each + (lambda (a) + (for-each + (lambda (b) + (let ([rect (format "~a~a~ai" + a + (if (member b '(+inf.0 -inf.0 +nan.0)) + "" + "+") + b)] + [polar (format "~a@~a" a b)]) + (test (make-rectangular a b) string->number rect) + (test (make-polar a b) string->number polar))) + parts)) + parts) + + (for-each + (lambda (a) + (let ([rect1 (format "~a+1/0i" a)] + [rect2 (format "1/0~a~ai" + (if (member a '(+inf.0 -inf.0 +nan.0)) + "" + "+") + a)] + [polar1 (format "~a@1/0" a)] + [polar2 (format "1/0@~a" a)] + [dbz-test (lambda (s) + (test 'div 'divide-by-zero + (with-handlers ([(lambda (x) + (and (exn:read? x) + (regexp-match "division by zero" + (exn-message x)))) + (lambda (x) 'div)]) + (read (open-input-string s)))))]) + (test #f string->number rect1) + (test #f string->number rect2) + (test #f string->number polar1) + (test #f string->number polar2) + (dbz-test rect1) + (dbz-test rect2) + (dbz-test polar1) + (dbz-test polar2))) + parts)) + +(test #f string->number "88" 7) +(test #f string->number "") +(test #f string->number " 1") +(test #f string->number ".") +(test #f string->number "#4@#i5") +(test #f string->number "190888 qwerqwerq") +(test #t symbol? '1/x) +(test #t symbol? '1+ei) +(test #t symbol? '|1/0|) + +(arity-test string->number 1 2) +(arity-test number->string 1 2) + +(error-test '(number->string 'a)) +(error-test '(number->string 1 'a)) +(error-test '(number->string 'a 10)) +(error-test '(number->string 1.8 8) exn:application:mismatch?) +(error-test '(number->string 1 -1)) + +(error-test '(string->number 'a)) +(error-test '(string->number 'a 'a)) +(error-test '(string->number "12" -1)) +(error-test '(string->number "12" 17)) +(error-test '(string->number "1" "1")) +(error-test '(string->number 1 1)) + +(test #t andmap (lambda (x) (and (>= x 0) (< x 10))) (map random '(10 10 10 10))) +(test (void) random-seed 5) +(test (begin (random-seed 23) (list (random 10) (random 20) (random 30))) + 'random-seed-same + (begin (random-seed 23) (list (random 10) (random 20) (random 30)))) +(arity-test random-seed 1 1) +(arity-test random 1 1) +(error-test '(random-seed "apple")) +(error-test '(random-seed 4.5)) +(error-test '(random-seed -1)) +(error-test '(random-seed (expt 2 31))) +(error-test '(random-seed big-num)) +(error-test '(random "apple")) +(error-test '(random 0)) +(error-test '(random -6)) +(error-test '(random (expt 2 31))) +(error-test '(random big-num)) + +(random-seed 101) +(define x (list (random 10) (random 20) (random 30))) +(random-seed 101) +(parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) + (random 10) + (random 10)) +(test x 'generator-preserved (list (random 10) (random 20) (random 30))) +(random-seed 101) +(thread-wait (thread (lambda () + (random 10) + (random 10)))) +(test #f 'generator-not-preserved (equal? x (list (random 10) (random 20) (random 30)))) +(test #t pseudo-random-generator? (make-pseudo-random-generator)) +(test #t pseudo-random-generator? (current-pseudo-random-generator)) +(test #f pseudo-random-generator? 10) +(arity-test pseudo-random-generator? 1 1) +(arity-test make-pseudo-random-generator 0 0) +(arity-test current-pseudo-random-generator 0 1) +(error-test '(current-pseudo-random-generator 10)) + +(report-errs) diff --git a/collects/tests/mzscheme/numstrs.ss b/collects/tests/mzscheme/numstrs.ss new file mode 100644 index 00000000..a337b9d1 --- /dev/null +++ b/collects/tests/mzscheme/numstrs.ss @@ -0,0 +1,168 @@ + +(define number-table + `((,(+ 1/2 +i) "1/2+i") + (100 "100") + (0.1 ".1") + (1/20000 "#e1/2e-4") + (10.0 "1e1") + (10.0 "1E1") + (10.0 "1s1") + (10.0 "1S1") + (10.0 "1f1") + (10.0 "1F1") + (10.0 "1l1") + (10.0 "1L1") + (10.0 "1d1") + (10.0 "1D1") + (0.0 "0e13") + (0.0 "#i0") + (-0.0 "#i-0") + (+inf.0 ".3e2666666666") + (+inf.0 "+INF.0") + (+nan.0 "+NaN.0") + (+inf.0 "1e500") ; Check simple overflows + (-inf.0 "-1e500") + (0.0 "1e-500") + (-0.0 "-1e-500") + (+inf.0 "1#e500") + (-inf.0 "-1#e500") + (0.0 "1#e-500") + (-0.0 "-1#e-500") + (+inf.0 "1e10000000000000000000000000000000") ; Check avoidance of extreme computations + (-inf.0 "-1e10000000000000000000000000000000") + (+inf.0 "1#e10000000000000000000000000000000") + (-inf.0 "-1#e10000000000000000000000000000000") + (+0.0 "1e-10000000000000000000000000000000") + (-0.0 "-1e-10000000000000000000000000000000") + (+0.0 "1#e-10000000000000000000000000000000") + (-0.0 "-1#e-10000000000000000000000000000000") + (10.0 "1#") + (10.0 "1#e0") + (10.0 "1####e-3") + (10.0 "1#.e0") + (10.0 "10.#e0") + (10.0 "10.e0") + (10.0 "1#.e0") + (10.0 "10.0#e0") + (10.0 "1#.##e0") + (10 "#e1#") + (10 "#e1#e0") + (10 "#e1#.e0") + (5e-5 "1/2e-4") + (5e-5 "#i1/2e-4") + (0.5 "#i1/2") + (1/2 "#e1/2") + (0.5 "#i0.5") + (1/2 "#e0.5") + (1/20 "#e0.5e-1") + (1/20 "#e0.005e1") + (1.0+0.5i "1+0.5i") + (1/2 "1/2@0") + (-1/2 "-1/2@0") + (1/2 "1/2@-0") + (0 "#b#e0") + (0.0 "#b#i0") + (4.0 "#b1e10") + (4 "#b#e1e10") + (1/10+1/5i "#e0.1+0.2i") + (0.0+80.0i "#i+8#i") + (521976 "#x7f6f8") + (1+8i "#b#e1+1#e10i") + (1.125 "#x1.2") + (1.1640625 "#x1.2a") + (1.1640625 "#x1.2a####") + (10.0 "#xa.") + (10.25 "#xa.4") + (160.0 "#xa#.") + (416.0 "#x1a#.") + (2816.0 "#xb##.##") + + (#f "d") + (D "D") + (#f "i") + (I "I") + (#f "3i") + (3I "3I") + (#f "33i") + (33I "33I") + (#f "3.3i") + (3.3I "3.3I") + (#f "e") + (#f "e1") + (#f "e1") + (#f "-") + (#f "+") + (X "#e-") + (X "#e+") + (X "#i-") + (X "#i+") + (#f "+.") + (X "#e+.") + (#f "/") + (#f "+1+1") + (#f "+1/+1") + (#f "1//2") + (#f "mod//") + (#f "-1.0/2") + (#f "/2") + (#f "2..") + (#f ".2.") + (X "#e2..") + (X "#e.2.") + (#f "1#.0e4") + (#f "1#0e4") + (#f "1#0.e4") + (#f "1##.##0e4") + (#f "2i") + (#f "/2i") + (#f "2@2i") + (#f "2@@2") + (#f "-2@-+2") + (#f "1/1-e4") + (#f "1.-2") + (#f "--1") + (#f "-+1") + (#f "-1+3-4") + (X "#xg") + (X "#xa#a") + (X "#x12.a#b") + (X "#e1.-2") + (X "#b#b0") + (X "#b#o0") + (X "#i#i0") + (X "#e#e0") + (X "#i8#i") + (X "#i4@#i5") + (X "#i4+#d6i") + (X "#i4+#d6") + (#f "4ef5") + (X "#e4ef5") + (X "1/0") + (X "5+1/0i") + (X "1/0+5i") + (X "5@1/0") + (X "1/0@5") + (X "1/0e2") + (#f "1/0+hi") + (#f "x+1/0i") + (+nan.0+1i "+nan.0+1i") + (1+nan.0i "1+nan.0i") + (#f "1++nan.0i") + (0.5+nan.0i "1/2+nan.0i") + (1+inf.0i "1+inf.0i") + (1-inf.0i "1-inf.0i") + (-inf.0-nan.0i "-inf.0-nan.0i") + (#f "1++inf.0i") + (+nan.0@1 "+nan.0@1") + (+inf.0@1 "+inf.0@1") + (#f "+inf.0@1@1") + (1@+inf.0 "1@+inf.0") + (1@+inf.0 "1/1@+inf.0") + (+inf.0@1 "+inf.0@1/1") + (#f "+inf.0@3@0") + (X "1/0+inf.0i") + (X "+inf.0+1/0i") + (X "1/0@+inf.0") + (X "+inf.0@1/0") + (#f "1e1/0") + (#f "011111122222222223333333333444444x"))) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss new file mode 100644 index 00000000..2e0fc57b --- /dev/null +++ b/collects/tests/mzscheme/object.ss @@ -0,0 +1,651 @@ + +; Test MzScheme's object system + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'OBJECT) + +(define (test-class* cl* renames) + (syntax-test `(,cl*)) + (syntax-test `(,cl* ,@renames . x)) + (syntax-test `(,cl* ,@renames 0)) + (syntax-test `(,cl* ,@renames object% . x)) + (syntax-test `(,cl* ,@renames object% 0)) + (syntax-test `(,cl* ,@renames object% x)) + (syntax-test `(,cl* ,@renames object% ())) + (syntax-test `(,cl* ,@renames object% () (0) x)) + (syntax-test `(,cl* ,@renames object% () 0)) + (syntax-test `(,cl* ,@renames object% () . x)) + (syntax-test `(,cl* ,@renames object% () () . x)) + (syntax-test `(,cl* ,@renames object% () () x)) + (syntax-test `(,cl* ,@renames object% () () public)) + (syntax-test `(,cl* ,@renames object% () () (x))) + (syntax-test `(,cl* ,@renames object% () (x) ())) + + (let () + (define (try-dotted cl) + (syntax-test `(,cl* ,@renames object% () () (,cl . x)))) + + (map try-dotted '(public override private inherit rename + inherit-from rename-from + sequence))) + + (let () + (define (try-defn-kind cl) + (syntax-test `(,cl* ,@renames object% () () (,cl 8))) + (syntax-test `(,cl* ,@renames object% () () (,cl [8 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(x) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(x y x) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [x . 1]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [x 1 . 3]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [x 1 3])))) + + (try-defn-kind 'public) + (try-defn-kind 'override) + (try-defn-kind 'private)) + + (let () + (define (try-defn-rename-kind cl) + (syntax-test `(,cl* ,@renames object% () () (,cl [((x) y) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(x (y)) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(x . y) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(x 1) 9]))) + (syntax-test `(,cl* ,@renames object% () () (,cl [(1 x) 9])))) + (try-defn-rename-kind 'public) + (try-defn-rename-kind 'override)) + + (let () + (define (try-ref-kind cl) + (syntax-test `(,cl* ,@renames object% () () (,cl 8))) + (syntax-test `(,cl* ,@renames object% () () (,cl x 8))) + (syntax-test `(,cl* ,@renames object% () () (,cl (x . y)))) + (syntax-test `(,cl* ,@renames object% () () (,cl (x y z))))) + + (map try-ref-kind '(inherit rename share))) + (error-test `(,cl* ,@renames object% () () (inherit x)) exn:object?) + (error-test `(,cl* ,@renames object% () () (inherit (x y))) exn:object?) + (error-test `(,cl* ,@renames object% () () (override [x void])) exn:object?) + (error-test `(,cl* ,@renames object% () () (override [(x y) void])) exn:object?) + (syntax-test `(,cl* ,@renames object% () () (inherit (x y z)))) + (syntax-test `(,cl* ,@renames object% () () (inherit (x 5)))) + (syntax-test `(,cl* ,@renames object% () () (inherit (x)))) + (syntax-test `(,cl* ,@renames object% () () (rename x))) + (syntax-test `(,cl* ,@renames object% () () (rename (x)))) + (syntax-test `(,cl* ,@renames object% () () (rename ((x) y)))) + (syntax-test `(,cl* ,@renames object% () () (rename ((x y) y)))) + (syntax-test `(,cl* ,@renames object% () () (rename ((1) y)))) + + (syntax-test `(,cl* ,@renames object% () () (inherit x) (sequence (set! x 5)))) + (syntax-test `(,cl* ,@renames object% () () (rename [x y]) (sequence (set! x 5)))) + + (syntax-test `(,cl* ,@renames object% () () (sequence 1 . 2))) + + (syntax-test `(,cl* ,@renames object% () () (public [x 7] [x 9]))) + (syntax-test `(,cl* ,@renames object% () (x) (public [x 7]))) + (syntax-test `(,cl* ,@renames object% () (x) (public [(x w) 7]))) + (syntax-test `(,cl* ,@renames object% () () (public [(x y) 7] [(z y) 9]))) + (syntax-test `(,cl* ,@renames object% () () (public [(x y) 7] [(x z) 9]))) + + (syntax-test `(,cl* ,@renames object% a ())) + (syntax-test `(,cl* ,@renames object% (1 . a) ()))) + +(test-class* 'class* ()) +(test-class* 'class*/names '((this super))) + +(syntax-test `(class*/names 8 object% () () ())) +(syntax-test `(class*/names () object% () ())) +(syntax-test `(class*/names (8) object% () ())) +(syntax-test `(class*/names (this . 8) object% () ())) +(syntax-test `(class*/names (this 8) object% () ())) +(syntax-test `(class*/names (this super-init . 8) object% () ())) +(syntax-test `(class*/names (this super-init 8) object% () ())) + +(test #t class? (class* object% () ())) +(test #t class? (class* object% () ())) +(test #t class? (class* object% () x)) +(test #t class? (class* object% () () (public))) +(test #t class? (class* object% () () (public sequence))) +(test #t class? (class* object% () (x) (public [(y x) 9]))) +(test #t class? (class*/names (this super-init) object% () () (public))) + +(define c (class object% () (public x))) +(error-test `(class c () (public x)) exn:object?) +(error-test `(class c () (public ([y x] 5))) exn:object?) +(error-test `(class c () (override ([x y] 5))) exn:object?) + +(syntax-test `(interface)) +(syntax-test `(interface . x)) +(syntax-test `(interface 8)) +(syntax-test `(interface () 8)) +(syntax-test `(interface () x . y)) +(syntax-test `(interface () x 8)) +(syntax-test `(interface () x x)) +(error-test `(interface (8) x) exn:object?) + +(error-test `(interface ((class->interface (class object% ())) + (class->interface (class object% ())))) + exn:object?) + +(error-test `(interface ((interface () x)) x) exn:object?) +(error-test `(interface ((interface ((interface () x)) y)) x) exn:object?) +(test #t interface? (let ([i (interface () x)] + [j (interface () x)]) + (interface (i j) y))) +(error-test `(let ([i (interface () x)] + [j (interface () x)]) + (interface (i j) x)) + exn:object?) +(error-test `(interface ((class->interface (class object% () (public w)))) w) + exn:object?) + +(test #t interface? (interface ())) +(test #t interface? (interface () x)) +(test #f interface? (class* object% () ())) + +(define i0.1 (interface () x y)) +(define i0.2 (interface () y c d)) +(define i1 (interface (i0.1 i0.2) e)) +(define ix (interface () x y)) + +(test #t interface-extension? i1 i0.1) +(test #t interface-extension? i1 i0.2) +(test #f interface-extension? i0.1 i1) +(test #f interface-extension? i0.2 i1) +(test #f interface-extension? i0.2 i0.1) +(test #f interface-extension? i0.1 i0.2) + +(error-test '(let [(bad (class* object% (i0.1) ()))] bad) exn:object?) +(test #t class? (class* object% (i0.1) () (public x y))) +(error-test '(let ([cl (class* object% (i0.1 i0.2) () (public x y c))]) cl) exn:object?) +(error-test '(class* object% (i1) () (public x y c)) exn:object?) +(test #t class? (class* object% (i0.1 i0.1) () (public x y c d))) +(error-test '(class* object% (i1) () (public x y c d)) exn:object?) +(test #t class? (class* object% (i1) () (public x y c d e))) + +; No initialization: +(define no-init-c% (class* object% () ())) +(error-test '(make-object no-init-c%) exn:object?) + +(define c1 + (let ((v 10)) + (class* object% (i1) (in [in-2 'banana] . in-rest) + (public (x 1) (y 2)) + (private (a in) (b3 3)) + (public (b1 2) (b2 2) (e 0)) + (public (c 3) (d 7) + (f-1-a (lambda () a)) + (f-1-b1 (lambda () b1)) + (f-1-b2 (lambda () b2)) + (f-1-c (lambda () c)) + (f-1-v (lambda () v)) + (f-1-x (lambda () x)) + (f-1-top-a (lambda () (ivar this a))) + (f-1-other-e (lambda (o) (ivar o e))) + (f-1-set-b2 (lambda (v) (set! b2 v) b2)) + (f-1-in-2 (lambda () in-2)) + (f-1-in-rest (lambda () in-rest))) + (sequence + (set! e in) + (super-init))))) + +(test #t implementation? c1 i0.1) +(test #t implementation? c1 i0.2) +(test #t implementation? c1 (class->interface c1)) +(test #t implementation? c1 i1) +(test #f implementation? c1 ix) + +(test #t implementation? object% (class->interface object%)) +(test #t implementation? c1 (class->interface c1)) +(test #t implementation? (class c1 ()) (class->interface c1)) +(let ([i (interface ((class->interface c1)))]) + (test #f implementation? c1 i) + (test #t implementation? (class* c1 (i) ()) i)) + +(define o1 (make-object c1 0 'apple "first" "last")) + +(define c2 + (let ((v 20)) + (class c1 () + (inherit b2 (sup-set-b2 f-1-set-b2)) + (rename (also-e e) + (also-b2 b2)) + (override (b1 5) (c 6)) + (public (a 4) + (f-2-a (lambda () a)) + (f-2-b1 (lambda () b1)) + (f-2-b2 (lambda () b2)) + (f-2-also-b2 (lambda () also-b2)) + (f-2-c (lambda () c)) + ((i-f-2-v f-2-v) (lambda () v)) + (f-2-v-copy (lambda () (i-f-2-v))) + (f-2-set-b2 (lambda (v) (sup-set-b2 v)))) + (private (y 3)) + (sequence + (super-init 1))))) + +(test #t implementation? c2 i0.1) +(test #t implementation? c2 i0.2) +(test #t implementation? c2 i1) +(test #f implementation? c2 ix) +(test #t implementation? c2 (class->interface c2)) +(test #t implementation? c2 (class->interface c1)) +(test #f implementation? c1 (class->interface c2)) + +(test #t interface-extension? (class->interface c2) (class->interface object%)) +(test #t interface-extension? (class->interface c2) (class->interface c1)) +(test #t interface-extension? (class->interface c2) (class->interface c2)) +(test #f interface-extension? (class->interface c1) (class->interface c2)) +(test #t interface-extension? (class->interface c2) i0.1) +(test #f interface-extension? i0.1 (class->interface c2)) + +(define o2 (make-object c2)) + +(define c2.1 + (class*/names (this c2-init) c2 () () + (sequence + (c2-init)))) + +(define o2.1 (make-object c2.1)) + +(test #t interface? (interface ((class->interface c2) + (class->interface c2.1)))) + +(define c3 + (class* object% () () + (public (x 6) (z 7) (b2 8) + (f-3-b2 (lambda () b2))) + (sequence (super-init)))) + +(define o3 (make-object c3)) + +(define c6 + (class object% (x-x) + (public + [(i-a x-a) (lambda () 'x-a)] + [(x-a i-a) (lambda () 'i-a)] + [(i-x x-x) (lambda () 'x-x)] + [x-a-copy (lambda () (i-a))] + [i-a-copy (lambda () (x-a))]) + (sequence (super-init)))) + +(define o6 (make-object c6 'bad)) + +(define c7 + (class*/names (self super-init) object% () () + (public + [get-self (lambda () self)]) + (sequence (super-init)))) + +(define o7 (make-object c7)) + +(define display-test + (lambda (p v) + (printf "Should be ~s: ~s ~a~n" + p v (if (equal? p v) + "" + "ERROR")))) + +(define ivar? exn:object?) + +(test #t is-a? o1 c1) +(test #t is-a? o1 i1) +(test #t is-a? o1 (class->interface c1)) +(test #f is-a? o1 (interface ((class->interface c1)))) +(test #t is-a? o2 c1) +(test #t is-a? o2 i1) +(test #f is-a? o1 c2) +(test #f is-a? o1 (class->interface c2)) +(test #t is-a? o2 c2) +(test #t is-a? o2.1 c1) +(test #f is-a? o1 c3) +(test #f is-a? o2 c3) +(test #f is-a? o1 ix) +(test #f is-a? o2 ix) +(test #f is-a? o3 i1) +(test #f is-a? i1 i1) +(test #t subclass? c2 c1) +(test #t subclass? c2.1 c1) +(test #f subclass? c1 c2) +(test #f subclass? c1 c3) +(test #f subclass? i1 c3) +(test #t ivar-in-interface? 'f-1-a (class->interface c1)) +(test #t ivar-in-interface? 'f-1-a (class->interface c2)) +(test #f ivar-in-interface? 'f-2-a (class->interface c1)) +(test #t ivar-in-interface? 'f-2-a (class->interface c2)) +(test #t ivar-in-interface? 'x i0.1) +(test #t ivar-in-interface? 'x i1) +(test #f ivar-in-interface? 'x i0.2) +(test #f ivar-in-interface? 'c i0.1) +(test #t ivar-in-interface? 'c i0.2) +(test #t ivar-in-interface? 'c i1) +(test #f ivar-in-interface? 'zzz i1) +(test #t ivar-in-interface? 'f-1-a (class->interface c2)) +(test #t ivar-in-interface? 'f-1-a (interface ((class->interface c2)) one-more-method)) +(test #f ivar-in-interface? 'f-2-a (class->interface c1)) + +(error-test '(is-a? o1 o1)) +(error-test '(subclass? o1 o1)) +(error-test '(subclass? o1 i1)) +(error-test '(implementation? o1 o1)) +(error-test '(implementation? o1 c1)) +(error-test '(ivar-in-interface? 0 i1)) +(error-test '(ivar-in-interface? 'a o1)) +(error-test '(ivar-in-interface? 'a c1)) +(error-test '(ivar-in-interface? 'a o1)) + +(define (test/list l1 l2) + (test #t 'ivar-list (and (= (length l1) + (length l2)) + (andmap (lambda (i) (member i l2)) + l1) + #t))) + +(test/list '(hi there) + (interface->ivar-names + (interface () hi there))) +(test/list '(hi too mee there) + (interface->ivar-names + (interface ((interface () hi there)) mee too))) +(test/list '(hi too mee z y there) + (interface->ivar-names + (interface ((interface ((class->interface + (class object% () + (public y z) + (private nono)))) + hi there)) + mee too))) + + +(test 0 class-initialization-arity object%) +(test #t arity-at-least? (class-initialization-arity c1)) +(test 1 arity-at-least-value (class-initialization-arity c1)) +(test 0 class-initialization-arity c2) + +(test '(1 2) class-initialization-arity (class object% (a [b 2]))) + +(arity-test object? 1 1) +(arity-test class? 1 1) +(arity-test interface? 1 1) +(arity-test is-a? 2 2) +(arity-test subclass? 2 2) +(arity-test interface-extension? 2 2) +(arity-test ivar-in-interface? 2 2) +(arity-test class-initialization-arity 1 1) + +(arity-test ivar/proc 2 2) +(arity-test make-generic/proc 2 2) + +(error-test '(ivar o1 a) ivar?) +(test 4 ivar/proc o2 'a) + +(define (ivar-tests -ivar xtra-ok?) + (syntax-test `(,-ivar)) + (syntax-test `(,-ivar 7)) + (syntax-test `(,-ivar 7 8)) + (syntax-test `(,-ivar 7 (x))) + (syntax-test `(,-ivar 7 8 9)) + (unless xtra-ok? + (syntax-test `(,-ivar 7 x 9)))) +(ivar-tests 'ivar #f) +(ivar-tests 'send #t) +(ivar-tests 'make-generic #f) + +(test 0 'send (send o1 f-1-a)) +(test 1 'send (send o2 f-1-a)) +(test 4 'send (send o2 f-2-a)) + +(test 'apple 'send (send o1 f-1-in-2)) +(test 'banana 'send (send o2 f-1-in-2)) +(test '("first" "last") 'send (send o1 f-1-in-rest)) +(test '() 'send (send o2 f-1-in-rest)) + +(error-test '(send o1 f-1-top-a) ivar?) +(test 4 'send (send o2 f-1-top-a)) + +(test 5 ivar/proc o2 'b1) + +(test 2 'send (send o1 f-1-b1)) +(test 2 'send (send o1 f-1-b2)) +(test 5 'send (send o2 f-1-b1)) +(test 2 'send (send o2 f-1-b2)) +(test 5 'send (send o2 f-2-b1)) +(test 2 'send (send o2 f-2-b2)) +(test 2 'send (send o2 f-2-also-b2)) + +(test 3 ivar/proc o1 'c) +(test 6 ivar/proc o2 'c) + +(test 3 'send (send o1 f-1-c)) +(test 6 'send (send o2 f-1-c)) +(test 6 'send (send o2 f-2-c)) + +(test 7 ivar/proc o1 'd) +(test 7 ivar/proc o2 'd) + +(test 10 'send (send o1 f-1-v)) +(test 10 'send (send o2 f-1-v)) +(test 20 'send (send o2 f-2-v)) +(test 20 'send (send o2 f-2-v-copy)) + +(error-test '(ivar o2 i-f-2-v) ivar?) + +(test 0 'send (send o1 f-1-other-e o1)) +(test 1 'send (send o1 f-1-other-e o2)) + +(test 2 ivar/proc o2 'y) + +(test 3 'send (send o2 f-2-set-b2 3)) +(test 3 'send (send o2 f-2-also-b2)) + +(test 'i-a 'send (send o6 i-a)) +(test 'x-a 'send (send o6 x-a)) +(test 'i-a 'send (send o6 i-a-copy)) +(test 'x-a 'send (send o6 x-a-copy)) +(test 'x-x 'send (send o6 x-x)) + +(test #t eq? o7 (send o7 get-self)) + +(define g1 (make-generic c1 x)) +(test 1 g1 o1) +(test 1 g1 o2) +(arity-test g1 1 1) + +(error-test '(make-generic c1 www) exn:object?) + +(define g2 (make-generic c2 x)) +(test 1 g2 o2) + +(define g0 (make-generic i0.1 x)) +(test 1 g0 o1) +(test 1 g0 o2) +(arity-test g0 1 1) +(test 'hi g0 (make-object (class* object% (i0.1) () + (public [x 'hi][y 'bye]) + (sequence (super-init))))) + +(error-test '(make-generic i0.1 www) exn:object?) + +(error-test '(g2 o1) exn:object?) +(error-test '(g0 o3) exn:object?) + +(error-test '(class* 7 () ()) exn:object?) +(error-test '(class* null () ()) exn:object?) +(error-test '(let ([c (class* 7 () ())]) c) exn:object?) +(error-test '(class* object% (i1 7) ()) exn:object?) +(error-test '(let ([c (class* object% (i1 7) ())]) c) exn:object?) +(error-test '(interface (8) x) exn:object?) +(error-test '(let ([i (interface (8) x)]) i) exn:object?) +(error-test '(interface (i1 8) x) exn:object?) +(error-test '(make-generic c2 not-there) exn:object?) + +(error-test '(make-object (class* c1 () ())) exn:object?) +(error-test '(make-object (let ([c (class* c1 () ())]) c)) exn:object?) + +(error-test '(make-object + (class* c2 () () (sequence (super-init) (super-init)))) + exn:object?) +(error-test '(make-object + (let ([c (class* c2 () () (sequence (super-init) (super-init)))]) c)) + exn:object?) + +(error-test '(make-object (class object% (x))) exn:application:arity?) +(error-test '(make-object (let ([c (class object% (x))]) c)) exn:application:arity?) + + +(define c100 + (let loop ([n 99][c (class c1 args (public [z -1]) (sequence (apply super-init args)))]) + (if (zero? n) + c + (loop (sub1 n) (class c args + (override (z n)) + (sequence + (apply super-init args))))))) + +(define o100 (make-object c100 100)) +(test 100 'send (send o100 f-1-a)) +(test 1 'ivar (ivar o100 z)) + +(test 5 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init)))) g-x)) +(test 8 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init))) 0) g-x)) + +(test (letrec ([x x]) x) 'init (send (make-object + (class* object% () ([x y] [y x]) + (public (f (lambda () x))) + (sequence (super-init)))) + f)) + +(define inh-test-expr + (lambda (super derive-pre? rename? override? override-pre?) + (let* ([order + (lambda (pre? a b) + (if pre? + (list a b) + (list b a)))] + [base-class + `(class ,(if super + super + '(class object% (n) + (public [name (lambda () n)]) + (sequence (super-init)))) + () + ,(if (not rename?) + '(inherit name) + '(rename [super-name name])) + ,@(order + derive-pre? + `(public [w ,(if rename? 'super-name 'name)]) + '(sequence (super-init 'tester))))]) + `(ivar + (make-object + ,(if override? + `(class ,base-class () + ,@(order + override-pre? + '(sequence (super-init)) + '(override [name (lambda () 'o-tester)]))) + base-class)) + w)))) + +(define (do-override-tests super) + (define (eval-test v e) + (teval `(test ,v (quote, e) + (let ([v ,e]) + (if (procedure? v) + (v) + v))))) + + (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #f #f)) + (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #t #t)) + (eval-test '(letrec ([x x]) x) (inh-test-expr super #f #f #t #t)) + + (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #f #f)) + (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #f)) + (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #t)) + + (eval-test ''tester (inh-test-expr super #f #f #f #f)) + (eval-test ''o-tester (inh-test-expr super #t #f #t #f)) + (eval-test ''o-tester (inh-test-expr super #f #f #t #f)) + + (eval-test ''tester (inh-test-expr super #f #t #f #f)) + (eval-test ''tester (inh-test-expr super #f #t #t #t)) + (eval-test ''tester (inh-test-expr super #f #t #t #f))) + +(do-override-tests #f) + +(when (defined? 'primclass%) + (error-test '(make-object primclass%) exn:application:arity?) + (error-test '(make-object primsubclass%) exn:application:arity?) + + (let () + (define o (make-object primclass% 'tester)) + (arity-test (ivar o name) 0 0) + (test 'tester (ivar o name)) + (test "primclass%" (ivar o class-name)) + + (let () + (define o2 (make-object primsubclass% 'tester)) + (arity-test (ivar o2 name) 0 0) + (arity-test (ivar o2 detail) 0 0) + (test 'tester (ivar o2 name)) + (test #f (ivar o2 detail)) + (test "primsubclass%" (ivar o2 class-name)) + + (do-override-tests 'primclass%) + (do-override-tests 'primsubclass%) + + (let () + (define name-g (make-generic primclass% name)) + (define class-name-g (make-generic primclass% class-name)) + + (define sub-name-g (make-generic primsubclass% name)) + (define sub-class-name-g (make-generic primsubclass% class-name)) + (define sub-detail-g (make-generic primsubclass% detail)) + + (test 'tester (name-g o)) + (test "primclass%" (class-name-g o)) + + (test 'tester (name-g o2)) + (test "primsubclass%" (class-name-g o2)) + (test 'tester (sub-name-g o2)) + (test "primsubclass%" (sub-class-name-g o2)) + (test #f (sub-detail-g o2)) + + (let () + (define c% + (class primsubclass% () + (inherit name detail class-name) + (sequence (super-init 'example)) + (public + [n name] + [d detail] + [c class-name]))) + + (define o3 (make-object c%)) + (test 'example (ivar o3 n)) + (test #f (ivar o3 d)) + (test "primsubclass%" (ivar o3 c)) + (test 'example (ivar o3 name)) + (test #f (ivar o3 detail)) + (test "primsubclass%" (ivar o3 class-name)) + + (test 'example (name-g o3)) + (test "primsubclass%" (class-name-g o3)) + (test 'example (sub-name-g o3)) + (test "primsubclass%" (sub-class-name-g o3)) + (test #f (sub-detail-g o3))))))) + + +; Test for override/rename order +(define bsc (class object% () + (public [x (lambda () 10)]) + (sequence (super-init)))) +(define orc (class bsc () + (public [y (lambda () (super-x))]) + (override [x (lambda () 20)]) + (rename [super-x x]) + (sequence (super-init)))) +(test 10 (ivar (make-object orc) y)) + +(report-errs) + diff --git a/collects/tests/mzscheme/oe.ss b/collects/tests/mzscheme/oe.ss new file mode 100644 index 00000000..b2b17406 --- /dev/null +++ b/collects/tests/mzscheme/oe.ss @@ -0,0 +1,42 @@ +(define-values (odd) (lambda (x) (if (zero? x) #f (even (- x 1))))) +(define-values (even) (lambda (x) (if (zero? x) #t (odd (- x 1))))) + +(define-values (odd2) + (letrec ([even (lambda (x) (if (zero? x) #t (odd (- x 1))))] + [odd (lambda (x) (if (zero? x) #f (even (- x 1))))]) + odd)) + +(define-values (odd3) + (let ([test (lambda (base other) + (lambda (x) (if (zero? x) base ((other) (- x 1)))))]) + (letrec ([odd (test #f (lambda () even))] + [even (test #t (lambda () odd))]) + odd))) + +(define-values (fib) + (lambda (n) + (if (<= n 1) + 1 + (+ (fib (- n 1)) (fib (- n 2)))))) + +(define-values (mutate) + (lambda (n) + (let loop () + (unless (zero? n) + (set! n (sub1 n)) + (loop))))) + +(define-values (mutate-evil) + (lambda (n) + (let loop ([n n]) + (unless (zero? n) + (set! n (sub1 n)) + (loop n))))) + +(define-values (c-loop) + (let-values ([(a b c d e f g) (values 1 2 3 4 5 6 7)]) + (lambda (n) + (let loop ([n n]) + (if (zero? n) + (+ a b c d e f g) + (loop (sub1 n))))))) diff --git a/collects/tests/mzscheme/oee.ss b/collects/tests/mzscheme/oee.ss new file mode 100644 index 00000000..d7e70adf --- /dev/null +++ b/collects/tests/mzscheme/oee.ss @@ -0,0 +1,45 @@ + +; Test the oe extension + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init)))) +(define b3 (class object% () (public [z1 13][z2 14]) (sequence (super-init)))) + +(define i1 (mktinterface (interface () z1))) +(define i3 (mktinterface (interface () z2))) + +(define c1 (mktclass b1 i1)) +(define c3 (mktclass b3 i3)) + +(define o1 (make-object c1 1 2)) +(define o2 (make-object c1 3 4)) +(define o3 (make-object c3 5 6)) + +(test 5 'oee (send o1 get-y)) +(test 5 'oee (send o2 get-y)) +(test 5 'oee (send o3 get-y)) + +(test 7 'oee (send o1 get-z1)) +(test 7 'oee (send o2 get-z1)) +(test 13 'oee (send o3 get-z1)) + +(test 8 'oee (send o1 get-z2)) +(test 8 'oee (send o2 get-z2)) +(test 14 'oee (send o3 get-z2)) + +(test 1 'oee (send o1 get-x1)) +(test 3 'oee (send o2 get-x1)) +(test 5 'oee (send o3 get-x1)) + +(test 2 'oee (send o1 get-x2)) +(test 4 'oee (send o2 get-x2)) +(test 6 'oee (send o3 get-x2)) + +(error-test '(mktinterface 0) exn:object:interface-type?) +(error-test '(mktclass 0 i1) exn:object:class-type?) +(error-test '(mktclass b1 0) exn:object:interface-type?) +(error-test '(mktclass b1 (interface () not-there)) exn:object:implement?) + +(report-errs) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss new file mode 100644 index 00000000..3a54a747 --- /dev/null +++ b/collects/tests/mzscheme/optimize.ss @@ -0,0 +1,60 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'optimization) + +(define (comp=? c1 c2) + (let ([s1 (open-output-string)] + [s2 (open-output-string)]) + (write c1 s1) + (write c2 s2) + (string=? (get-output-string s1) (get-output-string s2)))) + +(define test-comp + (case-lambda + [(expr1 expr2) (test-comp expr1 expr2 #t)] + [(expr1 expr2 same?) + (test same? `(compile ,same? ,expr2) (comp=? (compile expr1) (compile expr2)))])) + +(test-comp 5 '(if #t 5 (cons 1 2))) +(test-comp 5 '(if #f (cons 1 2) 5)) + +(test-comp 5 '(begin0 5 'hi "apple" 1.5)) +(test-comp 5 '(begin0 5 (begin0 'hi "apple" 1.5))) +(test-comp 5 '(begin0 5 (begin0 'hi "apple") 1.5)) +(test-comp 5 '(begin0 5 (begin 'hi "apple" 1.5))) +(test-comp 5 '(begin0 5 (begin 'hi "apple") 1.5)) +(test-comp 5 '(begin0 (begin0 5 'hi "apple" 1.5))) +(test-comp 5 '(begin0 (begin0 5 'hi "apple") 1.5)) + +; Can't drop `begin0' if the first expresson is not valueable: +(test-comp '(begin0 (begin0 (+ 1 2) 0) 0) '(begin0 (begin0 (+ 1 2) 'hi "apple") 1.5)) + +(test-comp 5 '(begin 'hi "apple" 1.5 5)) +(test-comp 5 '(begin (begin 'hi "apple" 1.5) 5)) +(test-comp 5 '(begin (begin 'hi "apple") 1.5 5)) +(test-comp 5 '(begin (begin0 'hi "apple" 1.5) 5)) +(test-comp 5 '(begin (begin0 'hi "apple") 1.5 5)) +(test-comp 5 '(begin (begin 'hi "apple" 1.5 5))) +(test-comp 5 '(begin 'hi (begin "apple" 1.5 5))) + +(test-comp '(let ([x 8][y 9]) (lambda () x)) + '(let ([x 8][y 9]) (lambda () (if #f y x)))) +(test-comp '(let ([x 8][y 9]) (lambda () (+ x y))) + '(let ([x 8][y 9]) (lambda () (if #f y (+ x y))))) + +(test-comp '(let ([x 5]) (set! x 2)) '(let ([x 5]) (set! x x) (set! x 2))) + +(test-comp '(let* () (f 5)) + '(f 5)) +(test-comp '(letrec () (f 5)) + '(f 5)) +(test-comp '(with-handlers () (f 5)) + '(f 5)) +(test-comp '(parameterize () (f 5)) + '(f 5)) +(test-comp '(fluid-let () (f 5)) + '(f 5)) + +(report-errs) diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss new file mode 100644 index 00000000..67aae077 --- /dev/null +++ b/collects/tests/mzscheme/parallel.ss @@ -0,0 +1,57 @@ + +;; Runs 3 threads perfoming the test suite simultaneously. Each +;; thread creates a directory sub to run in, so that filesystem +;; tests don't collide. + +(unless (defined? 'parallel-load) + (global-defined-value 'parallel-load "quiet.ss")) + +; Runs n versions of test in parallel threads and namespaces, +; waiting until all are done +(define (parallel n test) + (let ([done (make-semaphore)] + [go (make-semaphore)]) + (let loop ([n n]) + (unless (zero? n) + (let ([ns (make-namespace)]) + (thread + (lambda () + (parameterize ([current-namespace ns]) + (let ([dirname (format "sub~s" n)]) + (when (directory-exists? dirname) + (delete-directory* dirname)) + (make-directory dirname) + (current-directory dirname) + (dynamic-wind + void + (lambda () + (load test)) + (lambda () + (semaphore-post done) + (semaphore-wait go) + (printf "~nThread ~s:" n) + (eval '(report-errs)) + (current-directory (build-path 'up)) + (delete-directory* dirname) + (semaphore-post done))))))) + (loop (sub1 n))))) + (let loop ([n n]) + (unless (zero? n) + (semaphore-wait done) + (loop (sub1 n)))) + (let loop ([n n]) + (unless (zero? n) + (semaphore-post go) + (semaphore-wait done) + (loop (sub1 n)))))) + +(define (delete-directory* dir) + (for-each (lambda (f) + (let ([f (build-path dir f)]) + (if (or (link-exists? f) (file-exists? f)) + (delete-file f) + (delete-directory* f)))) + (directory-list dir)) + (delete-directory dir)) + +(parallel 3 (path->complete-path parallel-load (current-load-relative-directory))) diff --git a/collects/tests/mzscheme/param.ss b/collects/tests/mzscheme/param.ss new file mode 100644 index 00000000..a35c5f07 --- /dev/null +++ b/collects/tests/mzscheme/param.ss @@ -0,0 +1,388 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'parameters) + +(let ([p (open-output-file "tmp5" 'replace)]) + (display (compile '(cons 1 2)) p) + (close-output-port p)) + +(define-struct tester (x)) +(define a-tester (make-tester 5)) + +(define (check-write-string display v s) + (let ([p (open-output-string)]) + (display v p) + (let ([s2 (get-output-string p)]) + (or (string=? s s2) + (error 'check-string "strings didn't match: ~s vs. ~s" + s s2))))) + +(define exn:check-string? exn:user?) + +(define called-break? #f) + +(define erroring-set? #f) + +(define erroring-port + (make-output-port (let ([orig (current-output-port)]) + (lambda (s) + (if erroring-set? + (begin + (set! erroring-set? #f) + (error 'output)) + (display s orig)))) + void)) + +(define erroring-eval + (let ([orig (current-eval)]) + (lambda (x) + (if erroring-set? + (begin + (set! erroring-set? #f) + (error 'eval)) + (orig x))))) + +(define blocking-thread + (lambda (thunk) + (let ([x #f]) + (thread-wait (thread (lambda () (set! x (thunk))))) + x))) + +(define main-cust (current-custodian)) + +(define zero-arg-proc (lambda () #t)) +(define one-arg-proc (lambda (x) #t)) +(define two-arg-proc (lambda (x y) #t)) +(define three-arg-proc (lambda (x y z) #t)) + +(define test-param1 (make-parameter 'one)) +(define test-param2 (make-parameter + 'two + ; generates type error: + (lambda (x) (if (symbol? x) + x + (add1 'x))))) + +(test 'one test-param1) +(test 'two test-param2) + +(arity-test make-parameter 1 2) +(error-test '(make-parameter 0 zero-arg-proc)) +(error-test '(make-parameter 0 two-arg-proc)) + +(define-struct bad-test (value exn?)) + +(define params (list + (list read-case-sensitive + (list #f #t) + '(if (eq? (read (open-input-string "HELLO")) (quote hello)) + (void) + (error (quote hello))) + exn:user? + #f) + (list read-square-bracket-as-paren + (list #t #f) + '(when (symbol? (read (open-input-string "[4]"))) + (error 'read)) + exn:user? + #f) + (list read-curly-brace-as-paren + (list #t #f) + '(when (symbol? (read (open-input-string "{4}"))) + (error 'read)) + exn:user? + #f) + (list read-accept-box + (list #t #f) + '(read (open-input-string "#&5")) + exn:read? + #f) + (list read-accept-graph + (list #t #f) + '(read (open-input-string "#0=(1 . #0#)")) + exn:read? + #f) + (list read-accept-compiled + (list #t #f) + '(let ([p (open-input-file "tmp5")]) + (dynamic-wind + void + (lambda () (read p)) + (lambda () (close-input-port p)))) + exn:read? + #f) + (list read-accept-bar-quote + (list #t #f) + '(let ([p (open-input-string "|hello #$ there| x")]) + (read p) + (read p)) + exn:read? + #f) + (list print-graph + (list #t #f) + '(check-write-string display (quote (#0=(1 2) . #0#)) "(#0=(1 2) . #0#)") + exn:check-string? + #f) + (list print-struct + (list #t #f) + '(check-write-string display a-tester "#(struct:tester 5)") + exn:check-string? + #f) + (list print-box + (list #t #f) + '(check-write-string display (box 5) "#&5") + exn:check-string? + #f) + (list print-vector-length + (list #t #f) + '(check-write-string write (vector 1 2 2) "#3(1 2)") + exn:check-string? + #f) + + (list current-input-port + (list (make-input-port (lambda () #\x) (lambda () #t) void) + (make-input-port (lambda () 5) (lambda () #t) void)) + '(read-char) + exn:i/o:port:user? + '("bad string")) + (list current-output-port + (list (current-output-port) + erroring-port) + '(begin + (set! erroring-set? #t) + (display 5) + (set! erroring-set? #f)) + exn:user? + '("bad string")) + +#| + ; Doesn't work since error-test sets the port! + (list current-error-port + (list (current-error-port) + erroring-port) + '(begin + (set! erroring-set? #t) + ((error-display-handler) "hello") + (set! erroring-set? #f)) + exn:user? + "bad setting") +|# + + (list compile-allow-cond-fallthrough + (list #t #f) + '(cond) + exn:else? + #f) + + (list compile-allow-set!-undefined + (list #t #f) + '(eval `(set! ,(gensym) 9)) + exn:variable? + #f) + + (list current-namespace + (list (make-namespace) + (make-namespace 'hash-percent-syntax)) + '(begin 0) + exn:variable? + '("bad setting")) + + (list error-print-width + (list 10 50) + '(when (< 10 (error-print-width)) (error 'print-width)) + exn:user? + '("bad setting")) + (list error-value->string-handler + (list (error-value->string-handler) (lambda (x w) (error 'converter))) + '(format "~e" 10) + exn:user? + (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc)) + + (list break-enabled + (list #t #f) + '(let ([cont? #f]) + (thread-wait + (thread + (lambda () + (break-thread (current-thread)) + (sleep) + (set! cont? #t)))) + (when cont? + (error 'break-enabled))) + exn:user? + #f) + + (list current-print + (list (current-print) + (lambda (x) (display "frog"))) + `(let ([i (open-input-string "5")] + [o (open-output-string)]) + (parameterize ([current-input-port i] + [current-output-port o]) + (read-eval-print-loop)) + (let ([s (get-output-string o)]) + (unless (char=? #\5 (string-ref s 2)) + (error 'print)))) + exn:user? + (list "bad setting" zero-arg-proc two-arg-proc)) + + (list current-prompt-read + (list (current-prompt-read) + (let ([x #f]) + (lambda () + (set! x (not x)) + (if x + '(quote hi) + eof)))) + `(let ([i (open-input-string "5")] + [o (open-output-string)]) + (parameterize ([current-input-port i] + [current-output-port o]) + (read-eval-print-loop)) + (let ([s (get-output-string o)]) + (unless (and (char=? #\> (string-ref s 0)) + (not (char=? #\h (string-ref s 0)))) + (error 'prompt)))) + exn:user? + (list "bad setting" one-arg-proc two-arg-proc)) + + (list current-load + (list (current-load) (lambda (f) (error "This won't do it"))) + '(load "tmp5") + exn:user? + (list "bad setting" zero-arg-proc two-arg-proc)) + (list current-eval + (list (current-eval) erroring-eval) + '(begin + (set! erroring-set? #t) + (eval 5) + (set! erroring-set? #f)) + exn:user? + (list "bad setting" zero-arg-proc two-arg-proc)) + + (list current-load-relative-directory + (list (current-load-relative-directory) + (build-path (current-load-relative-directory) 'up)) + '(load-relative "loadable.ss") + exn:i/o:filesystem? + (append (list 0) + (map + (lambda (t) + (make-bad-test t exn:i/o:filesystem?)) + (list + "definitely a bad path" + (string #\a #\nul #\b) + "relative" + (build-path 'up)))) + equal?) + + (list global-port-print-handler + (list write display) + '(let ([s (open-output-string)]) + (print "hi" s) + (unless (char=? #\" (string-ref (get-output-string s) 0)) + (error 'global-port-print-handler))) + exn:user? + (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc)) + + (list current-custodian + (list main-cust (make-custodian)) + '(let ([th (parameterize ([current-custodian main-cust]) + (thread (lambda () (sleep 1))))]) + (kill-thread th)) + exn:misc? + (list "bad setting")) + + (list exit-handler + (list void (lambda (x) (error 'exit-handler))) + '(exit) + exn:user? + (list "bad setting" zero-arg-proc two-arg-proc)) + + (list test-param1 + (list 'one 'bad-one) + '(when (eq? (test-param1) 'bad-one) + (error 'bad-one)) + exn:user? + #f) + (list test-param2 + (list 'two 'bad-two) + '(when (eq? (test-param2) 'bad-two) + (error 'bad-two)) + exn:user? + '("bad string")))) + +(for-each + (lambda (d) + (let ([param (car d)] + [alt1 (caadr d)] + [alt2 (cadadr d)] + [expr (caddr d)] + [exn? (cadddr d)]) + (parameterize ([param alt1]) + (test (void) void (teval expr))) + (parameterize ([param alt2]) + (error-test expr exn?)))) + params) + +(define test-param3 (make-parameter 'hi)) +(test 'hi test-param3) +(test 'hi 'thread-param + (let ([v #f]) + (thread-wait (thread + (lambda () + (set! v (test-param3))))) + v)) +(test (void) test-param3 'bye) +(test 'bye test-param3) +(test 'bye 'thread-param + (let* ([v #f] + [r (make-semaphore)] + [s (make-semaphore)] + [t (thread + (lambda () + (semaphore-post r) + (semaphore-wait s) + (set! v (test-param3))))]) + (semaphore-wait r) + (test-param3 'bye-again) + (semaphore-post s) + (thread-wait t) + v)) +(test 'bye-again test-param3) + +(test #f parameter? add1) + +(for-each + (lambda (d) + (let* ([param (car d)] + [alt1 (caadr d)] + [bads (cadddr (cdr d))]) + (test #t parameter? param) + (arity-test param 0 1) + (when bads + (for-each + (lambda (bad) + (let-values ([(bad exn?) + (if (bad-test? bad) + (values (bad-test-value bad) + (bad-test-exn? bad)) + (values bad + exn:application:type?))]) + (error-test `(,param ,bad) exn?))) + bads)))) + params) + +(test #t parameter-procedure=? read-accept-compiled read-accept-compiled) +(test #f parameter-procedure=? read-accept-compiled read-case-sensitive) +(error-test '(parameter-procedure=? read-accept-compiled 5)) +(error-test '(parameter-procedure=? 5 read-accept-compiled)) +(arity-test parameter-procedure=? 2 2) +(arity-test parameter? 1 1) + +; Test current-library-collection-paths? +; Test require-library-use-compiled? + +(report-errs) diff --git a/collects/tests/mzscheme/path.ss b/collects/tests/mzscheme/path.ss new file mode 100644 index 00000000..208e19ef --- /dev/null +++ b/collects/tests/mzscheme/path.ss @@ -0,0 +1,397 @@ +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'PATH) + +(define (make-/tf p exn?) + (lambda args + (with-handlers ([exn? (lambda (x) #f)] + [void (lambda (x) 'wrong-exn)]) + (if (void? (apply p args)) + #t + 'not-void)))) +(define delete-file/tf (lambda (x) ((make-/tf delete-file exn:i/o:filesystem?) x))) +(define delete-directory/tf (lambda (x) ((make-/tf delete-directory exn:i/o:filesystem?) x))) +(define rename-file-or-directory/tf (lambda (x y) ((make-/tf rename-file-or-directory exn:i/o:filesystem?) x y))) +(define make-directory/tf (lambda (x) ((make-/tf make-directory exn:i/o:filesystem?) x))) +(define copy-file/tf (lambda (x y) ((make-/tf copy-file exn:i/o:filesystem?) x y))) + +(test #f relative-path? (current-directory)) +(test #t relative-path? "down") +(test #t relative-path? (build-path 'up "down")) +(test #t relative-path? (build-path 'same "down")) +(test #t relative-path? (build-path 'same "down" "deep")) +(test #f relative-path? (build-path (current-directory) 'up "down")) +(test #f relative-path? (build-path (current-directory) 'same "down")) +(test #f relative-path? (build-path (current-directory) 'same "down" "deep")) +(test #f relative-path? (string #\a #\nul #\b)) + +(arity-test relative-path? 1 1) +(error-test '(relative-path? 'a)) + +(test #t absolute-path? (current-directory)) +(test #f absolute-path? (build-path 'up)) +(test #f absolute-path? (string #\a #\nul #\b)) + +(arity-test absolute-path? 1 1) +(error-test '(absolute-path? 'a)) + +(test #t complete-path? (current-directory)) +(test #f complete-path? (build-path 'up)) +(test #f complete-path? (string #\a #\nul #\b)) + +(arity-test complete-path? 1 1) +(error-test '(complete-path? 'a)) + +(call-with-output-file "tmp6" void 'replace) +(define existant "tmp6") + +(test #t file-exists? existant) + +(define deepdir (build-path "down" "deep")) + +(when (directory-exists? deepdir) + (for-each delete-file (directory-list deepdir)) + (delete-directory deepdir)) +(when (directory-exists? "down") + (for-each delete-file (directory-list "down")) + (delete-directory "down")) + +(test #t make-directory/tf "down") +(test #f make-directory/tf "down") +(test #t directory-exists? "down") +(test #f file-exists? "down") + +(test #t make-directory/tf deepdir) +(test #f make-directory/tf deepdir) +(test #t directory-exists? deepdir) +(test #f file-exists? deepdir) + +(test #t file-exists? (build-path "down" 'up existant)) +(test #t file-exists? (build-path deepdir 'up 'up existant)) +(test #t file-exists? (build-path 'same deepdir 'same 'up 'same 'up existant)) + +(test #f file-exists? (build-path "down" existant)) +(test #f file-exists? (build-path deepdir 'up existant)) +(test #f file-exists? (build-path 'same deepdir 'same 'same 'up existant)) + +(delete-file "tmp6") + +(test #f file-exists? (build-path "down" 'up "badfile")) +(test #f file-exists? (build-path deepdir 'up 'up "badfile")) +(test #f file-exists? (build-path 'same deepdir 'same 'up 'same 'up "badfile")) + +(error-test '(open-output-file (build-path "wrong" "down" "tmp8")) + exn:i/o:filesystem?) +(error-test '(open-output-file (build-path deepdir "wrong" "tmp7")) + exn:i/o:filesystem?) + +(define start-time (current-seconds)) +(let ([p (open-output-file "tmp5" 'replace)]) + (display "123456789" p) + (close-output-port p)) +(close-output-port (open-output-file (build-path "down" "tmp8") 'replace)) +(close-output-port (open-output-file (build-path deepdir "tmp7") 'replace)) +(define end-time (current-seconds)) + +(map + (lambda (f) + (let ([time (seconds->date (file-or-directory-modify-seconds f))] + [start (seconds->date start-time)] + [end (seconds->date end-time)]) + (test #t = (date-year start) (date-year time) (date-year end)) + (test #t = (date-month start) (date-month time) (date-month end)) + (test #t = (date-day start) (date-day time) (date-day end)) + (test #t = (date-week-day start) (date-week-day time) (date-week-day end)) + (test #t = (date-year-day start) (date-year-day time) (date-year-day end)) + (test #t = (date-hour start) (date-hour time) (date-hour end)) + (test #t <= (date-minute start) (date-minute time) (date-minute end)) + (test #t <= (date-second start) (date-second time) (date-second end)))) + (list "tmp5" + "down" + (build-path "down" "tmp8") + (build-path deepdir "tmp7"))) + +(test 'no-exists 'no-file-for-seconds (with-handlers ([void (lambda (x) 'no-exists)]) (file-or-directory-modify-seconds "non-existent-file"))) +(map + (lambda (f) + (test #t number? (file-or-directory-modify-seconds f))) + (filesystem-root-list)) + +(test #t file-exists? "tmp5") +(test #t file-exists? (build-path "down" "tmp8")) +(test #t file-exists? (build-path deepdir "tmp7")) + +(test #t copy-file/tf "tmp5" "tmp5y") +(test #f copy-file/tf "tmp5" "tmp5y") +(test #f copy-file/tf "tmp5" "down") +(test #f copy-file/tf "tmp5" (build-path deepdir "moredeep" "tmp5y")) +(test (file-size "tmp5") file-size "tmp5y") +(delete-file "tmp5y") + +(test #t rename-file-or-directory/tf "tmp5" "tmp5x") +(test #f rename-file-or-directory/tf "tmp5" "tmp5x") +(close-output-port (open-output-file "tmp5")) +(test #t file-exists? "tmp5") +(test #t file-exists? "tmp5x") +(test #f rename-file-or-directory/tf "tmp5" "tmp5x") +(test #f rename-file-or-directory/tf "tmp5" "down") +(delete-file "tmp5") +(test #f file-exists? "tmp5") +(test #t rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x")) +(test #f rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x")) +(test #t rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x")) +(test #f rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x")) + +(test #t make-directory/tf "downx") +(test #f rename-file-or-directory/tf "down" "downx") +(test #t delete-directory/tf "downx") + +(test #t rename-file-or-directory/tf "down" "downx") +(test #t directory-exists? "downx") +(test #f directory-exists? "down") +(test #t file-exists? (build-path "downx" "tmp8x")) +(test #f file-exists? (build-path "down" "tmp8x")) +(test #f rename-file-or-directory/tf "down" "downx") +(test #t rename-file-or-directory/tf "downx" "down") +(test #t file-exists? (build-path "down" "tmp8x")) + +(test #t rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x") +(test #f rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x") +(test #t rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x")) +(test #f rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x")) + +(test #f not (member "tmp5x" (directory-list))) +(test #t 'directory-list + (let ([l (directory-list "down")]) + (or (equal? l '("deep" "tmp8x")) + (equal? l '("tmp8x" "deep"))))) +(test '("tmp7x") directory-list deepdir) + +(test #f delete-directory/tf deepdir) +(test #f delete-directory/tf "down") + +(test #t delete-file/tf (build-path deepdir "tmp7x")) +(test #f delete-file/tf (build-path deepdir "tmp7x")) +(test #t delete-file/tf (build-path "down" "tmp8x")) +(test #f delete-file/tf (build-path "down" "tmp8x")) +(test #t delete-file/tf "tmp5x") +(test #f delete-file/tf "tmp5x") + +(test #f delete-directory/tf "down") +(test #t delete-directory/tf deepdir) +(test #f delete-directory/tf deepdir) +(test #t delete-directory/tf "down") +(test #f delete-directory/tf "down") + +; Redefine these per-platform +(define drives null) +(define nondrive-roots (list "/")) +(define -a (list "a")) +(define a/b (list "a/b" "a//b")) +(define a/b/c (list "a/b/c" "a//b/c")) +(define /a/b (list "/a/b")) +(define a/../b (list "a/../b")) +(define a/./b (list "a/./b")) +(define a/../../b (list "a/../../b")) +(define trail-sep "/") + +(define add-slashes + (lambda (l) + (if (null? l) + null + (let loop ([s (car l)][rest (add-slashes (cdr l))]) + (let ([naya (regexp-replace "/" s "\\")]) + (if (string=? naya s) + (cons s rest) + (loop naya (cons s rest)))))))) + +(when (eq? (system-type) 'windows) + (set! drives (list "c:" "c:/" "//hello/start" "//hello/start/")) + (set! nondrive-roots null) + (for-each + (lambda (var) + (eval `(set! ,var (add-slashes ,var)))) + '(-a a/b a/b/c /a/b a/../b a/./b a/../../b))) + + +(when (eq? (system-type) 'macos) + (set! drives null) + (set! nondrive-roots (filesystem-root-list)) + (set! -a (list ":a")) + (set! a/b (list ":a:b")) + (set! a/b/c (list ":a:b:c")) + (set! /a/b (list "a:b")) + (set! a/../b (list ":a::b")) + (set! a/./b null) + (set! a/../../b (list ":a:::b")) + (set! trail-sep ":")) + +(define roots (append drives nondrive-roots)) + +(define a/ (map (lambda (s) (string-append s trail-sep)) -a)) +(define a/b/ (map (lambda (s) (string-append s trail-sep)) a/b)) +(define a/b/c/ (map (lambda (s) (string-append s trail-sep)) a/b/c)) +(define /a/b/ (map (lambda (s) (string-append s trail-sep)) /a/b)) + +(define absols (append roots /a/b /a/b/)) +(define nondrive-absols (append nondrive-roots /a/b /a/b/)) +(define rels (append -a a/ a/b a/b/ a/b/c a/b/c/ a/../b a/./b a/../../b)) + +(define i (lambda (x) x)) + +(test #f ormap i (map relative-path? roots)) +(test #t andmap i (map relative-path? a/b)) +(test #f ormap i (map relative-path? /a/b)) + +(test #t andmap i (map absolute-path? roots)) +(test #f ormap i (map absolute-path? a/b)) + +(test #t andmap i (map complete-path? drives)) +(test #t andmap i (map complete-path? nondrive-roots)) +(test #f ormap i (map complete-path? a/b)) + +(for-each + (lambda (abs) + (for-each + (lambda (rel) + (test #t string? (build-path abs rel)) + (for-each + (lambda (rel2) + (test #t string? (build-path abs rel rel2))) + rels)) + rels)) + absols) + +(for-each + (lambda (drive) + (for-each + (lambda (root) + (test #t string? (build-path drive root)) + (for-each + (lambda (rel) + (test #t string? (build-path drive root rel))) + rels)) + nondrive-absols)) + drives) + +(for-each + (lambda (rel) + (test (build-path (current-directory) rel) + path->complete-path rel)) + rels) + +(define (test-path expect f . args) + (test (normal-case-path (expand-path expect)) + (or (inferred-name f) 'unknown) + (normal-case-path (expand-path (apply f args))))) + +(for-each + (lambda (absol) + (let ([cabsol (path->complete-path absol)]) + (for-each + (lambda (rel) + (test-path (build-path cabsol rel) path->complete-path rel cabsol) + (test-path (build-path cabsol rel rel) path->complete-path rel (build-path cabsol rel)) + (error-test `(path->complete-path ,rel ,rel) exn:i/o:filesystem?)) + rels))) + absols) + +(for-each + (lambda (drive) + (for-each + (lambda (rel) + (unless (relative-path? rel) + (test-path (build-path (current-drive) rel) + path->complete-path rel)) + (test-path (build-path drive rel) path->complete-path rel drive) + (test-path (if (relative-path? rel) + (build-path drive rel rel) + (build-path drive rel)) + path->complete-path rel (build-path drive rel))) + (append rels nondrive-absols))) + drives) + +(for-each + (lambda (drive) + (test drive path->complete-path drive) + (test drive path->complete-path drive drive)) + drives) + +(unless (eq? (system-type) 'macos) + (for-each + (lambda (abs1) + (for-each + (lambda (abs2) + (error-test `(build-path ,abs1 ,abs2) exn:i/o:filesystem?)) + absols)) + nondrive-roots)) + +(for-each + (lambda (root) + (let-values ([(base name dir?) (split-path root)]) + (test #f 'split-path base) + (test #t 'split-path dir?))) + roots) + +(let ([check-a/b + (lambda (a/b end/?) + (for-each + (lambda (path) + (let*-values ([(base name dir?) (split-path path)] + [(base2 name2 dir?2) (split-path base)]) + (test "b" substring name 0 1) + (test end/? 'split-path dir?) + (test "a" substring name2 0 1) + (test 'relative 'split-path base2) + (test #t 'split-path dir?2) + (for-each + (lambda (root) + (let ([bigpath (build-path root path)]) + (let*-values ([(base name dir?) (split-path bigpath)] + [(base2 name2 dir?2) (split-path base)] + [(base3 name3 dir?3) (split-path base2)]) + (test #f 'split-path base3) + (test #t 'split-path dir?3)))) + roots))) + a/b))]) + (check-a/b a/b #f) + (check-a/b a/b/ #t)) + +(arity-test split-path 1 1) + +(arity-test path->complete-path 1 2) +(error-test '(path->complete-path 1)) +(error-test '(path->complete-path "a" 1)) + +(test-path (build-path "a" "b") simplify-path (build-path "a" "b")) +(let ([full-path + (lambda args (apply build-path (current-directory) args))]) + (unless (string=? (build-path "a" "b") (build-path "a" 'same "b")) + (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "b"))) + (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'up "b")) + (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'same 'up "b" 'same 'same)) + (test-path (full-path "a" "b") simplify-path (build-path 'same "noexistsdir" 'same 'up "a" 'same "b" 'same 'same))) +(arity-test simplify-path 1 1) + +(arity-test expand-path 1 1) +(arity-test resolve-path 1 1) + +(map + (lambda (f) + (error-test `(,f (string #\a #\nul #\b)) exn:i/o:filesystem?)) + '(build-path split-path file-exists? directory-exists? + delete-file directory-list make-directory delete-directory + file-or-directory-modify-seconds file-or-directory-permissions + expand-path resolve-path simplify-path path->complete-path + open-input-file open-output-file)) +(map + (lambda (f) + (error-test `(,f (string #\a #\nul #\b) "a") exn:i/o:filesystem?) + (error-test `(,f "a" (string #\a #\nul #\b)) exn:i/o:filesystem?)) + '(rename-file-or-directory path->complete-path)) + +; normal-case-path doesn't check for pathness: +(test #t string? (normal-case-path (string #\a #\nul #\b))) + +(report-errs) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss new file mode 100644 index 00000000..1c719616 --- /dev/null +++ b/collects/tests/mzscheme/pconvert.ss @@ -0,0 +1,369 @@ + +(unless (defined? 'SECTION) + (load-relative "testing.ss")) + +(SECTION 'pconvert) + +(require-library "pconver.ss") + +(constructor-style-printing #t) +(quasi-read-style-printing #f) + +(define (xl) 1) +(define (xu) (unit (import) (export))) +(define (xc) (class object% () (sequence (super-init)))) + +(let () + (define-struct test (value constructor-sexp + whole/frac-constructor-sexp + shared-constructor-sexp + quasi-sexp + whole/frac-quasi-sexp + shared-quasi-sexp + cons-as-list)) + + (define-struct no-cons-test (value constructor-sexp shared-constructor-sexp + quasi-sexp shared-quasi-sexp)) + (define-struct same-test (value sexp)) + (define get-value + (lambda (test-case) + (cond + [(test? test-case) + (test-value test-case)] + [(no-cons-test? test-case) + (no-cons-test-value test-case)] + [(same-test? test-case) + (same-test-value test-case)]))) + (define run-test + (lambda (test-case) + (let* ([before (get-value test-case)] + [cmp + (lambda (selector constructor-style? + quasi-read? + sharing? + cons-as-list? + whole/fractional-numbers?) + (unless (parameterize ([constructor-style-printing constructor-style?] + [show-sharing sharing?] + [quasi-read-style-printing quasi-read?] + [abbreviate-cons-as-list cons-as-list?] + [whole/fractional-exact-numbers whole/fractional-numbers?]) + (test (selector test-case) print-convert before)) + (printf + ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a) (whole/fractional-exact-numbers ~a)~n" + constructor-style? quasi-read? + sharing? cons-as-list? + whole/fractional-numbers?)))]) + ;(printf "testing: ~s~n" before) + ;(printf ".") (flush-output (current-output-port)) + (cond + [(test? test-case) + (cmp test-constructor-sexp #t #f #f #t #f) + (cmp test-whole/frac-constructor-sexp #t #f #f #t #t) + (cmp test-shared-constructor-sexp #t #f #t #t #f) + (cmp test-quasi-sexp #f #f #f #t #f) + (cmp test-whole/frac-quasi-sexp #f #f #f #t #t) + (cmp test-shared-quasi-sexp #f #f #t #t #f) + (cmp test-cons-as-list #t #f #f #f #f)] + [(no-cons-test? test-case) + (cmp no-cons-test-shared-constructor-sexp #t #f #t #t #t) + (cmp no-cons-test-constructor-sexp #t #f #f #t #t) + (cmp no-cons-test-shared-quasi-sexp #f #f #t #t #t) + (cmp no-cons-test-quasi-sexp #f #f #f #t #t)] + [(same-test? test-case) + (cmp same-test-sexp #t #t #t #t #t) + (cmp same-test-sexp #t #t #t #t #f) + (cmp same-test-sexp #t #t #t #f #t) + (cmp same-test-sexp #t #t #t #f #f) + (cmp same-test-sexp #t #t #f #t #t) + (cmp same-test-sexp #t #t #f #t #f) + (cmp same-test-sexp #t #t #f #f #t) + (cmp same-test-sexp #t #t #f #f #f) + + (cmp same-test-sexp #t #f #t #t #t) + (cmp same-test-sexp #t #f #t #t #f) + (cmp same-test-sexp #t #f #t #f #t) + (cmp same-test-sexp #t #f #t #f #f) + (cmp same-test-sexp #t #f #f #t #t) + (cmp same-test-sexp #t #f #f #t #f) + (cmp same-test-sexp #t #f #f #f #t) + (cmp same-test-sexp #t #f #f #f #f) + + (cmp same-test-sexp #f #t #t #t #t) + (cmp same-test-sexp #f #t #t #t #f) + (cmp same-test-sexp #f #t #t #f #t) + (cmp same-test-sexp #f #t #t #f #f) + (cmp same-test-sexp #f #t #f #t #t) + (cmp same-test-sexp #f #t #f #t #f) + (cmp same-test-sexp #f #t #f #f #t) + (cmp same-test-sexp #f #t #f #f #f) + + (cmp same-test-sexp #f #f #t #t #t) + (cmp same-test-sexp #f #f #t #t #f) + (cmp same-test-sexp #f #f #t #f #t) + (cmp same-test-sexp #f #f #t #f #f) + (cmp same-test-sexp #f #f #f #t #t) + (cmp same-test-sexp #f #f #f #t #f) + (cmp same-test-sexp #f #f #f #f #t) + (cmp same-test-sexp #f #f #f #f #f)])))) + + (define + tests + (list + (make-same-test "abc" "abc") + (make-same-test 'a ''a) + + (make-same-test 8 8) + (make-same-test 1/2 1/2) + (make-same-test 1.1 1.1) + + (make-test 3/2 3/2 '(+ 1 1/2) 3/2 3/2 '(+ 1 1/2) 3/2 3/2) + + (make-test (list 1) '(list 1) '(list 1) '(list 1) '`(1) '`(1) '`(1) '(cons 1 empty)) + (make-test (list 1/2) '(list 1/2) '(list 1/2) '(list 1/2) + '`(1/2) '`(1/2) '`(1/2) + '(cons 1/2 empty)) + (make-test (list 3/2) '(list 3/2) '(list (+ 1 1/2)) '(list 3/2) + '`(3/2) '`(,(+ 1 1/2)) '`(3/2) + '(cons 3/2 empty)) + (make-test (list 1/2+1/2i) + '(list 1/2+1/2i) + '(list (+ 1/2 (* 0+1i 1/2))) + '(list 1/2+1/2i) + '`(1/2+1/2i) + '`(,(+ 1/2 (* 0+1i 1/2))) + '`(1/2+1/2i) + '(cons 1/2+1/2i empty)) + (make-test (list 3/2+1/2i) + '(list 3/2+1/2i) + '(list (+ (+ 1 1/2) (* 0+1i 1/2))) + '(list 3/2+1/2i) + '`(3/2+1/2i) + '`(,(+ (+ 1 1/2) (* 0+1i 1/2))) + '`(3/2+1/2i) + '(cons 3/2+1/2i empty)) + (make-test (list 1/2+3/2i) + '(list 1/2+3/2i) + '(list (+ 1/2 (* 0+1i (+ 1 1/2)))) + '(list 1/2+3/2i) + '`(1/2+3/2i) + '`(,(+ 1/2 (* 0+1i (+ 1 1/2)))) + '`(1/2+3/2i) + '(cons 1/2+3/2i empty)) + (make-test (list 3/2+3/2i) + '(list 3/2+3/2i) + '(list (+ (+ 1 1/2) (* 0+1i (+ 1 1/2)))) + '(list 3/2+3/2i) + '`(3/2+3/2i) + '`(,(+ (+ 1 1/2) (* 0+1i (+ 1 1/2)))) + '`(3/2+3/2i) + '(cons 3/2+3/2i empty)) + + (make-same-test (vector 0 0 0 0 0 0 0 0 0 0) '(vector 0 0 0 0 0 0 0 0 0 0)) + (make-same-test #t 'true) + (make-same-test #f 'false) + + (make-same-test (interface () a b c) '(interface ...)) + + (make-same-test (delay 1) '(delay ...)) + (make-same-test (let-struct a (a) (make-a 3)) '(make-a 3)) + (make-same-test (box 3) '(box 3)) + (make-test null 'empty 'empty 'empty '`() '`() '`() 'empty) + (make-same-test add1 'add1) + (make-same-test (void) '(void)) + (make-same-test (unit (import) (export)) '(unit ...)) + (make-same-test (make-weak-box 12) '(make-weak-box 12)) + (make-same-test (regexp "1") '(regexp ...)) + (make-same-test (lambda () 0) '(lambda () ...)) + (make-same-test xl 'xl) + (make-same-test (letrec ([xl (lambda () 1)]) xl) '(lambda () ...)) + (make-same-test (letrec ([xl-ID-BETTER-NOT-BE-DEFINED (lambda () 1)]) + xl-ID-BETTER-NOT-BE-DEFINED) + '(lambda () ...)) + (make-same-test xc 'xc) + (make-same-test (letrec ([xc (class object% ())]) xc) '(class ...)) + (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())]) + xc-ID-BETTER-NOT-BE-DEFINED) + '(class ...)) + (make-same-test xu 'xu) + (make-same-test (letrec ([xu (unit (import) (export))]) xu) + '(unit ...)) + (make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))]) + xu-ID-BETTER-NOT-BE-DEFINED) + '(unit ...)) + (make-same-test (lambda (x) x) '(lambda (a1) ...)) + (make-same-test (lambda x x) '(lambda args ...)) + (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...)) + (make-same-test (case-lambda) '(case-lambda)) + (make-same-test (case-lambda [() a] [(x) a]) '(case-lambda [() ...] [(a1) ...])) + (make-same-test (case-lambda [() a] [(x y) a]) + '(case-lambda [() ...] [(a1 a2) ...])) + (make-same-test (case-lambda [() a] [(x . y) a]) + '(case-lambda [() ...] [(a1 . args) ...])) + (make-same-test (case-lambda [() a] [x a]) + '(case-lambda [() ...] [args ...])) + (make-same-test (case-lambda [() a] [(x y z) a] [x a]) + '(case-lambda [() ...] [(a1 a2 a3) ...] [args ...])) + (make-same-test (let ([ht (make-hash-table)]) + (hash-table-put! ht 'x 1) + ht) + '(make-hash-table)) + (make-test (list 'a (box (list ())) (cons 1 '())) + '(list (quote a) (box (list empty)) (list 1)) + '(list (quote a) (box (list empty)) (list 1)) + '(list (quote a) (box (list empty)) (list 1)) + '`(a ,(box `(())) (1)) + '`(a ,(box `(())) (1)) + '`(a ,(box `(())) (1)) + '(cons 'a + (cons (box (cons empty empty)) + (cons (cons 1 empty) + empty)))) + (make-test (let ([x (list 1)]) (set-car! x x) x) + '(shared ([-0- (list -0-)]) -0-) + '(shared ([-0- (list -0-)]) -0-) + '(shared ([-0- (list -0-)]) -0-) + '(shared ([-0- `(,-0-)]) -0-) + '(shared ([-0- `(,-0-)]) -0-) + '(shared ([-0- `(,-0-)]) -0-) + '(shared ([-0- (cons -0- empty)]) -0-)) + (make-test (let ([x (list 1)]) (set-cdr! x x) x) + '(shared ([-0- (cons 1 -0-)]) -0-) + '(shared ([-0- (cons 1 -0-)]) -0-) + '(shared ([-0- (cons 1 -0-)]) -0-) + '(shared ([-0- `(1 . ,-0-)]) -0-) + '(shared ([-0- `(1 . ,-0-)]) -0-) + '(shared ([-0- `(1 . ,-0-)]) -0-) + '(shared ([-0- (cons 1 -0-)]) -0-)) + (make-test (let* ([a (list 1 2 3)] + [b (list 1 a (cdr a))]) + (set-car! b b) + (append b (list (list 2 3)))) + '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))]) + (list -1- (list 1 2 3) (list 2 3) (list 2 3))) + '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))]) + (list -1- (list 1 2 3) (list 2 3) (list 2 3))) + '(shared ([-1- (list -1- -3- -4-)] + [-3- (cons 1 -4-)] + [-4- (list 2 3)]) + (list -1- -3- -4- (list 2 3))) + '(shared ([-1- `(,-1- (1 2 3) (2 3))]) + `(,-1- (1 2 3) (2 3) (2 3))) + '(shared ([-1- `(,-1- (1 2 3) (2 3))]) + `(,-1- (1 2 3) (2 3) (2 3))) + '(shared ([-1- `(,-1- ,-3- ,-4-)] + [-3- `(1 . ,-4-)] + [-4- `(2 3)]) + `(,-1- ,-3- ,-4- (2 3))) + '(shared ([-1- (cons -1- + (cons (cons 1 (cons 2 (cons 3 empty))) + (cons (cons 2 (cons 3 empty)) + empty)))]) + (cons -1- + (cons (cons 1 (cons 2 (cons 3 empty))) + (cons (cons 2 (cons 3 empty)) + (cons (cons 2 (cons 3 empty)) + empty)))))) + (make-no-cons-test (let* ([a (list 1 2 3)] + [b (list 1 a (cdr a))]) + (set-car! b b) + (let* ([share-list (append b (list (list 2 3)))] + [v (vector 1 share-list (cdr share-list))]) + (vector-set! v 0 v) + v)) + '(shared + ((-0- (vector -0- + (list -2- + (list 1 2 3) + (list 2 3) + (list 2 3)) + (list (list 1 2 3) + (list 2 3) + (list 2 3)))) + (-2- (list -2- (list 1 2 3) (list 2 3)))) + -0-) + '(shared + ((-0- (vector -0- (cons -2- -8-) -8-)) + (-2- (list -2- -4- -5-)) + (-4- (cons 1 -5-)) + (-5- (list 2 3)) + (-8- (list -4- -5- (list 2 3)))) + -0-) + '(shared + ((-0- (vector -0- + `(,-2- + (1 2 3) + (2 3) + (2 3)) + `((1 2 3) + (2 3) + (2 3)))) + (-2- `(,-2- (1 2 3) (2 3)))) + -0-) + '(shared + ((-0- (vector -0- `(,-2- . ,-8-) -8-)) + (-2- `(,-2- ,-4- ,-5-)) + (-4- `(1 . ,-5-)) + (-5- `(2 3)) + (-8- `(,-4- ,-5- (2 3)))) + -0-)))) + (for-each run-test tests)) + +(let () + (define make-test-shared + (lambda (shared?) + (lambda (object output) + (parameterize ([constructor-style-printing #t] + [show-sharing #t] + [quasi-read-style-printing #f] + [abbreviate-cons-as-list #t]) + (test (if shared? + `(shared ((-1- ,output)) + (list -1- -1-)) + `(list ,output ,output)) + print-convert + (list object object)))))) + (define test-shared (make-test-shared #t)) + (define test-not-shared (make-test-shared #f)) + + (test-not-shared #t 'true) + (test-not-shared #f 'false) + (test-not-shared 1 1) + (test-not-shared 3276832768327683276832768327683276832768 + 3276832768327683276832768327683276832768) + (test-shared (regexp "") '(regexp ...)) + (let ([in (open-input-string "")]) (test-shared in in)) + (let ([out (open-output-string)]) (test-shared out out)) + (test-not-shared #\a #\a) + (test-not-shared 'x ''x) + (test-shared (lambda (x) x) '(lambda (a1) ...)) + (test-shared (make-promise (lambda () 1)) '(delay ...)) + (test-shared (class object% ()) '(class ...)) + (test-shared (unit (import) (export)) '(unit ...)) + (test-shared (make-object (class object% () (sequence (super-init)))) '(make-object (class ...) ...)) + + (test-shared "abc" "abc") + (test-shared (list 1 2 3) '(list 1 2 3)) + (test-shared (vector 1 2 3) '(vector 1 2 3)) + (let-struct a () (test-shared (make-a) '(make-a))) + (test-shared (box 1) '(box 1)) + (test-shared (make-hash-table) '(make-hash-table))) + +(arity-test print-convert 1 2) +(arity-test build-share 1 1) +(arity-test get-shared 1 2) +(arity-test print-convert-expr 3 3) + +(test 'empty print-convert '()) + +(let ([pc + (lambda (pv) + (lambda (x) + (parameterize ([booleans-as-true/false pv]) + (print-convert x))))]) + (test 'false (pc #t) #f) + (test 'true (pc #t) #t) + (test #f (pc #f) #f) + (test #t (pc #f) #t)) + +(report-errs) diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss new file mode 100644 index 00000000..e340e373 --- /dev/null +++ b/collects/tests/mzscheme/pretty.ss @@ -0,0 +1,110 @@ + +; Test pretty-print. Some of it relies on manual inspection of the results + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(require-library "pretty.ss") + +(define (pp-string v) + (let ([p (open-output-string)]) + (pretty-print v p) + (let ([s (get-output-string p)]) + (substring s 0 (sub1 (string-length s)))))) + + +(test "10" pp-string 10) +(test "1/2" pp-string 1/2) +(test "-1/2" pp-string -1/2) +(test "1/2+3/4i" pp-string 1/2+3/4i) +(test "0.333" pp-string #i0.333) +(test "2.0+1.0i" pp-string #i2+1i) + +(parameterize ([pretty-print-exact-as-decimal #t]) + (test "10" pp-string 10) + (test "0.5" pp-string 1/2) + (test "-0.5" pp-string -1/2) + (test "3500.5" pp-string 7001/2) + (test "0.0001220703125" pp-string 1/8192) + (test "0.0000000000000006869768746897623487" + pp-string 6869768746897623487/10000000000000000000000000000000000) + (test "0.00000000000001048576" pp-string (/ (expt 5 20))) + + (test "1/3" pp-string 1/3) + (test "1/300000000000000000000000" pp-string 1/300000000000000000000000) + + (test "0.5+0.75i" pp-string 1/2+3/4i) + (test "0.5-0.75i" pp-string 1/2-3/4i) + (test "1/9+3/17i" pp-string 1/9+3/17i) + (test "0.333" pp-string #i0.333) + (test "2.0+1.0i" pp-string #i2+1i)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Manual part +;; (Why is this manual? Probably I was too lazy to make +;; a proper test suite.) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-struct s (a b c)) + +(define (make k?) + (let ([make (if k? make (lambda (x) '(end)))]) + (list + 1 + 'a + "a" + (list 'long-name-numero-uno-one-the-first-supreme-item + 'long-name-number-two-di-ar-ge-second-line) + (map (lambda (v v2) + (make-s v 2 v2)) + (make #f) + (reverse (make #f))) + '(1) + '(1 2 3) + '(1 . 2) + #(1 2 3 4 5) + '(#0=() . #0#) + '#1=(1 . #1#) + (map box (make #f)) + (make #f)))) + +(define vs (make #t)) + +(define print-line-no + (lambda (line port offset width) + (if line + (begin + (when (positive? line) (write-char #\newline port)) + (fprintf port "~s~a~a~a " line + (if (< line 10) " " "") + (if (< line 100) " " "") + (if (< line 1000) " " "")) + 5) + (fprintf port "!~n")))) + +(define modes + (list + (list "DEPTH=2" pretty-print-depth 2) + (list "GRAPH-ON" print-graph #t) + (list "STRUCT-ON" print-struct #t) + (list "LINE-NO-ON" pretty-print-print-line print-line-no))) + +(define num-combinations (arithmetic-shift 1 (length modes))) + +(let loop ([n 0]) + (when (< n num-combinations) + (let loop ([modes modes][n n]) + (cond + [(null? modes) (printf ":~n") (map pretty-print vs)] + [(positive? (bitwise-and n 1)) + (let ([mode (car modes)]) + (printf "~s " (car mode)) + (parameterize ([(cadr mode) (caddr mode)]) + (loop (cdr modes) (arithmetic-shift n -1))))] + [else + (loop (cdr modes) (arithmetic-shift n -1))])) + (loop (add1 n)))) + + + +(report-errs) diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss new file mode 100644 index 00000000..7a948cc1 --- /dev/null +++ b/collects/tests/mzscheme/quiet.ss @@ -0,0 +1,9 @@ + +(unless (defined? 'quiet-load) + (global-defined-value 'quiet-load "all.ss")) + +(let ([p (make-output-port void void)]) + (parameterize ([current-output-port p]) + (load-relative quiet-load)) + (report-errs)) + diff --git a/collects/tests/mzscheme/read.ss b/collects/tests/mzscheme/read.ss new file mode 100644 index 00000000..061c3ecd --- /dev/null +++ b/collects/tests/mzscheme/read.ss @@ -0,0 +1,169 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'READING) +(define readstr + (lambda (s) + (let* ([o (open-input-string s)] + [read (if (defined? 'read/zodiac) + (let ([r (read/zodiac (open-input-string s))]) + (lambda () + (let ([orig (error-escape-handler )]) + (dynamic-wind + (lambda () (error-escape-handler + (lambda () + (error-escape-handler orig) + (error 'read/zodiac)))) + r + (lambda () (error-escape-handler orig)))))) + (lambda () (read o)))]) + (let loop ([last eof]) + (let ([v (read)]) + (if (eof-object? v) + last + (loop v))))))) + +(define readerrtype + (if (defined? 'read/zodiac) + (lambda (x) (lambda (y) #t)) + (lambda (x) x))) + +; Make sure {whitespace} == {delimiter} +(let ([with-censor (load-relative "censor.ss")]) + (with-censor + (lambda () + (let loop ([n 0]) + (unless (= n 256) + (let* ([c0 (integer->char n)] + [c (if (read-case-sensitive) + c0 + (char-downcase c0))]) + (cond + [(char-whitespace? c) + (test 'b readstr (string #\a c #\b))] + [(char=? #\\ c) (test 'ab readstr (string #\a c #\b))] + [(char=? #\; c) (test 'a readstr (string #\a c #\b))] + [(char=? #\' c) (test ''b readstr (string #\a c #\b))] + [(char=? #\` c) (test '`b readstr (string #\a c #\b))] + [(char=? #\, c) (test ',b readstr (string #\a c #\b))] + [else + (test (string->symbol (string #\a (char-downcase c) #\b)) + 'readstr + (with-handlers ([void + (lambda (x) + (string->symbol (string #\a (char-downcase c) #\b)))]) + (readstr (string #\a c #\b))))])) + (loop (add1 n))))))) + +(error-test '(readstr ")") (readerrtype exn:read?)) +(error-test '(readstr "[)") (readerrtype exn:read?)) +(error-test '(readstr "[}") (readerrtype exn:read?)) +(error-test '(readstr "8 )") (readerrtype exn:read?)) +(error-test '(readstr "(8 . )") (readerrtype exn:read?)) + +(load-relative "numstrs.ss") +(let loop ([l number-table]) + (unless (null? l) + (let* ([pair (car l)] + [v (car pair)] + [s (cadr pair)]) + (cond + [(eq? v 'X) (error-test `(readstr ,s) (readerrtype exn:read?))] + [v (test v readstr s)] + [else (test (string->symbol s) readstr s)])) + (loop (cdr l)))) + +(error-test '(readstr "#\\silly") (readerrtype exn:read?)) +(error-test '(readstr "#\\nully") (readerrtype exn:read?)) +(error-test '(readstr "#\\nu") (readerrtype exn:read?)) +(error-test '(readstr "#\\733") (readerrtype exn:read?)) +(error-test '(readstr "#\\433") (readerrtype exn:read?)) + +(error-test '(readstr "(hi") (readerrtype exn:read:eof?)) +(error-test '(readstr "\"hi") (readerrtype exn:read:eof?)) +(error-test '(readstr "#(hi") (readerrtype exn:read:eof?)) +(error-test '(readstr "#4(hi") (readerrtype exn:read:eof?)) +(error-test '(readstr "|hi") (readerrtype exn:read:eof?)) +(error-test '(readstr "#\\") (readerrtype exn:read:eof?)) +(error-test '(readstr "#| hi") (readerrtype exn:read:eof?)) + +(error-test '(readstr ".") (readerrtype exn:read?)) +(error-test '(readstr "a .") (readerrtype exn:read?)) +(error-test '(readstr "a . b") (readerrtype exn:read?)) +(error-test '(readstr "( . )") (readerrtype exn:read?)) +(error-test '(readstr "( . 8)") (readerrtype exn:read?)) +(error-test '(readstr "(0 . 8 9)") (readerrtype exn:read?)) +(error-test '(readstr "( . 8 9)") (readerrtype exn:read?)) +(error-test '(readstr "#(8 . )") (readerrtype exn:read?)) +(error-test '(readstr "#( . )") (readerrtype exn:read?)) +(error-test '(readstr "#( . 8)") (readerrtype exn:read?)) +(error-test '(readstr "#(0 . 8 9)") (readerrtype exn:read?)) +(error-test '(readstr "#( . 8 9)") (readerrtype exn:read?)) +(error-test '(readstr "#( 8 . 9)") (readerrtype exn:read?)) +(error-test '(readstr "#( 8 . (9))") (readerrtype exn:read?)) + +(error-test '(readstr "#Q") (readerrtype exn:read?)) +(error-test '(readstr "##") (readerrtype exn:read?)) +(error-test '(readstr "#?") (readerrtype exn:read?)) +(error-test '(readstr "#-1()") (readerrtype exn:read?)) +(error-test '(readstr "#") (readerrtype exn:read?)) + +(test 2 vector-length (readstr "#2()")) +(test 0 vector-ref (readstr "#2()") 1) +(test 2 vector-length (readstr "#000000000000000000000000000000002()")) + +(error-test '(readstr "#2(1 2 3)") (readerrtype exn:read?)) +(error-test '(readstr "#200000000000(1 2 3)") (readerrtype exn:misc:out-of-memory?)) + +(unless (defined? 'read/zodiac) + (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#0=(1 2) . #0#)")) + (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)"))) + +(error-test '(readstr "#0#") (readerrtype exn:read?)) +(error-test '(readstr "#0=#0#") (readerrtype exn:read?)) +(error-test '(readstr "(#0# #0=7)") (readerrtype exn:read?)) +(error-test '(readstr "(#0=7 #1#)") (readerrtype exn:read?)) +(error-test '(readstr "#012345678=7") (readerrtype exn:read?)) +(error-test '(readstr "(#12345678=7 #012345678#)") (readerrtype exn:read?)) + +(test 3 string-length (readstr (string #\" #\a #\nul #\b #\"))) +(test (string->symbol (string #\a #\nul #\b)) 'sym (readstr (string #\a #\nul #\b))) +(test (string->symbol (string #\1 #\nul #\b)) 'sym (readstr (string #\1 #\nul #\b))) + +; Test read/write invariance on symbols and use of pipe quotes +(define (test-write-sym with-bar without-bar s) + (let ([sym (string->symbol s)]) + (parameterize ([read-case-sensitive #t]) + (let ([p (open-output-string)]) + (write sym p) + (test with-bar 'write-sym-with-bar (get-output-string p)) + (test sym read (open-input-string (get-output-string p)))) + (let ([p (open-output-string)]) + (parameterize ([read-accept-bar-quote #f]) + (write sym p) + (test without-bar 'write-sym-no-bar (get-output-string p)) + (test sym read (open-input-string (get-output-string p))))) + (let ([p (open-output-string)]) + (display sym p) + (test s 'display-sym (get-output-string p)))))) + +(test-write-sym "a->b" "a->b" "a->b") +(test-write-sym "|a,b|" "a\\,b" "a,b") +(test-write-sym "a\\|b" "a|b" "a|b") +(test-write-sym "|a\\b|" "a\\\\b" "a\\b") + +(load-relative "numstrs.ss") +(let loop ([l number-table]) + (cond + [(null? l) 'done] + [(or (number? (caar l)) (eq? (caar l) 'X)) + (test-write-sym (string-append "|" (cadar l) "|") + (string-append "\\" (cadar l)) + (cadar l)) + (loop (cdr l))] + [else + (test-write-sym (cadar l) (cadar l) (cadar l)) + (loop (cdr l))])) + +(report-errs) diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss new file mode 100644 index 00000000..be981dc3 --- /dev/null +++ b/collects/tests/mzscheme/stream.ss @@ -0,0 +1,305 @@ + +(printf "Stream Tests (current dir must be startup dir)~n") + +(define (log . args) + '(begin + (apply printf args) + (newline))) + +(define cs-prog + '(define (copy-stream in out) + (lambda () + (let ([s (make-string 4096)]) + (let loop () + (let ([l (read-string-avail! s in)]) + (log "in: ~a" l) + (unless (eof-object? l) + (let loop ([p 0][l l]) + (let ([r (write-string-avail s out p (+ p l))]) + (log "out: ~a" r) + (when (< r l) + (loop (+ p r) (- l r))))) + (loop)))))))) + +(eval cs-prog) + +(define test-file (find-system-path 'exec-file)) +(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ")) + +(define (feed-file out) + (let ([p (open-input-file test-file)]) + (let loop () + (let ([c (read-char p)]) + (unless (eof-object? c) + (write-char c out) + (loop)))))) + +(define (feed-file/fast out) + (let ([p (open-input-file test-file)]) + ((copy-stream p out)) + (close-input-port p))) + +(define (check-file in) + (let ([p (open-input-file test-file)]) + (let loop ([badc 0]) + (let ([c (read-char p)] + [c2 (read-char in)]) + (unless (eq? c c2) + (if (= badc 30) + (error "check-failed" (file-position p) c c2) + (begin + (fprintf (current-error-port) + "fail: ~a ~s ~s~n" + (file-position p) c c2) + (loop (add1 badc))))) + (unless (eof-object? c) + (loop badc)))))) + +(define (check-file/fast in) + (let ([p (open-input-file test-file)]) + (let loop () + (let* ([s (read-string 5000 p)] + [s2 (read-string (if (string? s) (string-length s) 100) in)]) + (unless (equal? s s2) + (error "fast check failed")) + (unless (eof-object? s) + (loop)))))) + +(define (check-file/fastest in) + (let ([p (open-input-file test-file)] + [s1 (make-string 5000)] + [s2 (make-string 5000)]) + (let loop ([leftover 0]) + (let* ([n1 (let ([n (read-string-avail! s1 p leftover)]) + (if (eof-object? n) + (if (zero? leftover) + n + leftover) + (+ n leftover)))] + [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) + 1 + n1))]) + (unless (if (or (eof-object? n1) + (eof-object? n2) + (= n2 n1 5000)) + (equal? s1 s2) + (string=? (substring s1 0 n2) + (substring s2 0 n2))) + (error "fast check failed")) + (unless (eof-object? n1) + (loop (- n1 n2))))))) + +(define portno 40000) + +(define (setup-mzscheme-echo tcp?) + (define p (process* test-file "-q" "-b")) + (define s (make-string 256)) + (define r #f) + (define w #f) + (define r2 #f) + (define w2 #f) + (thread (copy-stream (cadddr p) (current-error-port))) + (fprintf (cadr p) "(define log void)~n") + (fprintf (cadr p) "~s~n" cs-prog) + (if tcp? + (let ([t + (thread (lambda () + (define-values (rr ww) (tcp-accept l1)) + (define-values (rr2 ww2) (tcp-accept l2)) + (set! r rr) + (set! w ww) + (set! r2 rr2) + (set! w2 ww2)))]) + (fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno) + (fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno)) + (thread-wait t) + (fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n")) + (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) + + ;; Flush initial output: + (read-string (string-length (banner)) (car p)) + (sleep 0.3) + (when (char-ready? (car p)) + (read-string-avail! s (car p))) + (sleep 0.3) + (when (char-ready? (car p)) + (read-string-avail! s (car p))) + + (if tcp? + (values r w r2 w2) + p)) + +(define start-ms 0) +(define start-ps-ms 0) +(define start-gc-ms 0) +(define (start s) + (printf s) + (set! start-ms (current-milliseconds)) + (set! start-gc-ms (current-gc-milliseconds)) + (set! start-ps-ms (current-process-milliseconds))) +(define (end) + (let ([ps-ms (current-process-milliseconds)] + [gc-ms (current-gc-milliseconds)] + [ms (current-milliseconds)]) + (printf "cpu: ~a real: ~a gc ~a~n" + (- ps-ms start-ps-ms) + (- ms start-ms) + (- gc-ms start-gc-ms)))) + +'(thread (lambda () + (let loop () + (printf "alive~n") + (sleep 1) + (loop)))) + +(start "Quick check:~n") +(define p (open-input-file test-file)) +(check-file/fast p) +(close-input-port p) +(end) + +(start "Quicker check:~n") +(define p (open-input-file test-file)) +(check-file/fastest p) +(close-input-port p) +(end) + +(start "Plain pipe...~n") +(define-values (r w) (make-pipe)) +(feed-file w) +(close-output-port w) +(check-file r) +(end) + +(start "Plain pipe, faster...~n") +(define-values (r w) (make-pipe)) +(feed-file/fast w) +(close-output-port w) +(check-file/fast r) +(end) + +(start "Plain pipe, fastest...~n") +(define-values (r w) (make-pipe)) +(feed-file/fast w) +(close-output-port w) +(check-file/fastest r) +(end) + +(start "To file and back:~n") +(start " to...~n") +(define-values (r w) (make-pipe)) +(define p (open-output-file tmp-file 'truncate)) +(define t (thread (copy-stream r p))) +(feed-file w) +(close-output-port w) +(thread-wait t) +(close-output-port p) +(end) + +(start " back...~n") +(define-values (r w) (make-pipe)) +(define p (open-input-file tmp-file)) +(define t (thread (copy-stream p w))) +(thread-wait t) +(close-output-port w) +(close-input-port p) +(check-file r) +(end) + +(start "To file and back, faster:~n") +(start " to...~n") +(define-values (r w) (make-pipe)) +(define p (open-output-file tmp-file 'truncate)) +(define t (thread (copy-stream r p))) +(feed-file/fast w) +(close-output-port w) +(thread-wait t) +(close-output-port p) +(end) + +(start " back...~n") +(define-values (r w) (make-pipe)) +(define p (open-input-file tmp-file)) +(define t (thread (copy-stream p w))) +(thread-wait t) +(close-output-port w) +(close-input-port p) +(check-file/fast r) +(end) + +(start "File back, fastest:~n") +(define-values (r w) (make-pipe)) +(define p (open-input-file tmp-file)) +(define t (thread (copy-stream p w))) +(thread-wait t) +(close-output-port w) +(close-input-port p) +(check-file/fastest r) +(end) + +(start "Echo...~n") +(define p (setup-mzscheme-echo #f)) +(thread (lambda () + (feed-file (cadr p)) + (close-output-port (cadr p)))) +(check-file (car p)) +(end) + +(start "Echo, faster...~n") +(define p (setup-mzscheme-echo #f)) +(thread (lambda () + (feed-file/fast (cadr p)) + (close-output-port (cadr p)))) +(check-file/fast (car p)) +(end) + +(start "Echo, indirect...~n") +(define p (setup-mzscheme-echo #f)) +(define-values (rp1 wp1) (make-pipe)) +(define-values (rp2 wp2) (make-pipe)) +(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p)))) +(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2))) +(thread (lambda () + (feed-file/fast wp1) + (close-output-port wp1))) +(check-file/fast rp2) +(end) + +(define l1 (tcp-listen portno)) +(define l2 (tcp-listen (add1 portno))) + +(start "TCP Echo...~n") +(define-values (r w r2 w2) (setup-mzscheme-echo #t)) +(close-input-port r) +(thread (lambda () + (feed-file w) + (close-output-port w))) +(check-file r2) +(close-input-port r2) +(end) + +(start "TCP Echo, faster...~n") +(define-values (r w r2 w2) (setup-mzscheme-echo #t)) +(close-input-port r) +(thread (lambda () + (feed-file/fast w) + (close-output-port w))) +(check-file/fast r2) +(close-input-port r2) +(end) + +(start "TCP Echo, indirect...~n") +(define-values (rp1 wp1) (make-pipe)) +(define-values (rp2 wp2) (make-pipe)) +(define-values (r w r2 w2) (setup-mzscheme-echo #t)) +(close-input-port r) +(thread (lambda () ((copy-stream rp1 w)) (close-output-port w))) +(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2))) +(thread (lambda () + (feed-file/fast wp1) + (close-output-port wp1))) +(check-file/fast rp2) +(end) + +(tcp-close l1) +(tcp-close l2) diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss new file mode 100644 index 00000000..b0b0a962 --- /dev/null +++ b/collects/tests/mzscheme/struct.ss @@ -0,0 +1,234 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'STRUCT) + +(test 7 call-with-values + (lambda () (struct a (b c))) + (lambda args (length args))) +(let-values ([(type make pred sel1 set1 sel2 set2) (struct a (b c))]) + (test #t struct-type? type) + (test #t procedure? make) + (test 2 arity make) + (test 1 arity sel1) + (test 2 arity set1) + (test #t struct-setter-procedure? set2) + (test #f struct-setter-procedure? sel2)) + +(define-struct a (b c)) +(define-struct aa ()) +(define ai (make-a 1 2)) +(define aai (make-aa)) +(test #t struct-type? struct:a) +(test #f struct-type? 5) +(test #t procedure? a?) +(test #t a? ai) +(test #f a? 1) +(test #f aa? ai) +(test 1 a-b ai) +(test 2 a-c ai) +(define ai2 (make-a 1 2)) +(set-a-b! ai2 3) +(set-a-c! ai2 4) +(test 1 a-b ai) +(test 2 a-c ai) +(test 3 a-b ai2) +(test 4 a-c ai2) +(define-struct a (b c)) +(test #f a? ai) +(arity-test make-a 2 2) +(error-test `(make-aa 1) exn:application:arity?) +(arity-test a? 1 1) +(arity-test a-b 1 1) +(arity-test a-c 1 1) +(arity-test set-a-b! 2 2) +(arity-test set-a-c! 2 2) +(error-test `(a-b 5)) +(error-test `(a-b ,ai)) +(error-test `(set-a-b! ai 5)) +(error-test `(set-a-c! ai 5)) +(error-test `(begin (define-struct (a 9) (b c)) (void)) exn:struct?) + +(arity-test struct-type? 1 1) + +(define (gen-struct-syntax-test formname suffix) + (syntax-test `(,formname 1 (x) ,@suffix)) + (syntax-test `(,formname a (1) ,@suffix)) + (syntax-test `(,formname a (x 1) ,@suffix)) + (syntax-test `(,formname a (x . y) ,@suffix)) + (syntax-test `(,formname (a) (x) ,@suffix)) + (syntax-test `(,formname (a . y) (x) ,@suffix)) + (syntax-test `(,formname (a 2 3) (x) ,@suffix))) +(define (struct-syntax-test formname) + (syntax-test `(,formname)) + (syntax-test `(,formname . a)) + (syntax-test `(,formname a . x)) + (syntax-test `(,formname a x)) + (gen-struct-syntax-test formname '())) + +(struct-syntax-test 'struct) +(struct-syntax-test 'define-struct) +(gen-struct-syntax-test 'let-struct '(5)) + +(define-struct base0 ()) +(define-struct base1 (a)) +(define-struct base2 (l r)) +(define-struct base3 (x y z)) + +(define-struct (one00 struct:base0) ()) +(define-struct (one01 struct:base1) ()) +(define-struct (one02 struct:base2) ()) +(define-struct (one03 struct:base3) ()) + +(define-struct (one10 struct:base0) (a)) +(define-struct (one11 struct:base1) (a)) +(define-struct (one12 struct:base2) (a)) +(define-struct (one13 struct:base3) (a)) + +(define-struct (one20 struct:base0) (l r)) +(define-struct (one21 struct:base1) (l r)) +(define-struct (one22 struct:base2) (l r)) +(define-struct (one23 struct:base3) (l r)) + +(define-struct (one30 struct:base0) (x y z)) +(define-struct (one31 struct:base1) (x y z)) +(define-struct (one32 struct:base2) (x y z)) +(define-struct (one33 struct:base3) (x y z)) + +(define-struct (two100 struct:one00) (a)) +(define-struct (two101 struct:one01) (a)) +(define-struct (two102 struct:one02) (a)) +(define-struct (two103 struct:one03) (a)) +(define-struct (two110 struct:one10) (a)) +(define-struct (two111 struct:one11) (a)) +(define-struct (two112 struct:one12) (a)) +(define-struct (two113 struct:one13) (a)) +(define-struct (two120 struct:one20) (a)) +(define-struct (two121 struct:one21) (a)) +(define-struct (two122 struct:one22) (a)) +(define-struct (two123 struct:one23) (a)) +(define-struct (two130 struct:one30) (a)) +(define-struct (two131 struct:one31) (a)) +(define-struct (two132 struct:one32) (a)) +(define-struct (two133 struct:one33) (a)) + +(define x00 (make-one00)) + +(define x01 (make-one01 1)) + +(define x10 (make-one10 1)) +(define x11 (make-one11 1 2)) +(define x12 (make-one12 1 2 3)) +(define x13 (make-one13 1 2 3 4)) + +(define x31 (make-one31 1 2 3 4)) + +(define x33 (make-one33 1 2 3 4 5 6)) + +(define x132 (make-two132 1 2 3 4 5 6)) + +(define (ones v) + (cond + [(one00? v) 'one00] + [(one01? v) 'one01] + [(one02? v) 'one02] + [(one03? v) 'one03] + + [(one10? v) 'one10] + [(one11? v) 'one11] + [(one12? v) 'one12] + [(one13? v) 'one13] + + [(one20? v) 'one20] + [(one21? v) 'one21] + [(one22? v) 'one22] + [(one23? v) 'one23] + + [(one30? v) 'one30] + [(one31? v) 'one31] + [(one32? v) 'one32] + [(one33? v) 'one33])) + +(define (multi v) + (cond + [(two130? v) 'two130] + [(two131? v) 'two131] + [(two132? v) 'two132] + [(two133? v) 'two133] + + [(one10? v) 'one10] + [(one11? v) 'one11] + [(one12? v) 'one12] + [(one13? v) 'one13] + + [(one20? v) 'one20] + [(one21? v) 'one21] + [(one22? v) 'one22] + [(one23? v) 'one23] + + [(base0? v) 'base0] + [(base1? v) 'base1] + [(base2? v) 'base2] + [(base3? v) 'base3])) + +(define (dummy v) + 'ok) + +(define (go f v n) + (time + (let loop ([n n]) + (unless (zero? n) + (f v) + (loop (sub1 n)))))) + +(define check + (lambda (l) + (cond + [(null? l) #f] + [else + (test (caddr l) (car l) (cadr l)) + (check (cdddr l))]))) + +(define ones-test + (list x00 'one00 + x10 'one10 + x11 'one11 + x12 'one12 + x13 'one13 + x33 'one33)) + +(define multi-test + (list x00 'base0 + x10 'one10 + x11 'one11 + x12 'one12 + x13 'one13 + x33 'base3 + x132 'two132)) + +(letrec ([bundle + (lambda (l f) + (if (null? l) + null + (list* f (car l) (cadr l) + (bundle (cddr l) f))))]) + (check (append + (bundle ones-test ones) + (bundle multi-test multi) + (list base1-a x11 1 + one11-a x11 2 + one10-a x10 1 + + base1-a x31 1 + one31-z x31 4 + + base2-l x132 1 + two132-a x132 6 + one32-y x132 4)))) + + +(error-test '(struct x (y z)) exn:application:arity?) +(error-test '(let ([x (struct x (y z))]) 10) exn:application:arity?) + +(report-errs) diff --git a/collects/tests/mzscheme/structc.ss b/collects/tests/mzscheme/structc.ss new file mode 100644 index 00000000..2e7d616f --- /dev/null +++ b/collects/tests/mzscheme/structc.ss @@ -0,0 +1,182 @@ + +(define ones-case + (make-struct-case + (list + one00? + one01? + one02? + one03? + + one10? + one11? + one12? + one13? + + one20? + one21? + one22? + one23? + + one30? + one31? + one32? + one33?) + + (list + (lambda (x) 'one00) + (lambda (x) 'one01) + (lambda (x) 'one02) + (lambda (x) 'one03) + + (lambda (x) 'one10) + (lambda (x) 'one11) + (lambda (x) 'one12) + (lambda (x) 'one13) + + (lambda (x) 'one20) + (lambda (x) 'one21) + (lambda (x) 'one22) + (lambda (x) 'one23) + + (lambda (x) 'one30) + (lambda (x) 'one31) + (lambda (x) 'one32) + (lambda (x) 'one33)))) + +(define multi-case + (make-struct-case + (list + two130? + two131? + two132? + two133? + + one10? + one11? + one12? + one13? + + one20? + one21? + one22? + one23? + + base0? + base1? + base2? + base3?) + + (list + (lambda (x) 'two130) + (lambda (x) 'two131) + (lambda (x) 'two132) + (lambda (x) 'two133) + + (lambda (x) 'one10) + (lambda (x) 'one11) + (lambda (x) 'one12) + (lambda (x) 'one13) + + (lambda (x) 'one20) + (lambda (x) 'one21) + (lambda (x) 'one22) + (lambda (x) 'one23) + + (lambda (x) 'base0) + (lambda (x) 'base1) + (lambda (x) 'base2) + (lambda (x) 'base3)) + + (lambda (x) x))) + +(letrec ([bundle + (lambda (l f) + (if (null? l) + null + (list* f (car l) (cadr l) + (bundle (cddr l) f))))]) + (check (append + (bundle ones-test ones-case) + (bundle multi-test multi-case) + (list base1-a x11 1 + one11-a x11 2 + one10-a x10 1 + + base1-a x31 1 + one31-z x31 4 + + base2-l x132 1 + two132-a x132 6 + one32-y x132 4)))) + +(test #t arity-at-least? (multi-case (arity void))) + +(arity-test multi-case 1 1) + +(error-test `(,ones-case 6) type?) +(error-test `(,multi-case 6) type?) + +(error-test `(,ones-case (arity void)) exn:else?) + +(test (void) (make-struct-case null null void) x00) +(test #t procedure? (make-struct-case null null)) + +(error-test `((make-struct-case null null) x00) exn:else?) + +(error-test `(make-struct-case (list 8) (list void))) +(error-test `(make-struct-case (list exn:misc? 8) (list void void))) +(error-test `(make-struct-case (list exn:misc? 8 exn?) (list void void void))) +(error-test `(make-struct-case exn? (list void))) +(error-test `(make-struct-case (list* exn:misc? exn?) (list void))) + +(error-test `(make-struct-case (list exn?) (list 8))) +(error-test `(make-struct-case (list exn?) (list (lambda () 8)))) +(error-test `(make-struct-case (list exn:misc? exn?) + (list void string-set!))) +(error-test `(make-struct-case (list exn:misc? exn:syntax? exn?) + (list void void string-set!))) +(error-test `(make-struct-case (list exn?) void)) +(error-test `(make-struct-case (list exn?) (list* void void))) + +(error-test `(make-struct-case (list exn:misc?) (list void void)) + exn:application:list-sizes?) +(error-test `(make-struct-case (list exn:misc? exn?) (list void)) + exn:application:list-sizes?) + +(arity-test make-struct-case 2 3) + +(test 0 (struct-case-lambda x (else 0)) (arity void)) +(test (arity void) (struct-case-lambda x (else)) (arity void)) +(test (arity void) (struct-case-lambda x (arity-at-least?)) (arity void)) +(test 0 (struct-case-lambda x (arity-at-least? 0) (else 1)) (arity void)) + +(define s (struct-case-lambda x + [exn? 'exn] + [arity-at-least? x] + [else (cons x 5)])) + +(test 'exn s (make-exn 1 2)) +(test (arity void) s (arity void)) +(test (cons x00 5) s x00) + +(arity-test s 1 1) + +(error-test '(s 9)) +(error-test '(struct-case-lambda) syntaxe?) +(error-test '(struct-case-lambda 5) syntaxe?) +(error-test '(struct-case-lambda x . 5) syntaxe?) +(error-test '(struct-case-lambda x ()) syntaxe?) +(error-test '(struct-case-lambda x else) syntaxe?) +(error-test '(struct-case-lambda x (else 9) (exn? 8)) syntaxe?)) + +(define time-branch + (lambda (proc list) + (time + (let loop ([n 1000]) + (unless (zero? n) + (let loop ([l list]) + (unless (null? l) + (proc (car l)) + (loop (cddr l)))) + (loop (sub1 n))))))) + diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss new file mode 100644 index 00000000..d9b9d369 --- /dev/null +++ b/collects/tests/mzscheme/syntax.ss @@ -0,0 +1,948 @@ + +(unless (defined? 'SECTION) + (load-relative "testing.ss")) + +(test 0 'with-handlers (with-handlers () 0)) +(test 1 'with-handlers (with-handlers ([void void]) 1)) +(test 2 'with-handlers (with-handlers ([void void]) 1 2)) +(test 'zero 'zero + (with-handlers ((zero? (lambda (x) 'zero))) + (raise 0))) +(test 'zero 'zero + (with-handlers ((zero? (lambda (x) 'zero)) + (positive? (lambda (x) 'positive))) + (raise 0))) +(test 'positive 'positive + (with-handlers ((zero? (lambda (x) 'zero)) + (positive? (lambda (x) 'positive))) + (raise 1))) +(test 5 'with-handlers + (with-handlers ([void (lambda (x) 5)]) + (with-handlers ((zero? (lambda (x) 'zero))) + (/ 0)))) +(error-test '(with-handlers () + (/ 0)) + exn:application:divide-by-zero?) +(error-test '(with-handlers ((zero? (lambda (x) 'zero))) + (/ 0)) + exn:application:type?) +(error-test '(with-handlers ((zero? (lambda (x) 'zero)) + (boolean? (lambda (x) 'boolean))) + (/ 0)) + exn:application:type?) +(syntax-test '(with-handlers)) +(syntax-test '(with-handlers . 1)) +(syntax-test '(with-handlers ((zero? (lambda (x) 'zero))))) +(syntax-test '(with-handlers ((zero? (lambda (x) 'zero))) . 1)) +(syntax-test '(with-handlers (zero?) 1)) +(syntax-test '(with-handlers ((zero?)) 1)) +(syntax-test '(with-handlers ((zero? . zero?)) 1)) +(syntax-test '(with-handlers ((zero? zero?) . 2) 1)) +(syntax-test '(with-handlers ((zero? zero?) zero?) 1)) +(syntax-test '(with-handlers ((zero? zero?) (zero?)) 1)) +(syntax-test '(with-handlers ((zero? zero?) (zero?)) 1)) +(syntax-test '(with-handlers ((zero? zero? zero?)) 1)) +(syntax-test '(with-handlers ((zero? zero? . zero?)) 1)) +(syntax-test '(with-handlers ((zero? zero?)) 1 . 2)) + +(error-test '(with-handlers ((0 void)) (/ 0)) + exn:application:type?) +(error-test '(with-handlers ((void 0)) (/ 0)) + exn:application:type?) +(error-test '(with-handlers ((unbound-variable void)) 0) + exn:variable?) +(error-test '(with-handlers ((void unbound-variable)) 0) + exn:variable?) +(error-test '(with-handlers (((values 1 2) void)) 0) + arity?) +(error-test '(with-handlers ((void (values 1 2))) 0) + arity?) + +(test-values '(1 2) (lambda () (with-handlers ([void void]) + (values 1 2)))) + +(SECTION 4 1 2) +(test '(quote a) 'quote (quote 'a)) +(test '(quote a) 'quote ''a) +(syntax-test '(quote)) +(syntax-test '(quote 1 2)) + +(SECTION 4 1 3) +(test 12 (if #f + *) 3 4) +(syntax-test '(+ 3 . 4)) + +(SECTION 4 1 4) +(test 8 (lambda (x) (+ x x)) 4) +(define reverse-subtract + (lambda (x y) (- y x))) +(test 3 reverse-subtract 7 10) +(define add4 + (let ((x 4)) + (lambda (y) (+ x y)))) +(test 10 add4 6) +(test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x))) +(test (letrec([x x]) x) 'lambda ((lambda () (define d d) d))) +(test '(3 4 5 6) (lambda x x) 3 4 5 6) +(test '(5 6) (lambda (x y . z) z) 3 4 5 6) +(test 'second (lambda () (cons 'first 2) 'second)) +(syntax-test '(lambda)) +(syntax-test '(lambda x)) +(syntax-test '(lambda ())) +(syntax-test '(lambda () (begin))) +(syntax-test '(lambda . x)) +(syntax-test '(lambda x . x)) +(syntax-test '(lambda x . 5)) +(syntax-test '(lambda ((x)) x)) +(syntax-test '(lambda 5 x)) +(syntax-test '(lambda (5) x)) +(syntax-test '(lambda (x (y)) x)) +(syntax-test '(lambda (x . 5) x)) +(syntax-test '(lambda (x) x . 5)) + +(let ([f + (case-lambda + [() 'zero] + [(x) (cons 1 1) 'one] + [(x y) 'two] + [(x y z . rest) 'three+] + [x 'bad])] + [g + (case-lambda + [(x y z) 'three] + [(x y) (cons 2 2) 'two] + [(x) 'one] + [() 'zero] + [x (cons 0 'more!) 'more])] + [h + (case-lambda + [(x y) 'two] + [(x y z w) 'four])]) + (test 'zero f) + (test 'one f 1) + (test 'two f 1 2) + (test 'three+ f 1 2 3) + (test 'three+ f 1 2 3 4) + (test 'three+ f 1 2 3 4 5 6 7 8 9 10) + + (test 'zero g) + (test 'one g 1) + (test 'two g 1 2) + (test 'three g 1 2 3) + (test 'more g 1 2 3 4 5 6 7 8 9 10) + + (test 'two h 1 2) + (test 'four h 1 2 3 4) + (let ([h '(case-lambda + [(x y) 'two] + [(x y z w) 'four])]) + (error-test (list h) arity?) + (error-test (list* h '(1)) arity?) + (error-test (list* h '(1 2 3)) arity?) + (error-test (list* h '(1 2 3 4 5 6)) arity?))) + +(error-test '((case-lambda)) arity?) + +(syntax-test '(case-lambda [])) +(syntax-test '(case-lambda 1)) +(syntax-test '(case-lambda x)) +(syntax-test '(case-lambda [x])) +(syntax-test '(case-lambda [x 8][y])) +(syntax-test '(case-lambda [x][y 9])) +(syntax-test '(case-lambda [8 8])) +(syntax-test '(case-lambda [((x)) 8])) +(syntax-test '(case-lambda [(8) 8])) +(syntax-test '(case-lambda [(x . 9) 8])) +(syntax-test '(case-lambda [x . 8])) +(syntax-test '(case-lambda [(x) . 8])) +(syntax-test '(case-lambda . [(x) 8])) +(syntax-test '(case-lambda [(x) 8] . [y 7])) +(syntax-test '(case-lambda [(x) 8] . [y 7])) +(syntax-test '(case-lambda [(x) 8] [8 7])) +(syntax-test '(case-lambda [(x) 8] [((y)) 7])) +(syntax-test '(case-lambda [(x) 8] [(8) 7])) +(syntax-test '(case-lambda [(x) 8] [(y . 8) 7])) +(syntax-test '(case-lambda [(x) 8] [y . 7])) +(syntax-test '(case-lambda [(x) 8] [(y) . 7])) +(syntax-test '(case-lambda [(x x) 8] [(y) 7])) +(syntax-test '(case-lambda [(x . x) 8] [(y) 7])) +(syntax-test '(case-lambda [(y) 7] [(x x) 8])) +(syntax-test '(case-lambda [(y) 7] [(x . x) 8])) + +(SECTION 4 1 5) +(test 'yes 'if (if (> 3 2) 'yes 'no)) +(test 'no 'if (if (> 2 3) 'yes 'no)) +(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) +(test-values '(1 2) (lambda () (if (cons 1 2) (values 1 2) 0))) +(test-values '(1 2) (lambda () (if (not (cons 1 2)) 0 (values 1 2)))) +(syntax-test '(if . #t)) +(syntax-test '(if #t . 1)) +(syntax-test '(if #t 1 . 2)) +(syntax-test '(if #t)) +(syntax-test '(if #t 1 2 3)) +(syntax-test '(if #t 1 2 . 3)) +(error-test '(if (values 1 2) 3 4) arity?) + +(test (void) 'when (when (> 1 2) 0)) +(test (void) 'when (when (> 1 2) (cons 1 2) 0)) +(test 0 'when (when (< 1 2) 0)) +(test 0 'when (when (< 1 2) (cons 1 2) 0)) +(test-values '(0 10) (lambda () (when (< 1 2) (values 0 10)))) +(syntax-test '(when)) +(syntax-test '(when . 1)) +(syntax-test '(when 1)) +(syntax-test '(when 1 . 2)) +(error-test '(when (values 1 2) 0) arity?) + +(test (void) 'unless (unless (< 1 2) 0)) +(test (void) 'unless (unless (< 1 2) (cons 1 2) 0)) +(test 0 'unless (unless (> 1 2) 0)) +(test 0 'unless (unless (> 1 2) (cons 1 2) 0)) +(test-values '(0 10) (lambda () (unless (> 1 2) (values 0 10)))) +(syntax-test '(unless)) +(syntax-test '(unless . 1)) +(syntax-test '(unless 1)) +(syntax-test '(unless 1 . 2)) +(error-test '(unless (values 1 2) 0) arity?) + +(SECTION 4 1 6) +(define x 2) +(test 3 'define (+ x 1)) +(set! x 4) +(test 5 'set! (+ x 1)) +(syntax-test '(set!)) +(syntax-test '(set! x)) +(syntax-test '(set! x 1 2)) +(syntax-test '(set! 1 2)) +(syntax-test '(set! (x) 1)) +(syntax-test '(set! . x)) +(syntax-test '(set! x . 1)) +(syntax-test '(set! x 1 . 2)) + +(set!-values (x) 9) +(test 9 'set!-values x) +(test (void) 'set!-values (set!-values () (values))) +(set!-values (x x) (values 1 2)) +(test 2 'set!-values x) +(syntax-test '(set!-values)) +(syntax-test '(set!-values . x)) +(syntax-test '(set!-values x)) +(syntax-test '(set!-values 8)) +(syntax-test '(set!-values (x))) +(syntax-test '(set!-values (x) . 0)) +(syntax-test '(set!-values x 0)) +(syntax-test '(set!-values (x . y) 0)) +(syntax-test '(set!-values (x . 8) 0)) +(syntax-test '(set!-values (x 8) 0)) +(syntax-test '(set!-values (x) 0 1)) +(syntax-test '(set!-values (x) 0 . 1)) + +(error-test '(set!-values () 1) arity?) +(error-test '(set!-values () (values 1 2)) arity?) +(error-test '(set!-values (x) (values)) arity?) +(error-test '(set!-values (x) (values 1 2)) arity?) +(error-test '(set!-values (x y) 1) arity?) +(error-test '(set!-values (x y) (values 1 2 3)) arity?) + +(error-test '(set! unbound-variable 5) exn:variable?) + +(SECTION 4 2 1) +(test 'greater 'cond (cond ((> 3 2) 'greater) + ((< 3 2) 'less))) +(test 'equal 'cond (cond ((> 3 3) 'greater) + ((< 3 3) 'less) + (else 'equal))) +(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) + (else #f))) +(test #f 'cond (cond ((assv 'z '((a 1) (b 2))) => cadr) + (else #f))) +(syntax-test '(cond ((assv 'z '((a 1) (b 2))) => cadr) + (else 8) + (else #f))) +(test #f 'cond (let ([else #f]) + (cond ((assv 'z '((a 1) (b 2))) => cadr) + (else 8) + (#t #f)))) +(test 'second 'cond (cond ((< 1 2) (cons 1 2) 'second))) +(test 'second-again 'cond (cond ((> 1 2) 'ok) (else (cons 1 2) 'second-again))) +(test 1 'cond (cond (1))) +(test 1 'cond (cond (#f) (1))) +(test 1 'cond (cond (#f 7) (1))) +(test 2 'cond (cond (#f 7) (1 => add1))) +(test add1 'cond (let ([=> 9]) (cond (#f 7) (1 => add1)))) +(non-z '(test 0 'case (case (* 2 3) + (6 0) + (else 7)))) +(test 'composite 'case (case (* 2 3) + ((2 3 5 7) 'prime) + ((1 4 6 8 9) 'composite))) +(test 'consonant 'case (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) +(test 'second 'case (case 10 + [(10) (cons 1 2) 'second] + [else 5])) +(test 'second-again 'case (case 11 + [(10) (cons 1 2) 'second] + [else (cons 1 2) 'second-again])) +(test-values '(10 9) (lambda () + (cond + [(positive? 0) 'a] + [(positive? 10) (values 10 9)] + [else #f]))) +(test-values '(10 9) (lambda () + (case (string->symbol "hello") + [(bye) 'a] + [(hello) (values 10 9)] + [else #f]))) +(error-test '(cond [(values 1 2) 8]) arity?) +(error-test '(case (values 1 2) [(a) 8]) arity?) + +(test #t 'and (and (= 2 2) (> 2 1))) +(test #f 'and (and (= 2 2) (< 2 1))) +(test '(f g) 'and (and 1 2 'c '(f g))) +(test #t 'and (and)) +(test-values '(1 12) (lambda () (and (cons 1 2) (values 1 12)))) +(test #t 'or (or (= 2 2) (> 2 1))) +(test #t 'or (or (= 2 2) (< 2 1))) +(test #f 'or (or #f #f #f)) +(test #f 'or (or)) +(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) +(test-values '(1 12) (lambda () (or (not (cons 1 2)) (values 1 12)))) +(syntax-test '(cond #t)) +(syntax-test '(cond ()) ) +(syntax-test '(cond (1 =>)) ) +(syntax-test '(cond (1 => 3 4)) ) +(syntax-test '(cond . #t)) +(syntax-test '(cond (#t . 1))) +(syntax-test '(cond (#t 1) #f)) +(syntax-test '(cond (#t 1) . #f)) +(error-test '(cond ((values #t #f) 1)) arity?) +(syntax-test '(case)) +(syntax-test '(case 0 #t)) +(syntax-test '(case . 0)) +(syntax-test '(case 0 . #t)) +(syntax-test '(case 0 (0 #t))) +(syntax-test '(case 0 ())) +(syntax-test '(case 0 (0))) +(syntax-test '(case 0 (0 . 8))) +(syntax-test '(case 0 ((0 . 1) 8))) +(syntax-test '(case 0 (0 8) #f)) +(syntax-test '(case 0 (0 8) . #f)) +(syntax-test '(case 0 (else 1) (else 2))) +(error-test '(case 0 ((0) =>)) exn:variable?) +(syntax-test '(and . 1)) +(syntax-test '(and 1 . 2)) +(syntax-test '(or . 1)) +(syntax-test '(or 1 . 2)) +(error-test '(and #t (values 1 2) 8) arity?) +(error-test '(or #f (values 1 2) 8) arity?) + +(SECTION 4 2 2) +(test 6 'let (let ((x 2) (y 3)) (* x y))) +(test 'second 'let (let ((x 2) (y 3)) (* x y) 'second)) +(test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y))) +(test 6 'let-values (let-values (((x y) (values 2 3))) (* x y))) +(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) +(test 35 'let-values (let-values (((x y) (values 2 3))) (let-values (((x) 7) ((z) (+ x y))) (* z x)))) +(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) +(test 70 'let*-values (let ((x 2) (y 3)) (let*-values (((x) 7) ((z) (+ x y))) (* z x)))) +(test #t 'letrec (letrec ((-even? + (lambda (n) (if (zero? n) #t (-odd? (- n 1))))) + (-odd? + (lambda (n) (if (zero? n) #f (-even? (- n 1)))))) + (-even? 88))) +(test #t 'letrec-values (letrec-values (((-even? -odd?) + (values + (lambda (n) (if (zero? n) #t (-odd? (- n 1)))) + (lambda (n) (if (zero? n) #f (-even? (- n 1))))))) + (-even? 88))) +(define x 34) +(test 5 'let (let ((x 3)) (define x 5) x)) +(test 5 'let (let ((x 3)) (define-values (x w) (values 5 8)) x)) +(test 34 'let x) +(test 6 'let (let () (define x 6) x)) +(test 34 'let x) +(test 7 'let* (let* ((x 3)) (define x 7) x)) +(test 34 'let* x) +(test 8 'let* (let* () (define x 8) x)) +(test 34 'let* x) +(test 9 'letrec (letrec () (define x 9) x)) +(test 34 'letrec x) +(test 10 'letrec (letrec ((x 3)) (define x 10) x)) +(test 34 'letrec x) +(teval '(test 5 'letrec (letrec ((x 5)(y x)) y))) +(test 3 'let (let ((y 'apple) (x 3) (z 'banana)) x)) +(test 3 'let* (let* ((y 'apple) (x 3) (z 'banana)) x)) +(test 3 'letrec (letrec ((y 'apple) (x 3) (z 'banana)) x)) +(test 3 'let* (let* ((x 7) (y 'apple) (z (set! x 3))) x)) +(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #f) (set! x 3) #f))) x)) +(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #t) #t (set! x 3)))) x)) +(test 3 'let-values (let-values (((y x z) (values 'apple 3 'banana))) x)) +(test 3 'let*-values (let*-values (((y x z) (values 'apple 3 'banana))) x)) +(test 3 'letrec-values (letrec-values (((y x z) (values 'apple 3 'banana))) x)) +(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (set! x 3))) x)) +(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #f) (set! x 3) #f))) x)) +(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #t) #t (set! x 3)))) x)) +(test 1 'named-let-scope (let ([f add1]) (let f ([n (f 0)]) n))) + +(test-values '(3 4) (lambda () (let ([x 3][y 4]) (values x y)))) +(test-values '(3 -4) (lambda () (let loop ([x 3][y -4]) (values x y)))) +(test-values '(3 14) (lambda () (let* ([x 3][y 14]) (values x y)))) +(test-values '(3 24) (lambda () (letrec ([x 3][y 24]) (values x y)))) +(test-values '(3 54) (lambda () (let-values ([(x y) (values 3 54)]) (values x y)))) +(test-values '(3 64) (lambda () (let*-values ([(x y) (values 3 64)]) (values x y)))) +(test-values '(3 74) (lambda () (letrec-values ([(x y) (values 3 74)]) (values x y)))) + +(test '(10 11) 'letrec-values (letrec-values ([(names kps) + (letrec ([oloop 10]) + (values oloop (add1 oloop)))]) + (list names kps))) + +(define (error-test-let/no-* expr) + (syntax-test (cons 'let expr)) + (syntax-test (cons 'let (cons 'name expr))) + (syntax-test (cons 'letrec expr))) +(define (error-test-let expr) + (error-test-let/no-* expr) + (syntax-test (cons 'let* expr))) +(error-test-let 'x) +(error-test-let '(x)) +(error-test-let '(())) +(error-test-let '(x ())) +(syntax-test '(let* x () 1)) +(syntax-test '(letrec x () 1)) +(error-test-let '(x . 1)) +(error-test-let '(() . 1)) +(error-test-let '(((x 1)))) +(error-test-let '(((x 1)) . 1)) +(error-test-let '(((x . 1)) 1)) +(error-test-let '(((1 1)) 1)) +(error-test-let '(((x 1) 1) 1)) +(error-test-let '(((x 1) . 1) 1)) +(error-test-let '(((x 1 1)) 1)) +(error-test-let '(((x 1 1)) 1)) +(error-test-let '(((x 1)) 1 . 2)) +(error-test-let/no-* '(((x 1) (x 2)) 1)) +(error-test-let/no-* '(((x 1) (y 3) (x 2)) 1)) +(error-test-let/no-* '(((y 3) (x 1) (x 2)) 1)) +(error-test-let/no-* '(((x 1) (x 2) (y 3)) 1)) +(test 5 'let* (let* ([x 4][x 5]) x)) +(error-test-let '(() (define x 10))) +(error-test-let '(() (define x 10) (define y 20))) + +(define (do-error-test-let-values/no-* expr syntax-test) + (syntax-test (cons 'let-values expr)) + (syntax-test (cons 'letrec-values expr))) +(define (do-error-test-let-values expr syntax-test) + (do-error-test-let-values/no-* expr syntax-test) + (syntax-test (cons 'let*-values expr))) +(define (error-test-let-values/no-* expr) + (do-error-test-let-values/no-* expr syntax-test)) +(define (error-test-let-values expr) + (do-error-test-let-values expr syntax-test)) +(error-test-let-values 'x) +(error-test-let-values '(x)) +(error-test-let-values '(())) +(error-test-let-values '(x ())) +(syntax-test '(let*-values x () 1)) +(syntax-test '(letrec-values x () 1)) +(error-test-let-values '(x . 1)) +(error-test-let-values '(() . 1)) +(error-test-let-values '((((x) 1)))) +(error-test-let-values '((((x) 1)) . 1)) +(error-test-let-values '((((x) . 1)) 1)) +(error-test-let-values '((((1) 1)) 1)) +(error-test-let-values '((((x 1) 1)) 1)) +(error-test-let-values '((((1 x) 1)) 1)) +(error-test-let-values '((((x) 1) . 1) 1)) +(error-test-let-values '((((x) 1 1)) 1)) +(error-test-let-values '((((x . y) 1)) 1)) +(error-test-let-values '((((x . 1) 1)) 1)) +(error-test-let-values '((((x) 1)) 1 . 2)) +(error-test-let-values '((((x x) 1)) 1)) +(error-test-let-values '((((y) 0) ((x x) 1)) 1)) +(error-test-let-values '((((x x) 1) ((y) 0)) 1)) +(error-test-let-values/no-* '((((x) 1) ((x) 2)) 1)) +(error-test-let-values/no-* '((((x) 1) ((y) 3) ((x) 2)) 1)) +(error-test-let-values/no-* '((((y) 3) ((x) 1) ((x) 2)) 1)) +(error-test-let-values/no-* '((((x) 1) ((x) 2) ((y) 3)) 1)) +(test 5 'let* (let*-values ([(x) 4][(x) 5]) x)) + +(do-error-test-let-values '((((x y) 1)) 1) (lambda (x) (error-test x arity?))) +(do-error-test-let-values '((((x) (values 1 2))) 1) (lambda (x) (error-test x arity?))) +(do-error-test-let-values '(((() (values 1))) 1) (lambda (x) (error-test x arity?))) +(do-error-test-let-values '((((x) (values))) 1) (lambda (x) (error-test x arity?))) + +(test 5 'embedded (let () (define y (lambda () x)) (define x 5) (y))) + +(let ([wrap (lambda (body) + (syntax-test `(let () ,@body)) + (syntax-test `(let () (begin ,@body))))]) + (wrap '((define x 7) (define x 8) x)) + (wrap '(2 (define y 8) x)) + (wrap '((define 3 8) x)) + (wrap '((define-values x 8) x))) + +(let ([wrap + (lambda (val body) + (teval `(test ,val 'let-begin (let () ,@body))) + (teval `(test ,val 'let-begin (let ([xyzw 12]) ,@body))) + (teval `(test ,val (lambda () ,@body))) + (teval `(test ,val 'parameterize-begin + (parameterize () ,@body))) + (teval `(test ,val 'parameterize-begin + (parameterize ([current-directory (current-directory)]) + ,@body))) + (teval `(test ,val 'with-handlers-begin + (with-handlers () ,@body))) + (teval `(test ,val 'with-handlers-begin + (with-handlers ([void void]) ,@body))) + (teval `(test ,val 'fluid-let-begin (fluid-let () ,@body))) + (teval `(test ,val 'fluid-let-begin (fluid-let ([x 20]) ,@body))) + (syntax-test `(when (positive? 1) ,@body)) + (syntax-test `(unless (positive? -1) ,@body)) + (syntax-test `(cond [(positive? 1) ,@body][else #f])) + (syntax-test `(cond [(positive? -1) 0][else ,@body])) + (syntax-test `(case (positive? 1) [(#t) ,@body][else -12])) + (syntax-test `(cond [#t ,@body])) + (syntax-test `(do ((x 1)) (#t ,@body) ,@body)) + (syntax-test `(begin0 12 ,@body)))]) + (wrap 5 '((begin (define x 5)) x)) + (wrap 5 '((begin (define x 5) x))) + (wrap 15 '((begin (define x 5)) (begin (define y (+ x 10)) y))) + (wrap 13 '((begin) 13)) + (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x))) + (wrap 7 '((begin (begin (begin (define x 7) (begin) x)))))) + +(SECTION 4 2 3) +(define x 0) +(define (test-begin bg nested-bg) + (let* ([make-args + (lambda (bg b) + (if (eq? bg 'begin) + b + (let* ([len (length b)] + [last (list-ref b (sub1 len))]) + (cons last + (let loop ([l b]) + (if (null? (cdr l)) + null + (cons (car l) (loop (cdr l)))))))))] + [test-bg + (lambda (v b) + (let* ([args (make-args bg b)] + [expr (cons bg args)]) + (printf "~s:~n" expr) + (teval `(test ,v (quote ,bg) ,expr))))] + [make-bg + (lambda (b) + (cons nested-bg (make-args nested-bg b)))] + [make-test-bg-d + (lambda (bg) + (lambda (v1 v2 b) + (test-bg (if (eq? bg 'begin) + v1 + v2) + b)))] + [test-bg-d (make-test-bg-d bg)] + [test-bg-d2 (make-test-bg-d nested-bg)]) + (teval '(set! x 0)) + (test-bg-d 6 1 '((set! x 5) (+ x 1))) + (test-bg 5 '(5)) + (test-bg 3 '(2 3)) + (test-bg 3 `(2 (,bg 3))) + (test-bg 3 `(,(make-bg '(2)) ,(make-bg '(3)))) + (test-bg-d 7 6 '((set! x 6) 'a (+ x 1))) + (test-bg ''w '((set! x 6) 'a (+ x 1) 'w)) + (test-bg-d 8 7 '('b (set! x 7) (+ x 1))) + (test-bg-d 9 8 '('b (set! x 8) 'a (+ x 1))) + (test-bg ''z '('b (set! x 8) 'a (+ x 1) 'z)) + (test-bg-d 7 9 `(,(make-bg '((set! x 6) 'a)) (+ x 1))) + (test-bg 10 `(,(make-bg '((set! x 60) 'a)) 10)) + (teval '(test 60 'x x)) + (test-bg 10 `(,(make-bg '((set! x 65) 'a)) (add1 20) 10)) + (teval '(test 65 'x x)) + (test-bg ''a `(10 ,(make-bg '((set! x 66) 'a)))) + (teval '(test 66 'x x)) + (test-bg ''a `(10 (add1 32) ,(make-bg '((set! x 67) 'a)))) + (teval '(test 67 'x x)) + (teval '(set! x 6)) + (test-bg-d 8 7 `(,(make-bg '('b (set! x 7) 'a)) (+ x 1))) + (test-bg-d 9 8 `(,(make-bg '('b (set! x 8))) ,(make-bg '('a (+ x 1))))) + (test-bg-d2 10 9 `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))))) + (test-bg ''s `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1) 's)))))))) + (test-bg ''t `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))) 't)) + (teval `(test 5 call-with-values (lambda () ,(make-bg '((values 1 2) (values 1 3 1)))) +)) + (syntax-test `(let () 10 (,bg) 5)) + (syntax-test `(,bg . 1)) + (syntax-test `(,bg 1 . 2)))) + +(test-begin 'begin 'begin) +(test-begin 'begin0 'begin) +(test-begin 'begin0 'begin0) +(test-begin 'begin 'begin0) + +(syntax-test `(begin0)) +(begin) ; must succeed, but we can't wrap it + +(test 4 'implicit-begin (let ([x 4][y 7]) 'y x)) +(test 4 'implicit-begin (let ([x 4][y 7]) y x)) + +(SECTION 4 2 5) +(define f-check #t) +(define f (delay (begin (set! f-check #f) 5))) +(test #t (lambda () f-check)) +(test 5 force f) +(test #f (lambda () f-check)) +(test 5 force f) +(define f-check-2 (delay (values 1 5))) +(test-values '(1 5) (lambda () (force f-check-2))) +(values 1 2) +(test-values '(1 5) (lambda () (force f-check-2))) +(syntax-test '(delay)) +(syntax-test '(delay . 1)) +(syntax-test '(delay 1 . 2)) +(syntax-test '(delay 1 2)) + +(SECTION 4 2 6) +(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) +(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) +(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) +(test '((foo 7) . cons) + 'quasiquote + `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) +(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) +(test 5 'quasiquote `,(+ 2 3)) +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) +(test '(a `(b ,x ,'y d) e) 'quasiquote + (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) +(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) +(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) +(test '(()) 'qq `((,@()))) +(define x 5) +(test '(quasiquote (unquote x)) 'qq ``,x) +(test '(quasiquote (unquote 5)) 'qq ``,,x) +(test '(quasiquote (unquote-splicing x)) 'qq ``,@x) +(test '(quasiquote (unquote-splicing 5)) 'qq ``,@,x) +(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x) +(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x) + +(test '(quasiquote (unquote result)) 'qq `(quasiquote ,result)) +(test (list 'quasiquote car) 'qq `(,'quasiquote ,car)) + +(syntax-test '(quasiquote)) +(syntax-test '(quasiquote . 5)) +(syntax-test '(quasiquote 1 . 2)) +(syntax-test '(quasiquote 1 2)) +(syntax-test '(unquote 7)) +(syntax-test '(unquote-splicing 7)) + +(syntax-test '`(1 . ,@5)) +(error-test '`(1 ,@5)) +(error-test '`(1 ,@5 2)) + +(define (qq-test e) + (syntax-test e ) + (syntax-test (list 'quasiquote e)) + (syntax-test (list 'quasiquote e)) + (syntax-test (list 'quasiquote (list 'quasiquote e))) + (syntax-test (list 'quasiquote (list 'quasiquote (list 'unquote e)))) + (syntax-test (list 'quasiquote (list 'quasiquote (list 'unquote-splicing e))))) +(qq-test '(unquote)) +(qq-test '(unquote 7 8 9)) +(qq-test '(unquote-splicing)) +(qq-test '(unquote-splicing 7 8 9)) + +(test '(unquote . 5) 'qq (quasiquote (unquote . 5))) +(test '(unquote 1 . 5) 'qq (quasiquote (unquote 1 . 5))) +(test '(unquote 1 2 . 5) 'qq (quasiquote (unquote 1 2 . 5))) + +(test '(unquote 1 2 7 . 5) 'qq (quasiquote (unquote 1 2 ,(+ 3 4) . 5))) +(test '(unquote 1 2 (unquote (+ 3 4)) . 5) 'qq (quasiquote (unquote 1 2 ,',(+ 3 4) . 5))) + +(test '(1 2 3 4 . 5) 'qq `(1 ,@'(2 3 4) . 5)) + +(error-test '`(10 ,(values 1 2)) arity?) +(error-test '`(10 ,@(values 1 2)) arity?) + +(SECTION 5 2 1) +(define add3 (lambda (x) (+ x 3))) +(test 6 'define (add3 3)) +(define (add3 x) (+ x 3)) +(test 6 'define (add3 3)) +(define first car) +(test 1 'define (first '(1 2))) +(syntax-test '(define)) +(syntax-test '(define . x)) +(syntax-test '(define x)) +(syntax-test '(define x . 1)) +(syntax-test '(define 1 2)) +(syntax-test '(define (1) 1)) +(syntax-test '(define (x 1) 1)) +(syntax-test '(define x 1 . 2)) +(syntax-test '(define x 1 2)) + +(define-values (add3) (lambda (x) (+ x 3))) +(test 6 'define (add3 3)) +(define-values (add3 another) (values (lambda (x) (+ x 3)) 9)) +(test 6 'define (add3 3)) +(test 9 'define another) +(define-values (first second third) (values car cadr caddr)) +(test 1 'define (first '(1 2))) +(test 2 'define (second '(1 2))) +(test 3 'define (third '(1 2 3))) +(define-values () (values)) +(syntax-test '(define-values)) +(syntax-test '(define-values . x)) +(syntax-test '(define-values x)) +(syntax-test '(define-values (x))) +(syntax-test '(define-values x . 1)) +(syntax-test '(define-values (x) . 1)) +(syntax-test '(define-values 1 2)) +(syntax-test '(define-values (1) 2)) +(syntax-test '(define-values (x 1) 1)) +(syntax-test '(define-values (x . y) 1)) +(syntax-test '(define-values (x) 1 . 2)) +(syntax-test '(define-values (x) 1 2)) + +(syntax-test '((define x 2) 0 1)) +(syntax-test '(+ (define x 2) 1)) +(syntax-test '(if (define x 2) 0 1)) +(syntax-test '(begin0 (define x 2))) +(syntax-test '(begin0 (define x 2) 0)) +(syntax-test '(begin0 0 (define x 2))) +(syntax-test '(begin0 0 (define x 2) (define x 12))) +(syntax-test '(let () (define x 2))) +(syntax-test '(letrec () (define x 2))) +(syntax-test '(lambda () (define x 2))) +(syntax-test '(lambda () (void (define x 2)) 1)) + +; Unfortunately, there's no good way to test this for mzc: +(unless (defined? 'building-flat-tests) + (error-test '(define x (values)) exn:application:arity?) + (error-test '(define x (values 1 2)) exn:application:arity?) + (error-test '(define-values () 3) exn:application:arity?) + (error-test '(define-values () (values 1 3)) exn:application:arity?) + (error-test '(define-values (x y) (values)) exn:application:arity?) + (error-test '(define-values (x y) 3) exn:application:arity?) + (error-test '(define-values (x y) (values 1 2 3)) exn:application:arity?)) + +(begin (define ed-t1 1) (define ed-t2 2)) +(test 1 'begin-define ed-t1) +(test 2 'begin-define ed-t2) +(begin (begin (begin (begin 10 (define ed-t2.5 2.5) 12)))) +(test 2.5 'begin-define ed-t2.5) +(syntax-test '(if (zero? 0) (define ed-t3 3) (define ed-t3 -3))) +(syntax-test '(if #t (define ed-t3 3) (define ed-t3 -3))) +(syntax-test '(if #f (define ed-t3 3) (define ed-t3 -3))) + +(SECTION 5 2 2) +(test 45 'define + (let ((x 5)) + (define foo (lambda (y) (bar x y))) + (define bar (lambda (a b) (+ (* a b) a))) + (foo (+ x 3)))) +(define x 34) +(define (foo) (define x 5) x) +(test 5 foo) +(test 34 'define x) +(define foo (lambda () (define x 5) x)) +(test 5 foo) +(test 34 'define x) +(define (foo x) ((lambda () (define x 5) x)) x) +(test 88 foo 88) +(test 4 foo 4) +(test 34 'define x) + +'(teval '(test 5 'define + (let () + (define x 5) + (define define (lambda (a b) (+ a b))) + (define x 7) + x))) +'(teval '(syntax-test '(let () + (define define 5) + (define y 6) + y))) + +(syntax-test '(let () + (define x 5))) +(syntax-test '(let () + (if #t + (define x 5)) + 5)) + +; Can't shadow syntax/macros with embedded defines +(syntax-test '(let () + (define lambda 5) + lambda)) +(syntax-test '(let () + (define define 5) + define)) + +(syntax-test '(lambda () (define x 10) (begin))) +(syntax-test '(lambda () (define x 10) (begin) (begin))) +(syntax-test '(lambda () (define x 10) (begin) (begin x) (begin))) + +(test 87 (lambda () (define x 87) (begin) (begin x))) + +(SECTION 4 2 4) +(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) +(test 25 'do (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum)))) +(test 1 'let (let foo () 1)) +(test '((6 1 3) (-5 -2)) 'let + (let loop ((numbers '(3 -2 1 6 -5)) + (nonneg '()) + (neg '())) + (cond ((null? numbers) (list nonneg neg)) + ((negative? (car numbers)) + (loop (cdr numbers) + nonneg + (cons (car numbers) neg))) + (else + (loop (cdr numbers) + (cons (car numbers) nonneg) + neg))))) +(test 5 'do (do ((x 1)) (#t 5))) +(test-values '(10 5) (lambda () (do ((x 1)) (#t (values 10 5))))) +(syntax-test '(do)) +(syntax-test '(do ()) ) +(syntax-test '(do () ()) ) +(syntax-test '(do (1) (#t 5) 5)) +(syntax-test '(do ((1)) (#t 5) 5)) +(syntax-test '(do ((1 7)) (#t 5) 5)) +(syntax-test '(do ((x . 1)) (#t 5) 5)) +(syntax-test '(do ((x 1) 2) (#t 5) 5)) +(syntax-test '(do ((x 1) . 2) (#t 5) 5)) +(syntax-test '(do ((x 1)) (#t . 5) 5)) +(syntax-test '(do ((x 1)) (#t 5) . 5)) + +(SECTION 'let/cc) + +(test 0 'let/cc (let/cc k (k 0) 1)) +(test 0 'let/cc (let/cc k 0)) +(test 1 'let/cc (let/cc k (cons 1 2) 1)) +(test-values '(2 1) (lambda () (let/cc k (values 2 1)))) +(test-values '(2 1) (lambda () (let/cc k (k 2 1)))) +(syntax-test '(let/cc)) +(syntax-test '(let/cc . k)) +(syntax-test '(let/cc k)) +(syntax-test '(let/cc k . 1)) +(syntax-test '(let/cc 1 1)) + +(test 0 'let/ec (let/ec k (k 0) 1)) +(test 0 'let/ec (let/ec k 0)) +(test 1 'let/ec (let/ec k (cons 1 2) 1)) +(test-values '(2 1) (lambda () (let/ec k (values 2 1)))) +(test-values '(2 1) (lambda () (let/ec k (k 2 1)))) +(syntax-test '(let/ec)) +(syntax-test '(let/ec . k)) +(syntax-test '(let/ec k)) +(syntax-test '(let/ec k . 1)) +(syntax-test '(let/ec 1 1)) + +(SECTION 'fluid-let) +(define x 1) +(define y -1) +(define (get-x) x) +(test 5 'fluid-let (fluid-let () 5)) +(test 2 'fluid-let (fluid-let ([x 2]) x)) +(test 0 'fluid-let (fluid-let ([x 2][y -2]) (+ x y))) +(test 20 'fluid-let (fluid-let ([x 20]) (get-x))) +(test 1 'fluid-let-done x) +(error-test '(fluid-let ([x 10]) (error 'bad)) exn:user?) +(test 1 'fluid-let-done-escape x) +(test 3 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y)))) +(test 0 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y)) (y))) +(test-values '(34 56) (lambda () (fluid-let ([x 34][y 56]) (values x y)))) +(test 'second 'fluid-let (fluid-let ([x 2][y -2]) (+ x y) 'second)) + +(error-test '(fluid-let ([undefined-variable 0]) 8) exn:variable?) + +(syntax-test '(fluid-let)) +(syntax-test '(fluid-let . 1)) +(syntax-test '(fluid-let x 9)) +(syntax-test '(fluid-let 1 9)) +(syntax-test '(fluid-let (x) 9)) +(syntax-test '(fluid-let ([x]) 9)) +(syntax-test '(fluid-let ([x . 5]) 9)) +(syntax-test '(fluid-let ([x 5] . y) 9)) +(syntax-test '(fluid-let ([x 5] [y]) 9)) +(syntax-test '(fluid-let ([x 5]) . 9)) +(syntax-test '(fluid-let ([x 5]) 9 . 10)) + +(SECTION 'parameterize) + +(test 5 'parameterize (parameterize () 5)) +(test 6 'parameterize (parameterize ([error-print-width 10]) 6)) +(test 7 'parameterize (parameterize ([error-print-width 10] + [current-exception-handler void]) + 7)) +(define oepw (error-print-width)) +(error-test '(parameterize ([error-print-width 777]) (error 'bad)) exn:user?) +(test oepw 'parameterize (error-print-width)) +(error-test '(parameterize ([error-print-width 777] + [current-output-port (current-error-port)]) + (error 'bad)) + exn:user?) +(error-test '(parameterize ([error-print-width 'a]) 10)) + +(define p (make-parameter 1)) +(define q (make-parameter 2)) +(test '1 'pz-order (parameterize ([p 3][q (p)]) (q))) + +(error-test '(parameterize) syntaxe?) +(error-test '(parameterize ()) syntaxe?) +(error-test '(parameterize ((x y))) syntaxe?) +(error-test '(parameterize ((x y)) . 8) syntaxe?) +(error-test '(parameterize (x) 8) syntaxe?) +(error-test '(parameterize (9) 8) syntaxe?) +(error-test '(parameterize ((x z) . y) 8) syntaxe?) +(error-test '(parameterize ((x . z)) 8) syntaxe?) +(error-test '(parameterize ((x . 9)) 8) syntaxe?) +(error-test '(parameterize ((x . 9)) 8) syntaxe?) + +(SECTION 'time) +(test 1 'time (time 1)) +(test -1 'time (time (cons 1 2) -1)) +(test-values '(-1 1) (lambda () (time (values -1 1)))) +(syntax-test '(time)) +(syntax-test '(time . 1)) +(syntax-test '(time 1 . 2)) + +(SECTION 'compiler) +; Tests specifically aimed at the compiler +(error-test '(let ([x (values 1 2)]) x) exn:application:arity?) +; Known primitive +(error-test '(let ([x (#%make-pipe)]) x) exn:application:arity?) +; Known local +(error-test '(let* ([f (lambda () (values 1 2))][x (f)]) x) exn:application:arity?) + +; Known local with global in its closure +(test 15 'known (let ([g (lambda () + (letrec ([f (lambda (x) + (+ x 5))]) + (f 10)))]) + (g))) +; Known local with a set! +(test 16 'known (let ([g (lambda () + (letrec ([f (lambda (x) + (let ([y x]) + (set! x 7) + (+ y 5)))]) + (f 11)))]) + (g))) +; Known local non-function +(error-test '(apply (lambda () (let ([f 12]) (f))) null) exn:application:type?) +; Known local with revsed arguments: +(test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0) + +(report-errs) diff --git a/collects/tests/mzscheme/tcp.ss b/collects/tests/mzscheme/tcp.ss new file mode 100644 index 00000000..3a917a63 --- /dev/null +++ b/collects/tests/mzscheme/tcp.ss @@ -0,0 +1,59 @@ + +(define id 40000) + +(define max-send 100000) +(define print-mod 10000) + +(define (client host) + (lambda () + (let-values ([(r w) (tcp-connect host id)]) + (values r w void)))) + +(define server + (lambda () + (let ([l (tcp-listen id)]) + (let-values ([(r w) (tcp-accept l)]) + (values r w (lambda () (tcp-close l))))))) + +(define (tread connect) + (let-values ([(r w close) (connect)]) + (printf "Hit return to start reading~n") + (read-line) + (let loop ([last -1]) + (let ([v (read r)]) + (if (eof-object? v) + (begin + (close-input-port r) + (close-output-port w) + (close) + last) + (begin + (unless (= v (add1 last)) + (printf "skipped! ~a ~a~n" last v)) + (when (zero? (modulo v print-mod)) + (printf "got ~a~n" v)) + (loop v))))))) + +(define (twrite connect) + (let-values ([(r w close) (connect)] + [(t) (thread (lambda () + (let loop () + (sleep 1) + (printf "tick~n") + (loop))))]) + (let ([done (lambda () + (close-output-port w) + (close-input-port r) + (close) + (kill-thread t))]) + (let loop ([n 0]) + (if (= n max-send) + (begin + (printf "stopped before ~a~n" n) + (done)) + + (begin + (fprintf w "~s~n" n) + (when (zero? (modulo n print-mod)) + (printf "sent ~a~n" n)) + (loop (add1 n)))))))) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss new file mode 100644 index 00000000..0bca4bf5 --- /dev/null +++ b/collects/tests/mzscheme/testing.ss @@ -0,0 +1,250 @@ +;;; `test.scm' Test correctness of MzScheme implementations. +;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer. +;;; Modified for MzScheme by Matthew + +;;; MODIFIED for MzScheme - Matthew 8/95 +;;; Added a few more tests, like append!, reverse!, etc. +;;; Added testing for inexact numbers +;;; Added a lot of error testing +;;; modified for rational and complex numbers - Matthew 12/95 +;;; modified to test exceptions and more of MzScheme - Matthew 4/96 +;;; split into multiple files - Matthew 4/96 +;;; extended, extended, extended + +;;; This includes examples from +;;; William Clinger and Jonathan Rees, editors. +;;; Revised^4 Report on the Algorithmic Language Scheme +;;; and the IEEE specification. + +; The format of the next line is important: file.ss relies on it +(define cur-section '())(define errs '()) + +(define teval eval) + +(define SECTION (lambda args + (let ([ep (current-error-port)]) + (display "SECTION" ep) (write args ep) (newline ep) + (set! cur-section args) #t))) +(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) + +(print-struct #t) + +(define number-of-tests 0) +(define number-of-error-tests 0) +(define number-of-exn-tests 0) + +(define test + (lambda (expect fun . args) + (set! number-of-tests (add1 number-of-tests)) + (write (cons fun args)) + (display " ==> ") + (flush-output) + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (record-error (list res expect (cons fun args))) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) + +(define exn-table + (list (cons exn? (cons exn-message string?)) + (cons exn? (cons exn-continuation-marks continuation-mark-set?)) + (cons exn:variable? (cons exn:variable-id symbol?)) + (cons exn:application:arity? (cons exn:application-value integer?)) + (cons exn:application:arity? (cons exn:application:arity-expected + (lambda (a) + (or (integer? a) + (and (arity-at-least? a) + (integer? (arity-at-least-value a))) + (and (list? a) + (andmap + (lambda (a) + (or (integer? a) + (and (arity-at-least? a) + (integer? + (arity-at-least-value a))))) + a)))))) + (cons exn:application:type? (cons exn:application:type-expected symbol?)) + + (cons exn:i/o:port? (cons exn:i/o:port-port (lambda (x) (or (input-port? x) (output-port? x))))) + (cons exn:i/o:port:read? (cons exn:i/o:port-port input-port?)) + (cons exn:i/o:port:write? (cons exn:i/o:port-port output-port?)) + (cons exn:i/o:port:user? (cons exn:i/o:port-port input-port?)) + (cons exn:i/o:filesystem? (cons exn:i/o:filesystem-pathname string?)) + (cons exn:i/o:filesystem? (cons exn:i/o:filesystem-detail (lambda (x) + (memq x '(#f + ill-formed-path + already-exists + wrong-version))))))) + +(define mz-test-syntax-errors-allowed? #t) + +(define thunk-error-test + (case-lambda + [(th expr) (thunk-error-test th expr exn:application:type?)] + [(th expr exn?) + (set! number-of-error-tests (add1 number-of-error-tests)) + (write expr) + (display " =e=> ") + (call/ec (lambda (escape) + (let* ([old-esc-handler (error-escape-handler)] + [old-handler (current-exception-handler)] + [orig-err-port (current-error-port)] + [test-handler + (lambda () + (escape #t))] + [test-exn-handler + (lambda (e) + (when (and exn? (not (exn? e))) + (printf " WRONG EXN TYPE: ~s " e) + (record-error (list e 'exn-type expr))) + (when (and (exn:syntax? e) + (not mz-test-syntax-errors-allowed?)) + (printf " LATE SYNTAX EXN: ~s " e) + (record-error (list e 'exn-late expr))) + + (for-each + (lambda (row) + (let ([pred? (car row)]) + (when (pred? e) + (set! number-of-exn-tests + (add1 number-of-exn-tests)) + (let ([sel (cadr row)] + [pred? (cddr row)]) + (unless (pred? (sel e)) + (printf " WRONG EXN ELEM: ~s " e) + (record-error (list e 'exn-elem expr))))))) + exn-table) + + (old-handler e))]) + (dynamic-wind + (lambda () + (current-error-port (current-output-port)) + (current-exception-handler test-exn-handler) + (error-escape-handler test-handler)) + (lambda () + (let ([v (th)]) + (write v) + (display " BUT EXPECTED ERROR") + (record-error (list v 'Error expr)) + (newline) + #f)) + (lambda () + (current-error-port orig-err-port) + (current-exception-handler old-handler) + (error-escape-handler old-esc-handler))))))])) + +(if (not (defined? 'error-test)) + (global-defined-value + 'error-test + (case-lambda + [(expr) (error-test expr exn:application:type?)] + [(expr exn?) + (thunk-error-test (lambda () (eval expr)) expr exn?)]))) + +(define (syntax-test expr) + (error-test expr exn:syntax?) + (error-test `(if #f ,expr) exn:syntax?)) + +(define (arity-test f min max) + (letrec ([aok? + (lambda (a) + (cond + [(integer? a) (= a min max)] + [(arity-at-least? a) (and (negative? max) + (= (arity-at-least-value a) min))] + [(and (list? a) (andmap integer? a)) + (and (= min (car a)) (= max + (let loop ([l a]) + (if (null? (cdr l)) + (car l) + (loop (cdr l))))))] + [(list? a) + ; Just check that all are consistent for now. + ; This should be improved. + (andmap + (lambda (a) + (if (number? a) + (<= min a (if (negative? max) a max)) + (>= (arity-at-least-value a) min))) + a)] + [else #f]))] + [make-ok? + (lambda (v) + (lambda (e) + (and (exn:application:arity? e) + (= (exn:application-value e) v) + (aok? (exn:application:arity-expected e)))))] + [do-test + (lambda (f args check?) + (set! number-of-error-tests (add1 number-of-error-tests)) + (printf "(apply ~s '~s) =e=> " f args) + (let/ec done + (let ([v (with-handlers ([void + (lambda (exn) + (if (check? exn) + (printf " ~a~n" (exn-message exn)) + (let ([ok-type? (exn:application:arity? exn)]) + (printf " WRONG EXN ~a: ~s~n" + (if ok-type? + "FIELD" + "TYPE") + exn) + (record-error (list exn + (if ok-type? + 'exn-field + 'exn-type) + (cons f args))))) + (done (void)))]) + (apply f args))]) + (printf "~s~n BUT EXPECTED ERROR~n" v) + (record-error (list v 'Error (cons f args))))))]) + (let loop ([n 0][l '()]) + (unless (>= n min) + (do-test f l (make-ok? n)) + (loop (add1 n) (cons 1 l)))) + (let loop ([n min]) + (test #t procedure-arity-includes? f n) + (unless (>= n max) + (loop (add1 n)))) + (if (>= max 0) + (do-test f (let loop ([n 0][l '(1)]) + (if (= n max) + l + (loop (add1 n) (cons 1 l)))) + (make-ok? (add1 max))) + (test #t procedure-arity-includes? f (arithmetic-shift 1 100))))) + +(define (test-values l thunk) + (test l call-with-values thunk list)) + +(define (report-errs) + (printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n" + (+ number-of-tests number-of-error-tests) + number-of-tests + number-of-error-tests) + (printf "and ~a exception field tests.~n~n" + number-of-exn-tests) + (if (null? errs) + (display "Passed all tests.") + (begin + (display "Errors were:") + (newline) + (display "(SECTION (got expected (call)))") + (newline) + (for-each (lambda (l) (write l) (newline)) + errs))) + (newline) + (display "(Other messages report successful tests of error-handling behavior.)") + (newline)) + +(define type? exn:application:type?) +(define arity? exn:application:arity?) +(define syntaxe? exn:syntax?) + +(define non-z void) diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss new file mode 100644 index 00000000..c07850d3 --- /dev/null +++ b/collects/tests/mzscheme/thread.ss @@ -0,0 +1,369 @@ + + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'threads) + +(define SLEEP-TIME 0.1) + +(define t (thread (lambda () 8))) +(test #t thread? t) + +(arity-test thread 1 1) +(error-test '(thread 5) type?) +(error-test '(thread (lambda (x) 8)) type?) +(arity-test thread? 1 1) + +; Should be able to make an arbitrarily deep chain of custodians +; if only the first & last are accssible: +(test #t custodian? + (let loop ([n 1000][c (current-custodian)]) + (if (zero? n) + c + (loop (sub1 n) (make-custodian c))))) + +(define result 0) +(define th1 0) +(define set-ready + (let ([s (make-semaphore 1)] + [r #f]) + (lambda (v) + (semaphore-wait s) + (begin0 + r + (set! r v) + (semaphore-post s))))) +(define cm (make-custodian)) +(define th2 (parameterize ([current-custodian cm]) + (thread + (lambda () + (let ([cm2 (make-custodian cm)]) + (parameterize ([current-custodian cm2]) + (set! th1 (thread + (lambda () + (let loop () + (let ([r (set-ready #f)]) + (sleep SLEEP-TIME) + (set! result (add1 result)) + (when r (semaphore-post r))) + (loop))))))))))) +(define start result) +(let ([r (make-semaphore)]) + (set-ready r) + (semaphore-wait r)) +(test #f eq? start result) +(kill-thread th2) +(set! start result) +(let ([r (make-semaphore)]) + (set-ready r) + (semaphore-wait r)) +(test #f eq? start result) +(test #t thread-running? th1) +(custodian-shutdown-all cm) +(thread-wait th1) +(set! start result) +(test #f thread-running? th1) +(sleep SLEEP-TIME) +(test #t eq? start result) + +(let ([kept-going? #f]) + (let ([c (make-custodian)]) + (parameterize ([current-custodian c]) + (thread-wait + (thread + (lambda () + (custodian-shutdown-all c) + (set! kept-going? #t)))))) + (test #f 'kept-going-after-shutdown? kept-going?)) + +(error-test `(parameterize ([current-custodian cm]) (kill-thread (current-thread))) + exn:misc?) + +(test #t custodian? cm) +(test #f custodian? 1) +(arity-test custodian? 1 1) + +(arity-test custodian-shutdown-all 1 1) + +(arity-test make-custodian 0 1) +(error-test '(make-custodian 0)) + +(test (void) kill-thread t) +(arity-test kill-thread 1 1) +(error-test '(kill-thread 5) type?) + +(test #t thread-running? (current-thread)) +(arity-test thread-running? 1 1) +(error-test '(thread-running? 5) type?) + +(arity-test sleep 0 1) +(error-test '(sleep 'a) type?) +(error-test '(sleep 1+3i) type?) + +(define s (make-semaphore 1)) + +(test #t semaphore? s) + +(arity-test make-semaphore 0 1) +(error-test '(make-semaphore "a") type?) +(error-test '(make-semaphore -1) type?) +(error-test '(make-semaphore 1.0) type?) +(error-test '(make-semaphore (expt 2 64)) exn:application:mismatch?) +(arity-test semaphore? 1 1) + +(define test-block + (lambda (block? thunk) + (let* ([hit? #f] + [t (parameterize ([current-custodian (make-custodian)]) + (thread (lambda () (thunk) (set! hit? #t))))]) + (sleep SLEEP-TIME) + (begin0 (test block? 'nondeterministic-block-test (not hit?)) + (kill-thread t))))) + +(test #t semaphore-try-wait? s) +(test #f semaphore-try-wait? s) +(semaphore-post s) +(test #t semaphore-try-wait? s) +(test #f semaphore-try-wait? s) +(semaphore-post s) +(test-block #f (lambda () (semaphore-wait s))) +(test-block #t (lambda () (semaphore-wait s))) +(semaphore-post s) +(test-block #f (lambda () (semaphore-wait/enable-break s))) +(test-block #t (lambda () (semaphore-wait/enable-break s))) + +(arity-test semaphore-try-wait? 1 1) +(arity-test semaphore-wait 1 1) +(arity-test semaphore-post 1 1) + +(define s (make-semaphore)) +(define result 0) +(define t-loop + (lambda (n m) + (lambda () + (if (zero? n) + (begin + (set! result m) + (semaphore-post s)) + (thread (t-loop (sub1 n) (add1 m))))))) +(thread (t-loop 25 1)) +(semaphore-wait s) +(test 26 'thread-loop result) + +; Make sure you can break a semaphore-wait: +(test 'ok + 'break-semaphore-wait + (let* ([s1 (make-semaphore 0)] + [s2 (make-semaphore 0)] + [t (thread (lambda () + (semaphore-post s1) + (with-handlers ([exn:misc:user-break? (lambda (x) (semaphore-post s2))]) + (semaphore-wait (make-semaphore 0)))))]) + (semaphore-wait s1) + (sleep SLEEP-TIME) + (break-thread t) + (semaphore-wait s2) + 'ok)) + +; Make sure two waiters can be released +(test 'ok + 'double-semaphore-wait + (let* ([s1 (make-semaphore 0)] + [s2 (make-semaphore 0)] + [go (lambda () + (semaphore-post s2) + (semaphore-wait s1) + (semaphore-post s2))]) + (thread go) (thread go) + (semaphore-wait s2) (semaphore-wait s2) + (semaphore-post s1) (semaphore-post s1) + (semaphore-wait s2) (semaphore-wait s2) + 'ok)) + +; Tests inspired by a question from David Tillman +(define (read-line/expire1 port expiration) + (with-handlers ([exn:misc:user-break? (lambda (exn) #f)]) + (let ([timer (thread (let ([id (current-thread)]) + (lambda () + (sleep expiration) + (break-thread id))))]) + (dynamic-wind + void + (lambda () (read-line port)) + (lambda () (kill-thread timer)))))) +(define (read-line/expire2 port expiration) + (let ([done (make-semaphore 0)] + [result #f]) + (let ([t1 (thread (lambda () + (set! result (read-line port)) + (semaphore-post done)))] + [t2 (thread (lambda () + (sleep expiration) + (semaphore-post done)))]) + (semaphore-wait done) + (kill-thread t1) + (kill-thread t2) + result))) + +(define (go read-line/expire) + (define p (let ([c 0] + [nl-sleep? #f] + [nl? #f]) + (make-input-port (lambda () + (when nl-sleep? + (sleep 0.4) + (set! nl-sleep? #f)) + (if nl? + (begin + (set! nl? #f) + #\newline) + (begin + (set! nl? #t) + (set! nl-sleep? #t) + (set! c (add1 c)) + (integer->char c)))) + (lambda () + (when nl-sleep? + (sleep 0.4) + (set! nl-sleep? #f)) + #t) + void))) + (test #f read-line/expire p 0.2) ; should get char but not newline + (test "" read-line/expire p 0.6)) ; picks up newline + +(go read-line/expire1) +(go read-line/expire2) + +;; Make sure queueing works, and check kill/wait interaction: +(let* ([s (make-semaphore)] + [l null] + [wait (lambda (who) + (thread + (lambda () + (semaphore-wait s) + (set! l (cons who l)))))] + [pause (lambda () (sleep 0.01))]) + (wait 0) (pause) + (wait 1) (pause) + (wait 2) + (pause) + (test null 'queue l) + (semaphore-post s) (pause) + (test '(0) 'queue l) + (semaphore-post s) (pause) + (test '(1 0) 'queue l) + (semaphore-post s) (pause) + (test '(2 1 0) 'queue l) + + (set! l null) + (wait 0) (pause) + (let ([t (wait 1)]) + (pause) + (wait 2) + (pause) + (test null 'queue l) + (kill-thread t) + (semaphore-post s) (pause) + (test '(0) 'queue l) + (semaphore-post s) (pause) + (test '(2 0) 'queue l) + (semaphore-post s) (pause) + (test '(2 0) 'queue l) + (wait 3) (pause) + (test '(3 2 0) 'queue l))) + +;; Nested threads +(test 5 call-in-nested-thread (lambda () 5)) + +(error-test '(call-in-nested-thread (lambda () (kill-thread (current-thread)))) exn:thread?) +(error-test '(call-in-nested-thread (lambda () ((error-escape-handler)))) exn:thread?) +(error-test '(call-in-nested-thread (lambda () (raise (box 5)))) box?) + +(define c1 (make-custodian)) +(define c2 (make-custodian)) +(define c3 (make-custodian)) +(define output-stream null) +(define (output v) + (set! output-stream + (append output-stream (list v)))) +(define (test-stream v) + (test v 'output-stream output-stream)) + +(define (chain c) + (set! output-stream null) + + (output 'os) + (with-handlers ([void (lambda (x) x)]) + (call-in-nested-thread + (lambda () + (output 'ms) + (begin0 + (dynamic-wind + (lambda () (output 'mpre)) + (lambda () + (let ([t1 (current-thread)]) + (call-in-nested-thread + (lambda () + (output 'is) + (with-handlers ([void (lambda (x) + (if (exn:misc:user-break? x) + (output 'ibreak) + (output 'iother)) + (raise x))]) + (if (procedure? c) + (c t1) + (custodian-shutdown-all c))) + (output 'ie) + 'inner-result) + c2))) + (lambda () (output 'mpost))) + (output 'me))) + c1))) + +(test 'inner-result chain c3) +(test-stream '(os ms mpre is ie mpost me)) + +(test #t exn:thread? (chain c1)) +(test-stream '(os ms mpre is ibreak)) + +(parameterize ([break-enabled #f]) + (test #t exn:thread? (chain c1)) + (test-stream '(os ms mpre is ie))) + +(test #t exn:thread? (chain c2)) +(test-stream '(os ms mpre is mpost)) + +(test #t exn:thread? (chain (lambda (t1) (kill-thread (current-thread))))) +(test-stream '(os ms mpre is mpost)) + +(test #t exn:application? (chain 'wrong)) +(test-stream '(os ms mpre is iother mpost)) + +(test #t exn:misc:user-break? (chain (let ([t (current-thread)]) (lambda (t1) (break-thread t))))) +(test-stream '(os ms mpre is ibreak mpost)) + +(test #t exn:thread? (chain (lambda (t1) (kill-thread t1)))) +(test-stream '(os ms mpre is ibreak)) + +(parameterize ([break-enabled #f]) + (test #t exn:thread? (let ([t (current-thread)]) + (chain (lambda (t1) + (custodian-shutdown-all c1) + (test #t thread-running? (current-thread)) + (test #t thread-running? t) + (test #f thread-running? t1))))) + (test-stream '(os ms mpre is ie))) + +(error-test '(let/cc k (call-in-nested-thread (lambda () (k)))) exn:application:continuation?) +(error-test '(let/ec k (call-in-nested-thread (lambda () (k)))) exn:application:continuation?) +(error-test '((call-in-nested-thread (lambda () (let/cc k k)))) exn:application:continuation?) +(error-test '((call-in-nested-thread (lambda () (let/ec k k)))) exn:application:continuation?) + +(error-test '(call-in-nested-thread 5)) +(error-test '(call-in-nested-thread (lambda (x) 10))) +(error-test '(call-in-nested-thread (lambda () 10) 5)) + +(arity-test call-in-nested-thread 1 2) + +(report-errs) diff --git a/collects/tests/mzscheme/thrport.ss b/collects/tests/mzscheme/thrport.ss new file mode 100644 index 00000000..86d378ff --- /dev/null +++ b/collects/tests/mzscheme/thrport.ss @@ -0,0 +1,59 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'multi-threaded-ports) + +; Read from file with 3 threads, all writing to the same pipe +; read from pipe with 3 threads, all writing to the same output string +; compare resulting character content to the original file +(test 0 'threaded-ports + (let*-values ([(f-in) (open-input-file + (path->complete-path "testing.ss" + (current-load-relative-directory)))] + [(p-in p-out) (make-pipe)] + [(s-out) (open-output-string)] + [(in->out) (lambda (in out) + (lambda () + (let loop () + (let ([c (read-char in)] + [dummy (lambda () 'hi)]) + (unless (eof-object? c) + (write-char c out) + (loop))))))] + [(f->p) (in->out f-in p-out)] + [(p->s) (in->out p-in s-out)] + [(sthread) (lambda (thunk) + (let ([t (thread (lambda () (sleep) (thunk)))]) + (thread-weight t 101) + t))]) + (thread + (lambda () + (for-each thread-wait + (list (sthread f->p) + (sthread f->p) + (sthread f->p))) + (close-output-port p-out))) + (for-each thread-wait + (list (sthread p->s) + (sthread p->s) + (sthread p->s))) + (let ([s (get-output-string s-out)] + [hits (make-vector 256 0)]) + (for-each (lambda (c) + (let ([n (char->integer c)]) + (vector-set! hits n (add1 (vector-ref hits n))))) + (string->list s)) + (file-position f-in 0) + (let loop () + (let ([c (read-char f-in)]) + (unless (eof-object? c) + (let ([n (char->integer c)]) + (vector-set! hits n (sub1 (vector-ref hits n)))) + (loop)))) + (let loop ([i 0][total 0]) + (if (= i 256) + total + (loop (add1 i) (+ total (abs (vector-ref hits i))))))))) + +(report-errs) diff --git a/collects/tests/mzscheme/ttt/listlib.ss b/collects/tests/mzscheme/ttt/listlib.ss new file mode 100644 index 00000000..15221d58 --- /dev/null +++ b/collects/tests/mzscheme/ttt/listlib.ss @@ -0,0 +1,42 @@ +;; -------------------------------------------------------------------------- +;; list-library.ss +;; export: +;; collect: +;; (A ((cons B (listof B)) (listof B) (union A C) -> (union A C)) +;; -> +;; ((listof B) -> (union A C))) + +; #| +; (unit/sig +; (collect filter set-minus subset?) +; (import plt:userspace^) +; |# + + (define collect + (lambda (base combine) + (letrec ([C + (lambda (l) + (cond + ((null? l) base) + (else (combine l (car l) (C (cdr l))))))]) + C))) + + (define filter + (lambda (p? l) + [(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l])) + + ;; set library + (define set-minus + (lambda (set1 set2) + [(collect null (lambda (_ e1 rest) (if (member e1 set2) rest (cons e1 rest)))) + set1])) + + (define subset? + (lambda (state1 state2) + (cond + ((null? state1) #t) + (else (and (member (car state1) state2) + (subset? (cdr state1) state2)))))) +; #| +; ) +; |# diff --git a/collects/tests/mzscheme/ttt/tic-bang.ss b/collects/tests/mzscheme/ttt/tic-bang.ss new file mode 100644 index 00000000..85422cdc --- /dev/null +++ b/collects/tests/mzscheme/ttt/tic-bang.ss @@ -0,0 +1,123 @@ +;; -------------------------------------------------------------------------- +;; tic-bang.ss +;; This is an imperative version. + +;; This program plays through all possibilities of a tic-tac-toe +;; game, given the first move of a player. It only prints how many +;; states are being processed and how many states are terminal at +;; each stage of the game. + +;; This program lacks the capability to print how a situation arose. + +;; It relies on list-library.ss. + +;; representations of fields, states, and collections of states +(define BLANK 0) + +(define new-state + (lambda () + (make-2vec 3 BLANK))) + +(define update-state + (lambda (state x y token) + (2vec-set! state x y token) + state)) + +(define blank? + (lambda (astate i j) + (eq? (2vec-ref astate i j) BLANK))) + +(define clone-state + (lambda (state) + (let ((s (new-state))) + (let loop ((i 0) (j 0)) + (cond + ((and (= i 3) (= j 0)) (void)) + ((< j 3) (update-state s i j (2vec-ref state i j)) (loop i (+ j 1))) + ((< i 3) (loop (+ i 1) 0)) + (else 'bad))) + s))) + +;(define-type state (2vector (union 'x 'o '_))) +;(define-type states (listof state)) + +(define PLAYER 1) +(define OPPONENT 2) + +(define tic-tac-toe + (lambda (x y) + (tic (list (update-state (new-state) (- x 1) (- y 1) PLAYER))))) + +(define make-move + (lambda (other-move p/o tag) + (lambda (states) + (printf "~s: processing ~s states ~n" tag (length states)) + (let ((t (print&remove-terminals states))) + (printf "terminal states removed: ~s~n" + (- (length states) (length t))) + (if (null? t) + (void) + (other-move (apply append (map p/o t)))))))) + +(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) + +(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) + +(define make-players + (lambda (p/o) + (lambda (astate) + (let loop ((i 0) (j 0)) + (cond + ((and (= i 3) (= j 0)) null) + ((< j 3) (if (blank? astate i j) + (cons (update-state (clone-state astate) i j p/o) + (loop i (+ j 1))) + (loop i (+ j 1)))) + ((< i 3) (loop (+ i 1) 0)) + (else (error 'make-player "ouch"))))))) + +(define player (make-players PLAYER)) + +(define opponent (make-players OPPONENT)) + +(define print&remove-terminals + (local ((define print-state + (lambda (x) + ;(display ".") + (void)))) + + (collect null (lambda (_ astate rest) + (if (terminal? astate) + (begin (print-state astate) rest) + (cons astate rest)))))) + +(define terminal? + (lambda (astate) + (or (terminal-row 0 astate) + (terminal-row 1 astate) + (terminal-row 2 astate) + (terminal-col 0 astate) + (terminal-col 1 astate) + (terminal-col 2 astate) + (terminal-posdg astate) + (terminal-negdg astate)))) + +(define terminal-row + (lambda (n state) + (and (not (blank? state n 0)) + (= (2vec-ref state n 0) (2vec-ref state n 1) (2vec-ref state n 2))))) + +(define terminal-col + (lambda (n state) + (and (not (blank? state 0 n)) + (= (2vec-ref state 0 n) (2vec-ref state 1 n) (2vec-ref state 2 n))))) + +(define terminal-posdg + (lambda (state) + (and (not (blank? state 0 0)) + (= (2vec-ref state 0 0) (2vec-ref state 1 1) (2vec-ref state 2 2))))) + +(define terminal-negdg + (lambda (state) + (and (not (blank? state 0 2)) + (= (2vec-ref state 0 2) (2vec-ref state 1 1) (2vec-ref state 2 0))))) diff --git a/collects/tests/mzscheme/ttt/tic-func.ss b/collects/tests/mzscheme/ttt/tic-func.ss new file mode 100644 index 00000000..538d4569 --- /dev/null +++ b/collects/tests/mzscheme/ttt/tic-func.ss @@ -0,0 +1,120 @@ +;; -------------------------------------------------------------------------- +;; tic-func.ss +;; This program plays through all possibilities of a tic-tac-toe +;; game, given the first move of a player. It only prints how many +;; states are being processed and how many states are terminal at +;; each stage of the game. But it is constructed so that it can +;; print how to get to a winning terminal state. + +;; It relies on list-library.ss. + +;; representations of fields, states, and collections of states +(define null '()) +(define-structure (entry x y who)) +(define entry-field + (lambda (an-entry) + (list (entry-x an-entry) (entry-y an-entry)))) +;(define-type state (listof (structure:entry num num (union 'x 'o))) +;(define-type states (listof state)) + +(define PLAYER 'x) +(define OPPONENT 'o) + +(define tic-tac-toe + (lambda (x y) + (tic (list (list (make-entry x y PLAYER)))))) + +(define make-move + (lambda (other-move p/o tag) + (lambda (states) + (printf "~s: processing ~s states of length ~s ~n" + tag (length states) (length (car states))) + (let ((t (print&remove-terminals states))) + (printf "terminal states removed: ~s~n" + (- (length states) (length t))) + (if (null? t) + (void) + (other-move (apply append (map p/o t)))))))) + +(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) + +(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) + +(define make-players + (let () + (define rest-of-fields + (lambda (used-fields) + (set-minus ALL-FIELDS used-fields))) + (lambda (player/opponent) + (lambda (astate) + (map (lambda (counter-move) + (let ((counter-x (car counter-move)) + (counter-y (cadr counter-move))) + (cons (make-entry counter-x counter-y player/opponent) + astate))) + (rest-of-fields (map entry-field astate))))))) + +(define player (make-players PLAYER)) + +(define opponent (make-players OPPONENT)) + +(define terminal? + (let () (define filter-p/o + (lambda (p/o astate) + (map entry-field + (filter (lambda (x) (eq? (entry-who x) p/o)) astate)))) + (lambda (astate) + (and (>= (length astate) 5) + (let ((PLAYERf (filter-p/o PLAYER astate)) + (OPPONENTf (filter-p/o OPPONENT astate))) + (or + (= (length astate) 9) + (ormap (lambda (ts) (subset? ts PLAYERf)) TERMINAL-STATES) + (ormap (lambda (ts) (subset? ts OPPONENTf)) TERMINAL-STATES))))))) + +(define print&remove-terminals + (let () + + (define print-state1 + (lambda (x) + (display x) + (newline))) + + (define print-state2 + (lambda (astate) + (cond + ((null? astate) (printf "------------~n")) + (else (print-state (cdr astate)) + (let ((x (car astate))) + (printf " ~s @ (~s,~s) ~n" + (entry-who x) (entry-x x) (entry-y x))))))) + + (define print-state + (lambda (x) + ;(display ".") + (void))) + + (collect null (lambda (_ astate rest) + (if (terminal? astate) + (begin (print-state astate) rest) + (cons astate rest)))))) +;; fields +(define T + (lambda (alof) + (cond + ((null? alof) null) + (else (cons (list (cadr (car alof)) (car (car alof))) + (T (cdr alof))))))) + +(define row1 (list (list 1 1) (list 1 2) (list 1 3))) +(define row2 (list (list 2 1) (list 2 2) (list 2 3))) +(define row3 (list (list 3 1) (list 3 2) (list 3 3))) +(define col1 (list (list 1 1) (list 2 1) (list 3 1))) +(define col2 (list (list 1 2) (list 2 2) (list 3 2))) +(define col3 (list (list 1 3) (list 2 3) (list 3 3))) +(define posd (list (list 1 1) (list 2 2) (list 3 3))) +(define negd (list (list 1 3) (list 2 2) (list 3 1))) + +(define TERMINAL-STATES (list row1 row2 row3 col1 col2 col3 posd negd)) + +(define ALL-FIELDS (append row1 row2 row3)) diff --git a/collects/tests/mzscheme/ttt/ttt.ss b/collects/tests/mzscheme/ttt/ttt.ss new file mode 100644 index 00000000..67a1898f --- /dev/null +++ b/collects/tests/mzscheme/ttt/ttt.ss @@ -0,0 +1,14 @@ + +(read-case-sensitive #t) +(require-library "core.ss") +(load "listlib.ss") +(load "veclib.ss") +(load "tic-func.ss") + +(let loop () + (collect-garbage) + (collect-garbage) + (collect-garbage) + (dump-memory-stats) + (time (tic-tac-toe 1 1)) + '(loop)) diff --git a/collects/tests/mzscheme/ttt/uinc4.ss b/collects/tests/mzscheme/ttt/uinc4.ss new file mode 100644 index 00000000..31cef748 --- /dev/null +++ b/collects/tests/mzscheme/ttt/uinc4.ss @@ -0,0 +1,7 @@ + + +(define also-unused 'ok) + +(begin-elaboration-time + `(include ,(build-path 'up "uinc.ss"))) + diff --git a/collects/tests/mzscheme/ttt/veclib.ss b/collects/tests/mzscheme/ttt/veclib.ss new file mode 100644 index 00000000..d840f099 --- /dev/null +++ b/collects/tests/mzscheme/ttt/veclib.ss @@ -0,0 +1,57 @@ +;; -------------------------------------------------------------------------- +;; 2vec-library.ss + +; #| +; (unit/sig +; (make-2vec 2vec-ref 2vec-set! collect) +; (import plt:userspace^) +; |# + + ;; 2 dimensional, square vectors + + (define collect + (lambda (base combine) + (define C + (lambda (l) + (cond + ((null? l) base) + (else (combine l (car l) (C (cdr l))))))) + C)) + + (define (make-2vec N element) + (make-vector (* N N) element)) + + (define (2vec-ref 2vec i j) + (let ((L (sqrt (vector-length 2vec)))) + (vector-ref 2vec (+ (* i L) j)))) + + (define (2vec-set! 2vec i j element) + (let ((L (sqrt (vector-length 2vec)))) + (if (and (< i L) (< j L)) + (vector-set! 2vec (+ (* i L) j) element) + (error '2vec-set! "~s ~s" i j)))) + + (define (I N) + (let ((2vec (make-2vec N 0))) + (let loop ((i 0) (j 0)) + (if (= i N) + (void) + (begin + (2vec-set! 2vec i j 1) + (loop (add1 i) (add1 j))))) + 2vec)) + + (define (P N) + (let ((2vec (make-2vec N 0))) + (let loop ((i 0) (j 0)) + (cond + [(and (= i N) (= j 0)) (void)] + [(< j N) (2vec-set! 2vec i j (list i j)) (loop i (add1 j))] + [(< i N) (loop (add1 i) 0)] + [else (error 'P "impossible ~s ~s" i j)])) + 2vec)) + +; #| +; ) +; |# + diff --git a/collects/tests/mzscheme/uinc.ss b/collects/tests/mzscheme/uinc.ss new file mode 100644 index 00000000..ea489aaa --- /dev/null +++ b/collects/tests/mzscheme/uinc.ss @@ -0,0 +1,2 @@ + +(+ 4 5) diff --git a/collects/tests/mzscheme/uinc2.ss b/collects/tests/mzscheme/uinc2.ss new file mode 100644 index 00000000..c1de73fb --- /dev/null +++ b/collects/tests/mzscheme/uinc2.ss @@ -0,0 +1,2 @@ + +(define x 8) diff --git a/collects/tests/mzscheme/uinc3.ss b/collects/tests/mzscheme/uinc3.ss new file mode 100644 index 00000000..822a984d --- /dev/null +++ b/collects/tests/mzscheme/uinc3.ss @@ -0,0 +1,6 @@ + +(define unused 'hello) + +(begin-elaboration-time + `(include ,(build-path "ttt" "uinc4.ss"))) + diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss new file mode 100644 index 00000000..1dd3b8d6 --- /dev/null +++ b/collects/tests/mzscheme/unit.ss @@ -0,0 +1,524 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'unit) + +(syntax-test '(unit)) +(syntax-test '(unit (import))) +(syntax-test '(unit (impLort))) +(syntax-test '(unit (impLort) (export) 5)) +(syntax-test '(unit (import) (expLort) 5)) +(syntax-test '(unit import (export) 5)) +(syntax-test '(unit (import) export 5)) +(syntax-test '(unit (import) (export) . 5)) +(syntax-test '(unit (import 8) (export) 5)) +(syntax-test '(unit (import . i) (export) 5)) +(syntax-test '(unit (import (i)) (export) 5)) +(syntax-test '(unit (import i 8) (export) 5)) +(syntax-test '(unit (import i . b) (export) 5)) +(syntax-test '(unit (import i (b)) (export) 5)) +(syntax-test '(unit (import i) (export 7) 5)) +(syntax-test '(unit (import i) (export . a) (define a 6))) +(syntax-test '(unit (import i) (export a . b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) . b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a 8) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a 8)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a . x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a . x)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x y) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x . y) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export b (a x . y)) (define a 5) (define b 6))) + +(syntax-test '(unit (import i) (export) (begin 1 . 2))) +(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6) . x))) +(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6)) (define b 6))) + +(syntax-test '(unit (import #%car) (export) (define a 5))) +(syntax-test '(unit (import) (export #%car) (define a 5))) +(syntax-test '(unit (import) (export #%car) (define #%car 5))) +(syntax-test '(unit (import) (export) (define #%car 5))) +(syntax-test '(unit (import) (export) (define-values (3) 5))) + +(syntax-test '(unit (import a) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import a) (export (a x) (a y)) (define a 5) (define b 6))) +(syntax-test '(unit (import i a) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import b) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i j i) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i j j) (export (a x) b) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export a a) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) (b x)) (define a 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define a 6) (define b 6))) +(syntax-test '(unit (import make-i) (export (a x) b) (define a 5) (define-struct i ()) (define b 6))) +(syntax-test '(unit (import i) (export (make-a x) b) (define make-a 5) (define-struct a ()) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define r 6) (define r 7) (define b 6))) + +(syntax-test '(unit (import i) (export b (a x)) 5)) +(syntax-test '(unit (import i) (export (a x) b) (define x 5) (define b 6))) +(syntax-test '(unit (import i) (export (a x) b) (set! a 5) (define b 6))) + +(syntax-test '(unit (import i) (export) (set! g 5))) +(syntax-test '(unit (import i) (export) (set! i 5))) + +; Empty exports are syntactically ok:: +(error-test '(compound-unit (import) (link (A (0))) (export (A))) exn:unit?) +(error-test '(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:unit?) +(error-test '(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:unit?) + +; Self-import is now allowed +; (syntax-test '(compound-unit (import) (link (A (0 (A)))) (export))) +; (syntax-test '(compound-unit (import) (link (A (0 (A x)))) (export))) +(test (list (letrec ([x x]) x) 5) + 'self-import + (invoke-unit + (compound-unit + (import) + (link [U ((unit (import a) (export b) (define x a) (define b 5) (list x a)) + (U b))]) + (export)))) + +(error-test '(invoke-unit (unit (import not-defined) (export) 10) not-defined) exn:unit?) + +(unless (defined? 'test-global-var) + (let () + (define test-global-var 5) + (syntax-test '(unit (import) (export) test-global-var)))) + +(test #t unit? (unit (import) (export))) +(test #t unit? (unit (import) (export) 5)) +(test #t unit? (unit (import i) (export (a x)) (define a 8) (define x 5))) +(test 5 (lambda (f) (invoke-unit f)) (unit (import) (export) 5)) + +(test #t unit? (unit (import i) (export b a) (begin (define a 5) (define b 6)))) +(test #t unit? (unit (import i) (export b a) 'a (begin (define a 5) (define b 6)) 'b)) +(test #t unit? (unit (import i) (export b a) (begin (define a 5)) (define b 6))) +(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define b 6)))) +(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define y 7) (define b 6)) (+ y b a))) + +(test 3 'embedded-deeply ((invoke-unit (unit (import) (export) (lambda () (define x 3) x))))) +(test 1 'embedded-deeply-struct ((invoke-unit (unit (import) (export) (lambda () + (define-struct a ()) + make-a + 1))))) + +; Empty begin is OK in a unit context: +(test #t unit? (unit (import i) (export) (begin))) +(test #t unit? (unit (import i) (export) (begin (begin)))) + +(syntax-test '(compound-unit)) +(syntax-test '(compound-unit . x)) +(syntax-test '(compound-unit (import))) +(syntax-test '(compound-unit (import) . x)) +(syntax-test '(compound-unit (import) (link))) +(syntax-test '(compound-unit (import) (link) . x)) +(syntax-test '(compound-unit import (link) (export))) +(syntax-test '(compound-unit (import) link (export))) +(syntax-test '(compound-unit (import) (link) export)) +(syntax-test '(compound-unit ((import)) (link) (export))) +(syntax-test '(compound-unit (import) ((link)) (export))) +(syntax-test '(compound-unit (import) (link) ((export)))) +(syntax-test '(compound-unit (import . a) (link) (export))) +(syntax-test '(compound-unit (import b . a) (link) (export))) +(syntax-test '(compound-unit (import 1) (link) (export))) +(syntax-test '(compound-unit (import (a)) (link) (export))) +(syntax-test '(compound-unit (import (a . b)) (link) (export))) +(syntax-test '(compound-unit (import (a (b))) (link) (export))) +(syntax-test '(compound-unit (import ((a) b)) (link) (export))) +(syntax-test '(compound-unit (import) (link . a) (export))) +(syntax-test '(compound-unit (import) (link a) (export))) +(syntax-test '(compound-unit (import) (link (a)) (export))) +(syntax-test '(compound-unit (import) (link (a (b)) . c) (export))) +(syntax-test '(compound-unit (import) (link (a (b) . c)) (export))) +(syntax-test '(compound-unit (import) (link (a (b . c)) (c (d))) (export))) +(syntax-test '(compound-unit (import) (link (a (b c . e)) (c (d)) (e (f))) (export))) +(syntax-test '(compound-unit (import) (link (a (b 1))) (export))) +(syntax-test '(compound-unit (import) (link (a (b))) (export . a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a w) . a))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a 1)))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (a (x))))) +(syntax-test '(compound-unit (import) (link (a (b))) (export (1 w)))) + + +; Simple: + +(define m1 + (unit + (import) + (export x y a? set-a-b!) + + (define-struct a (b c)) + + (define x 7) + (define z 8) + (define y (lambda () (* z x))) + + (list x y z))) + +(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) + (invoke-unit m1)) + +(test #t apply + (lambda (x y-val a? set-a-b!) + (and (= x 7) (= y-val 56) + (= 1 (arity a?)) + (= 2 (arity set-a-b!)))) + (invoke-unit + (compound-unit + (import) + (link [M (m1)] + [N ((unit + (import x y a? set-a-b!) + (export) + (list x (y) a? set-a-b!)) + (M x y a? set-a-b!))]) + (export)))) + +; Structures: + + +(define m2-1 + (unit + (import) + (export x struct:a a? v y) + + (define x 5) + (define-struct a (b c)) + (define v (make-a 5 6)) + (define (y v) (a? v)))) + +(define m2-2 + (unit + (import struct:a a?) + (export x? make-x x-z both) + + (define-struct (x struct:a) (y z)) + (define both (lambda (v) + (and (a? v) (x? v)))))) + +(define m2-3 + (compound-unit + (import) + (link [O (m2-1)][T (m2-2 (O struct:a) (O a?))]) + (export [O x struct:a v y] + [T x? make-x x-z both]))) + + +(let ([p (open-output-string)]) + (invoke-unit + (compound-unit + (import) + (link [M (m2-3)] + [N ((unit + (import x v struct:a y x? make-x x-z both) + (export) + (define (filter v) + (if (procedure? v) + `(proc: ,(inferred-name v)) + v)) + (display + (map filter (list x v struct:a y make-x x? x-z both)) + p) + (let ([v2 (make-x 1 2 3 4)]) + (display (map filter + (list x (struct-type? struct:a) + v (y v) (y x) + v2 + (y v2) + (x? v2) + (both v) + (both v2))) + p))) + (M x v struct:a y x? make-x x-z both))]) + (export))) + + (test (string-append "(5 #(struct:a 5 6) # (proc: y)" + " (proc: make-x) (proc: x?)" + " (proc: x-z) (proc: both))" + "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") + get-output-string p)) + +; Compound with circularity + +(define make-z + (lambda (x-val) + (unit + (import z) + (export (x z) y) + + (define x x-val) + (define y (lambda () (- z x)))))) + +(define z1 (make-z 8)) +(define z2 (make-z 7)) + +; Dynamic linking + +(let ([u + (unit + (import x) + (export) + + (+ x 8))]) + + (test 10 'dynamic (invoke-unit + (unit + (import) + (export w) + + (define w 2) + + (invoke-unit u w))))) + +; Misc + +(test 12 'nested-units + (invoke-unit + (compound-unit + (import) + (link (a@ ((unit (import) (export s@:a) (define s@:a 5)))) + (u@ ((compound-unit + (import a@:s@:a) + (link (r@ ((unit (import a) (export) (+ a 7)) a@:s@:a))) + (export)) + (a@ s@:a)))) + (export)))) + +; Import linking via invoke-unit + +(test '(5 7 (7 2)) 'invoke-unit-linking + (let ([u (unit (import x) (export) x)] + [v (unit (import x) (export) (lambda () x))] + [x 5]) + (list (invoke-unit u x) + (begin + (set! x 7) + (invoke-unit u x)) + (let ([f (invoke-unit v x)]) + (list + (f) + (begin + (set! x 2) + (f))))))) + + +; Multiple values +(test '(1 2 3) + call-with-values + (lambda () (invoke-unit (unit (import) (export) (values 1 2 3)))) + list) + +; Units within units: + +(define u (unit + (import) + (export) + (define y 10) + (define x 5) + (unit + (import) + (export) + x))) +(test #t unit? u) +(define u2 (invoke-unit u)) +(test #t unit? u2) +(test 5 'invoke-unit-in-unit (invoke-unit u2)) + + +(syntax-test '(define u + (invoke-unit + (unit + (import) (export) + (define x 10) + x + (unit (import) (export) + apple + x))))) + +; Units and objects combined: + +(define u@ + (unit (import x) (export) + (class* object% () () + (public (y x)) + (sequence (super-init))))) +(define v (invoke-unit u@ car)) +(test #t class? v) +(define w (make-object v)) +(test car 'ivar (ivar w y)) + +(define c% + (class* object% () (x) + (public (z (unit (import) (export) x))) + (sequence (super-init)))) +(define u (ivar (make-object c% car) z)) +(test #t unit? u) +(test car 'invoke (invoke-unit u)) + + +(define c% + (class* object% () (x) (public (y x)) + (public (z (unit (import) (export) y))) + (sequence (super-init)))) +(define u (make-object c% 3)) +(define u2 (ivar u z)) +(test #t unit? u2) +(test 3 'invoke (invoke-unit u2)) + +(test (letrec ([x y][y 0]) x) 'invoke + (invoke-unit (unit (import) (export) (define x y) (define y 7) x))) + +; Can't shadow syntax/macros in unit +(syntax-test '(unit + (import) + (export) + (define define 10))) +(syntax-test '(unit + (import) + (export) + (define lambda 10))) + +; Shadowing ok if it's in the export list: +(test #t unit? (unit + (import) + (export define-values) + (define define-values 10))) +(test #t unit? (unit + (import) + (export lambda) + (define lambda 10))) +(test #t unit? (unit + (import) + (export [lambda l]) + (define lambda 10))) + +; These are ok, too: +(test #t unit? (unit + (import define) + (export) + (define define 10))) +(test #t unit? (let ([define-values 5]) + (unit + (import) + (export) + (define define-values 10)))) +(test 10 'invoke-w/shadowed + (let ([define-values 5]) + (invoke-unit + (unit + (import) + (export define-values) + (define define-values 10) + define-values)))) + +; Especially for zodiac: +(test '(b c 10 b a (c a b) (c b a) (c . c) (a) #t + (nested-b a b c) (a 2 b) (10 b c) (cl-unit-a 12 c)) + 'invoke-w/shadowed-a-lot + (let ([a 'bad-a] + [b 'bad-b] + [c 'bad-c] + [struct:d 'bad-d] + [i 'bad-i]) + (invoke-unit + (unit + (import) + (export b) + (define a 'a) + (define b 'tmp-b) + (begin + (define c 'c) + (define-struct d (w))) + (define x '...) + + (define-struct (e struct:d) ()) + (set! b 'b) + (set! x (cons c c)) + + (define i (interface ())) + + (list + (if (eq? a 'a) + b + c) + (if (eq? a 'bad-a) + b + c) + (d-w (make-e 10)) + (begin a b) + (begin0 a b) + (let ([ab (list a b)]) + (cons c ab)) + (letrec ([mk-ba (lambda () + (list b a))]) + (cons c (mk-ba))) + x + (with-continuation-mark + b a + (continuation-mark-set->list (current-continuation-marks) b)) + (interface? (interface (i))) + (invoke-unit + (unit + (import w a) + (export) + (define b 'nested-b) + (list b w a c)) + a b) + (invoke-unit + (compound-unit + (import a) + (link [u ((unit (import c) (export (xa a) (b xb)) + (define xa 1) + (define b 2) + (list a b c)) + a)]) + (export)) + b) + (send + (make-object + (class object% () + (public + [a 10] + [tester + (lambda () (list a b c))]) + (sequence (super-init)))) + tester) + (send + (make-object + (class object% () + (public + [a 10] + [b 12] + [tester + (lambda () + (invoke-unit + (unit + (import) + (export) + (define a 'cl-unit-a) + (list a b c))))]) + (sequence (super-init)))) + tester)))))) + +; Not ok if defining an imported name, but error should be about +; redefining an imported name. (This behavior is not actually tested.) +(syntax-test '(unit + (import define-values) + (export) + (define define-values 10))) + +(test #t unit? (unit + (import define-values) + (export) + (let () (define define-values 10) define-values))) + +;; Invoke-unit linking in let-bound variables +(test '(the-x 10) 'invoke + (let ([x 'the-x]) + (invoke-unit + (unit (import w) (export) + (list w 10)) + x))) + + +(report-errs) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss new file mode 100644 index 00000000..fe571eae --- /dev/null +++ b/collects/tests/mzscheme/unitsig.ss @@ -0,0 +1,502 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'unit/sig) + +(undefine 'a) +(undefine 'b) + +(syntax-test '(define-signature)) +(syntax-test '(define-signature)) +(syntax-test '(define-signature 8)) +(syntax-test '(define-signature . x)) +(syntax-test '(define-signature x)) +(syntax-test '(define-signature 8)) +(syntax-test '(define-signature x (8))) +(syntax-test '(define-signature x (a . 8))) +(syntax-test '(define-signature x (a . y))) +(syntax-test '(define-signature x (y y))) +(syntax-test '(define-signature x ((y)))) +(syntax-test '(define-signature x ((struct)))) +(syntax-test '(define-signature x ((struct y)))) +(syntax-test '(define-signature x ((struct . y)))) +(syntax-test '(define-signature x ((struct y . x)))) +(syntax-test '(define-signature x ((struct y x)))) +(syntax-test '(define-signature x ((struct y (x)) . x))) +(syntax-test '(define-signature x ((unit)))) +(syntax-test '(define-signature x ((unit y)))) +(syntax-test '(define-signature x ((unit . y)))) +(syntax-test '(define-signature x ((unit y : a)))) +(define-signature a ()) +(syntax-test '(define-signature x ((unit y a)))) +(syntax-test '(define-signature x ((unit y . a)))) +(syntax-test '(define-signature x ((unit y : . a)))) +(syntax-test '(define-signature x ((unit y a) . x))) +(syntax-test '(define-signature x (y (unit y a)))) + +(syntax-test '(unit/sig)) +(syntax-test '(unit/sig 8)) +(syntax-test '(unit/sig b)) +(define-signature b (x y)) +(syntax-test '(unit/sig (a))) +(syntax-test '(unit/sig a (impLort))) +(syntax-test '(unit/sig a (impLort) 5)) +(syntax-test '(unit/sig a import 5)) +(syntax-test '(unit/sig a (import . x) . 5)) +(syntax-test '(unit/sig a (import (x) 8) 5)) +(syntax-test '(unit/sig a (import (x) . i) 5)) +(syntax-test '(unit/sig a (import (i : a) . b) 5)) +(syntax-test '(unit/sig b (import (i : a)) 5)) +(syntax-test '(unit/sig a (import (i : a x)) 5)) +(syntax-test '(unit/sig a (import (i : a) x) 5)) +(syntax-test '(unit/sig b (import (i : a)) (define x 7))) +(syntax-test '(unit/sig b (import (i : a)) (define x 7) (define i:y 6))) +(syntax-test '(unit/sig blah (import) (define x 7))) + +(syntax-test '(unit/sig () (import) (begin 1 . 2))) +(syntax-test '(unit/sig () (import) (begin (define x 5)) (define x 5))) + +(define b@ (unit/sig b (import) (define x 9) (define y 9))) +(define b2@ (unit/sig b (import (i : a)) (define x 9) (define y 9))) +(define b3@ (unit/sig b (import (i : ())) (define x 9) (define y 9))) +(define b3u@ (unit/sig b (import ()) (define x 9) (define y 9))) +(define b3u2@ (unit/sig b (import a) (define x 9) (define y 9))) +(define-signature >b ((unit b@ : b))) +(define b3u3@ (unit/sig b (import (i : >b)) (define x 9) (define y 9))) + +(define >b@ (compound-unit/sig (import) (link [b@ : b (b@)]) (export (unit b@)))) + +(syntax-test '(compound-unit/sig)) +(syntax-test '(compound-unit/sig 8)) +(syntax-test '(compound-unit/sig b)) +(syntax-test '(compound-unit/sig (import) (link) (export (var (U x))))) +(syntax-test '(compound-unit/sig (import a) (link) (export))) +(syntax-test '(compound-unit/sig (import 5) (link) (export))) +(syntax-test '(compound-unit/sig (import . i) (link) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link ()) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ b)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b)) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open)))) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(error-test '(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) +(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 5)]) (export))) +(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 ())]) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@)))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5))))) +(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a))))) + +; Self-import is now allowed +; (syntax-test '(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import +; (syntax-test '(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import +(test (list (letrec ([x x]) x) 5) + 'self-import + (invoke-unit/sig + (compound-unit/sig + (import) + (link [U : (a) ((unit/sig (a) (import (a)) (rename (b a)) (define x a) (define b 5) (list x a)) + U)]) + (export)))) + +(define-signature not-defined^ (not-defined)) +(error-test '(invoke-unit/sig (unit/sig () (import not-defined^) 10) not-defined^) exn:unit?) + +(test #t unit/sig? (unit/sig a (import))) +(test #t unit/sig? (unit/sig b (import) (define x 1) (define y 2))) +(test #t unit/sig? (unit/sig a (import (i : b)) i:x)) +(test 5 (lambda (f) (invoke-unit/sig f ())) (unit/sig a (import ()) 5)) +(test #t unit/sig? (unit/sig (x) (import) (begin (define x 5)))) +(test #t unit/sig? (unit/sig (x) (import) (define a 14) (begin (define x 5) (define y 10)) (define z 12))) +(test #t unit/sig? (compound-unit/sig (import) (link) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ (i : a)))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : a)))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : ())))) (export))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x))))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x) w)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@) x) w)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit (b@))))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open b@)))) +(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open (b@ : b))))) + +(test #t unit/sig? (compound-unit/sig (import) + (link [compound-unit : () ((unit/sig () (import) 10))]) + (export))) +(test #t unit/sig? (compound-unit/sig + (import) + (link [export : () ((unit/sig () (import) 10))]) + (export))) + +; Empty begin is OK in a unit context: +(test #t unit/sig? (unit/sig () (import) (begin))) +(test #t unit/sig? (unit/sig () (import) (begin (begin)))) + +; Include: + +(define i1@ + (unit/sig + () + (import) + + (include "uinc.ss"))) + +(test 9 'include (invoke-unit/sig i1@)) + +;; Nested includes, macros that expand to `(include ...)' +(define i1.5@ + (unit/sig + () + (import) + + (+ 3 4) + (include "uinc3.ss"))) + +(test 9 'include (invoke-unit/sig i1.5@)) + +(define i2@ + (unit/sig + () + (import) + + (include "uinc.ss") + (include "uinc2.ss") + (include "uinc.ss") + (+ x 2))) + +(test 10 'include (invoke-unit/sig i2@)) + +; Simple: + +(define-signature m1^ + (x y a? set-a-b!)) + +(define m1@ + (unit/sig + m1^ + (import) + + (define-struct a (b c)) + + (define x 7) + (define z 8) + (define y (lambda () (* z x))) + + (list x y z))) + +(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) + (invoke-unit/sig m1@)) + +(test #t apply + (lambda (x y-val a? set-a-b!) + (and (= x 7) (= y-val 56) + (= 1 (arity a?)) + (= 2 (arity set-a-b!)))) + (invoke-unit/sig + (compound-unit/sig + (import) + (link [M@ : m1^ (m1@)] + [N@ : () ((unit/sig + () + (import (i@ : m1^)) + (list i@:x (i@:y) i@:a? i@:set-a-b!)) + M@)]) + (export (open M@))))) + +; More: + +(define-signature m2-1-lite^ + (x struct:a v y)) + +(define-signature m2-1^ + (a? + (open m2-1-lite^))) + +(define-signature m2-2^ + (x? make-x x-z both)) + +(define m2-1@ + (unit/sig + m2-1^ + (import) + + (define x 5) + (define-struct a (b c)) + (define v (make-a 5 6)) + (define (y v) (a? v)))) + +(define m2-2@ + (unit/sig + m2-2^ + (import m2-1^) + + (define-struct (x struct:a) (y z)) + (define both (lambda (v) + (and (a? v) (x? v)))))) + +(define-signature m2-3^ + (simple)) + +(let-signature m2-3^ + ((unit one@ : m2-1-lite^) + (unit two@ : m2-2^) + a?-again) + + (define m2-3@ + (compound-unit/sig + (import) + (link [O@ : m2-1^ (m2-1@)] + [T@ : m2-2^ (m2-2@ O@)]) + (export (unit (O@ : m2-1-lite^) one@) + (unit T@ two@) + (var (O@ a?) a?-again)))) + + (let ([p (open-output-string)] + [filter (lambda (v) + (if (procedure? v) + `(proc: ,(inferred-name v)) + v))]) + (invoke-unit/sig + (compound-unit/sig + (import) + (link [M@ : m2-3^ (m2-3@)] + [N@ : () ((unit/sig + () + (import (i : m2-3^)) + (display (map + filter + (list i:one@:x i:one@:v i:one@:struct:a i:one@:y + i:two@:make-x i:two@:x? i:two@:x-z i:two@:both + i:a?-again)) + p) + (let ([v2 (i:two@:make-x 1 2 3 4)]) + (display (map + filter + (list i:one@:x (struct-type? i:one@:struct:a) + i:one@:v (i:one@:y i:one@:v) (i:one@:y i:one@:x) + v2 + (i:one@:y v2) + (i:two@:x? v2) + (i:two@:both i:one@:v) + (i:two@:both v2))) + p))) + M@)]) + (export))) + (test (string-append "(5 #(struct:a 5 6) # (proc: y)" + " (proc: make-x) (proc: x?)" + " (proc: x-z) (proc: both) (proc: a?))" + "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") + get-output-string p))) + +(test 5 'let-sig + (invoke-unit/sig + (unit/sig + m2-3^ + (import) + (define simple 5) + simple))) + +(define-signature big^ + (a b c)) +(define-signature little^ + (a b c)) + +(test 11 + 'link-restrict + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : big^ ((unit/sig big^ (import) (define a 5) (define b 6) (define c 7)))] + [b@ : () ((unit/sig () (import (i : little^)) (+ i:a i:b)) + (a@ : little^))]) + (export)))) + +(define-signature just-a^ + (a)) +(define-signature >just-a^ + ((unit s@ : just-a^))) + +; Test a path for linking: root is a constiuent +(test 12 + 'link-path + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : >just-a^ ((compound-unit/sig + (import) + (link [i@ : just-a^ ((unit/sig + just-a^ + (import) + (define a 5)))]) + (export (unit i@ s@))))] + [r@ : () ((unit/sig + () + (import (i : just-a^)) + (+ i:a 7)) + (a@ s@))]) + (export)))) + +; Test a path for linking: root is an import +(test 12 + 'import-path + (invoke-unit/sig + (compound-unit/sig + (import) + (link [a@ : >just-a^ ((compound-unit/sig + (import) + (link [i@ : just-a^ ((unit/sig + just-a^ + (import) + (define a 5)))]) + (export (unit i@ s@))))] + [u@ : () ((compound-unit/sig + (import (a@ : >just-a^)) + (link [r@ : () ((unit/sig + () + (import (i : just-a^)) + (+ i:a 7)) + (a@ s@))]) + (export)) + a@)]) + (export)))) + +; Signature ordering + +(define o1 (unit/sig (num sym) (import) (define num 5) (define sym 'a))) +(define o2 (unit/sig () (import (sym num)) (list sym (+ num)))) + +(test (list 'a 5) + 'order + (invoke-unit/sig + (compound-unit/sig + (import) + (link [one : (num sym) (o1)] + [two : () (o2 one)]) + (export)))) + +; unit->unit/sig, etc. + +(define-signature s1 + (a b c)) +(define-signature s2 + (+)) + +(define us1 + (unit + (import +) + (export a b c) + + (define a 1) + (define b 2) + (define c 3) + (+ a b c))) + +(test 6 'u->s (invoke-unit us1 +)) +(test 6 'u->s (invoke-unit/sig (unit->unit/sig us1 (s2) s1) s2)) + +; Exporting a name twice: + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))]) + (export (var (A a)) (open A)))) + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))] + [B : (b) ((unit/sig (b) (import) (define b 2)))]) + (export (unit A x) (unit B x)))) + +(syntax-test + '(compound-unit/sig + (import) + (link [A : (a) ((unit/sig (a) (import) (define a 1)))] + [B : (b) ((unit/sig (b) (import) (define b 2)))]) + (export (unit A) (unit B A)))) + +; Can't shadow syntax/macros in unit +(syntax-test '(unit/sig () + (import) + (define define 10))) +(syntax-test '(unit/sig () + (import) + (define lambda 11))) + +; Shadowing ok if it's in the export list: +(test #t unit/sig? (unit/sig (define-values) + (import) + (define define-values 12))) +(test #t unit/sig? (unit/sig (lambda) + (import) + (define lambda 13))) +(test #t unit/sig? (unit/sig (l) + (import) + (rename (lambda l)) + (define lambda 14))) + +; These are ok, too: +(test #t unit/sig? (unit/sig () + (import (define)) + (define define 15))) +(test #t unit/sig? (let ([define-values 5]) + (unit/sig () + (import) + (define define-values 16)))) + +; Not ok if defining an imported name, but error should be about +; redefining an imported name. (This behavior is not actually tested.) +(syntax-test '(unit/sig () + (import (define-values)) + (define define-values 17))) + +(test #t unit/sig? (unit/sig () + (import (define-values)) + (let () (define define-values 10) define-values))) + +;; Invoke-unit linking in let-bound variables +(define x 'not-the-right-x) +(test '(the-x 10) 'invoke/sig + (let ([x 'the-x]) + (invoke-unit/sig + (unit/sig () (import (x)) + (list x 10)) + (x)))) + +(report-errs) + diff --git a/collects/tests/mzscheme/will.ss b/collects/tests/mzscheme/will.ss new file mode 100644 index 00000000..063a7726 --- /dev/null +++ b/collects/tests/mzscheme/will.ss @@ -0,0 +1,59 @@ + +(if (not (defined? 'SECTION)) + (load-relative "testing.ss")) + +(SECTION 'wills) + +(test #f will-executor? 5) +(test #t will-executor? (make-will-executor)) + +(define we (make-will-executor)) + +;; Never GC this one: +(test (void) will-register we test (lambda (x) (error 'bad-will-call))) + +; There's no excuse for not GCing half or more: +(define counter null) +(let loop ([n 10]) + (unless (zero? n) + (will-register we (cons n null) + (lambda (s) + (set! counter (cons (car s) counter)) + 12)) + (loop (sub1 n)))) +(collect-garbage) +(collect-garbage) +(let* ([v #f] + [t (thread (lambda () (set! v (will-execute we))))]) + (sleep 0.1) + (test #f thread-running? t) + (test v values 12)) +(let loop ([m 1]) + (if (let ([v (will-try-execute we)]) + (test #t 'good-result (or (not v) (= v 12))) + v) + (loop (add1 m)) + (begin + (test #t >= m 5) + ;; Make sure counter grew ok + (test m length counter) + ;; Make sure they're all different + (let loop ([l counter]) + (unless (or (null? l) (null? (cdr l))) + (test #f member (car l) (cdr l)) + (loop (cdr l))))))) + +(error-test '(will-register we we we)) +(error-test '(will-register we we (lambda () 10))) +(error-test '(will-register 5 we (lambda (s) 10))) + +(error-test '(will-execute "bad")) +(error-test '(will-try-execute "bad")) + +(arity-test make-will-executor 0 0) +(arity-test will-executor? 1 1) +(arity-test will-register 3 3) +(arity-test will-execute 1 1) +(arity-test will-try-execute 1 1) + +(report-errs) diff --git a/collects/tests/mzscheme/ztest.ss b/collects/tests/mzscheme/ztest.ss new file mode 100644 index 00000000..29567761 --- /dev/null +++ b/collects/tests/mzscheme/ztest.ss @@ -0,0 +1,20 @@ +;; rudimentary test harness for complex math routines in +;; zmath.ss + +(require-library "zmath.ss") + +(define ztest + (lambda (z) + (printf "z = ~a~n" z) + (printf " zabs(z) = ~a~n" (zabs z)) + (printf " zlog(z) = ~a~n" (zlog z)) + (printf " zexp(z) = ~a~n" (zexp z)) + (printf " zsqrt(z) = ~a~n" (zsqrt z)) + (printf " zsin(z) = ~a~n" (zsin z)) + (printf " zcos(z) = ~a~n" (zcos z)) + (printf " ztan(z) = ~a~n" (ztan z)) + (printf " zasin(z) = ~a~n" (zasin z)) + (printf " zacos(z) = ~a~n" (zacos z)) + (printf " zatan(z) = ~a~n" (zatan z)))) + +(ztest 0.5) diff --git a/collects/tests/utils/guir.ss b/collects/tests/utils/guir.ss new file mode 100644 index 00000000..12c44b8d --- /dev/null +++ b/collects/tests/utils/guir.ss @@ -0,0 +1,42 @@ +(unit/sig test-utils:gui^ + (import mred^) + + ;;; find-labelled-window : (union ((union #f string) -> window<%>) + ;;; ((union #f string) (union #f class) -> window<%>) + ;;; ((union #f string) (union class #f) area-container<%> -> area-container<%>)) + ;;;; may call error, if no control with the label is found + (define find-labelled-window + (case-lambda + [(label) (find-labelled-window label #f)] + [(label class) (find-labelled-window label class (get-top-level-focus-window))] + [(label class window) + (unless (or (not label) + (string? label)) + (error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let ([ans + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + window] + [(is-a? window area-container<%>) (ormap loop (send window get-children))] + [else #f]))]) + (or ans + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + ""))))]))) + diff --git a/collects/tests/utils/guis.ss b/collects/tests/utils/guis.ss new file mode 100644 index 00000000..637746dd --- /dev/null +++ b/collects/tests/utils/guis.ss @@ -0,0 +1,2 @@ +(define-signature test-utils:gui^ + (find-labelled-window)) \ No newline at end of file diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt new file mode 100644 index 00000000..79f1fc3b --- /dev/null +++ b/collects/texpict/doc.txt @@ -0,0 +1,326 @@ + + >>>>>> THIS IS UNSUPPORTED SOFTWARE <<<<<<< + +_texpict_ is a MzScheme utility for creating _LaTeX_ picture +expressions. + +LaTeX pictures are created as `pict' structures. Procedures in the +texpict library create new simple picts (e.g., `tex') or create new +picts that include other picts (e.g., `ht-append'). In the latter +case, the embedded picts retain their identity, so that offset-finding +functions (e.g., `find-lt') can find the offset of an embedded pict in +a larger pict. + +A pict has the following structure: + w + ------------------ + | | a \ + |------------------| | + | | | h + |------------------| | + | | d / + ------------------ +For a single `tex' line, d is descent below the baseline and +a + d = h. For multiple tex lines (created with vX-append), a is +ascent of top line above baseline and d is descent of bottom line, +so a + d < h. Other boxes have d = 0 and a = h. + +To create a LaTeX picture, assemble a `pict' and then call +`pict->string'. This string can be `display'ed to obtain the LaTeX +code, which is usually of the form: + \begin{picture} ... \end{picture} +When using colors, the output may be of the form: + \special{color push ...} ... \special{color pop ...} +so consider putting the output in an \hbox{} when using color. + +The `tex' function creates a pict given an arbitrary LaTeX +expression as a string. Initially, `tex' guess at the size of the +resulting pict. (It always guesses 10 x 10.) The LaTeX expression +generated for a `tex' pict causes information to be written to an +auxilliary file when LaTeX evaluates the expression. If you use +`tex' boxes, then: + + * Use the package "mztp.sty" at the start of your LaTeX + document "X.tex". + * In the MzScheme code creating `tex' picts, call + (read-in-sizes "X.mztp") before calling `tex'. + * Run the texpict-LaTeX cycle twice to get properly + draw pictures. + +texpict keys `tex' size information on the exact LaTeX expression +provided to `tex'. If you use a single `tex' pict in two different +contexts where the provided expression produces differently sized +output, texpict will not distinguish the uses (and the size of the +first instance of the pict will be used) by default. The +`serialize-tex-picts' parameter can solve this problem, but +serialization requires that the output is built in exactly the same +order every time, and generally requires more texpict-tex cycles to +reach a fixed point after a small change to the output. The +`tex-series-prefix' parameter may be used to explicitly tag `tex' +sequences in different contexts. + +All positions and sizes must be specified as exact integers. + +A pict is an instance of the `pict' structure type: + +> struct:pict :: (struct pict (draw width height ascent descent children)) + +The `children' field is a list of `child' structures: + +> struct:child :: (struct child (pict dx dy)) + +------------------------------------------------------------ +Procedures +------------------------------------------------------------ + + ;; Load `tex' pict size information generated by a LaTeX run. +> read-in-sizes ; string -> void + + ;; Parameter specifying whether to produce LaTeX commands to + ;; produce size information for a future run. + ;; Default: #t +> output-measure-commands + + ;; Parameter specifying whether the `pict2e' package is active. + ;; Default: #f +> using-pict2e-package + + ;; Parameter specifying whether to draw precise lines for `connect' + ;; with bezier curves. The value is a Boolean or a procedure that + ;; takes a length and returns the number of points to use. + ;; Default: #f +> draw-bezier-lines + + + ;; Parameter specifying a string to embed in the sizing key for a + ;; pict created with `tex'. The prefix is applied when the `tex' + ;; pict is created. Turning on the `serialize-tex-picts' parameter + ;; effectively generates a new series prefix for every `tex' pict. + ;; Default: #f +> tex-series-prefix + + ;; Parameter specifying whether to assign serial numbers to + ;; `tex'-generated strings for sizing purposes. Serial numbers + ;; allow the same tex string to be used in multiple contexts, but + ;; the output must be built in the same order every time. + ;; Default: #f +> serialize-tex-picts + + ;; Parameter specifying whether to draw in B&W or color (when + ;; `colorize' is used). + ;; Default: #f +> black-and-white + + ;; Find an embedded picture; see bottom for the definition of pict-path +> find-lt ; (left & top) ; pict pict-path -> dx dy +> find-lc ; (left & vertical center) +> find-lb ; (left & bottom) +> find-ltl ; (left and top baseline) +> find-lbl ; (left and bottom baseline) +> find-ct ; (horizontal center & top) +> find-cc +> find-cb +> find-ctl +> find-cbl +> find-rt +> find-rc +> find-rb +> find-rtl +> find-rbl + + ;; Create a new pict that hides the given pict from find-XX +> launder ; pict -> pict + + ;; Create an empty pict +> blank ; -> pict + ; s -> pict ; s is side length of square + ; w h -> pict + ; w h d -> pict + + ;; Create picts from LaTeX code +> tex ; string -> pict +> text-line ; string -> pict +> text-line/phantom ; string string -> pict +> tex-paragraph ; w string ['top|'bottom] -> pict + + ;; Delimitters to go around height h (result is taller than h; + ;; try h/2) +> left-brace ; h -> pict +> right-brace ; h -> pict +> left-delimit ; str h -> pict +> right-delimit ; str h -> pict +> middle-delimit ; str h -> pict + ;; Delimitter to go around width w (result is w wide) +> top-brace ; w -> pict +> bottom-brace ; w -> pict + +> clip-descent ; pict -> pict +> inset ; pict i -> pict + ; pict hi vi -> pict + ; pict l t r b -> pict + +> hline ; w h -> pict +> dash-hline ; w h seg-length -> pict ; default seg-length is 5 +> vline ; w h -> pict +> dash-vline ; w h seg-length -> pict ; default seg-length is 5 + ;; To draw other kinds of lines, use `picture' or `cons-picture' + +> frame ; pict -> pict +> dash-frame ; pict seg-length -> pict ; default seg-length is 5 +> oval ; pict -> pict +> oval/radius ; pict r -> pict ; r is radius of corners + + ;; Creates a fairly round circle using four splines: +> big-circle ; diameter -> pict + + ;; Set the line thickness for a picture (does not apply to + ;; slanted lines) +> thick ; pict -> pict +> thin ; pict -> pict + + ;; Make a container picture that doesn't draw the child picture, + ;; but uses the child's size +> ghost ; pict -> pict + +> record ; pict pict ... -> pict + + ;; Make a new picture as a column (vX-append) or row (hX-append) + ;; of other pictures. Different procedures align pictures in the + ;; orthogonal direction in different ways; e.g, vl-append left-aligns + ;; all of the pitures. A specified amount of space is inserted + ;; between each pair of pictures in making the column or row. +> vl-append ; d pict ... -> pict ; d units between each picture +> vc-append +> vr-append +> ht-append +> hc-append +> hb-append +> htl-append ; align bottoms of ascents +> hbl-append ; align tops of descents (normal text alignment) + + ;; Make a new picture by superimposing a set of pictures. The + ;; alignment indicators are essentially as above: horizontal + ;; alignment then vertical alignment. +> lt-superimpose ; pict ... -> pict +> lb-superimpose +> lc-superimpose +> ltl-superimpose +> lbl-superimpose +> rt-superimpose +> rb-superimpose +> rc-superimpose +> rtl-superimpose +> rbl-superimpose +> ct-superimpose +> cb-superimpose +> cc-superimpose +> ctl-superimpose +> cbl-superimpose + + ;; Make a table given a list of picts. The list is a + ;; concatentation of rows (which means that a Scheme `list' call + ;; can be formatted to reflect the shape of the output table). + ;; + ;; The col-aligns, row-aligns, col-seps, and row-seps arguments are + ;; `lists' specifying the row and columns alignments separation + ;; between rows and columns. For C columns and R rows, the first + ;; two should have C and R superimpose procedures, and the last two + ;; should have C - 1 and R - 1 numbers, respectively. The lists can + ;; be improper (e.g. just a number), in which case the non-pair cdr + ;; is used as the value for all remaining list items that were + ;; expected. The alignment procedures are used to superimpose all + ;; of the cells in a column or row; this superimposition determines + ;; the total width oir height of the column or row, and also + ;; determines the horizontal or vertical placement of each cell in + ;; the column or row. +> table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict + + ;; Apply a color to a picture. If the given picture has a colorized + ;; sub-picture, the color of the sub-picture is not affected. + ;; Be sure to use the LaTeX package `colordvi'. +> colorize ; pict color-string -> pict + + ;; Desribe a picture with low-level commands; see below. +> picture ; w h command-list -> pict + + ;; Create a new picture by `cons'ing drawing commands onto + ;; an existing picture. +> cons-picture ; pict command-list -> pict + + ;; Create a self-rendering picture (for dc output only) +> prog-picture ; (dc dx dy -> void) w a d -> pict + + + ;; Generate the LaTeX code for a pict. +> pict->string + + ;; Parameter to use the old implementation of `connect'. +> use-old-connect + +------------------------------------------------------------ +Picture Paths, Command, Putables, and Drawables +------------------------------------------------------------ + +pict-path: + + pict + non-empty-pict-path-list + +commands: + + `(place ,x ,y ,pict) + `(put ,x ,y ,putable) + `(connect ,x1 ,y1 ,x2 ,y2 ,bool) ; line or vector; bool => vector; + ; from (x1,y1) to (~x2,~y2) + ; as close as possible + ; (synonym for connect~xy with + ; an infinite tolerance when + ; draw-bezier-lines is #f, or + ; for curve when draw-bezier-lines + ; is #t) + `(dconnect ,x ,y ,dx ,dy ,bool) ; line or vector; bool => vector; + ; from (x,y) to (~(x+dx),~(y+dy)) + ; as close as possible (uses + ; connect) + `(connect~y ,tol ,x1 ,y2 ,x2 ,y2 ,bool) ; sequence of lines from + ; (~x1,~y1) to (~x2,~y2) where + ; either: + ; 1) ~x2=x2 and |~y2-y2| (lambda (m) + (parse-string (cadr m) + (send the-font-list find-or-create-font + (send f get-point-size) + (send f get-family) + (send f get-style) + 'bold)))] + [(regexp-match "^{\\\\it (.*)}$" s) + => (lambda (m) + (parse-string (cadr m) + (send the-font-list find-or-create-font + (send f get-point-size) + (send f get-family) + 'italic + (send f get-weight))))] + [else (values s f)])) + +(define (set-dc-for-text-size dc) + (output-measure-commands #f) + (draw-bezier-lines #t) + (current-tex-sizer + (lambda (s) + (let-values ([(s f) (parse-string s (send dc get-font))]) + (let-values ([(w h d a) (send dc get-text-extent s f)]) + (list w (- h d) d)))))) + +(define (draw-pict dc p dx dy) + + (define (render dc w h l dx dy) + (define b&w? #f) + (define straight? #f) + (define draw-line (ivar dc draw-line)) + (define draw-spline (ivar dc draw-spline)) + (define get-pen (ivar dc get-pen)) + (define get-brush (ivar dc get-brush)) + (define set-pen (ivar dc set-pen)) + (define set-brush (ivar dc set-brush)) + (define find-or-create-pen (ivar the-pen-list find-or-create-pen)) + (define find-or-create-brush (ivar the-brush-list find-or-create-brush)) + (set-brush (find-or-create-brush "black" 'solid)) + (let loop ([dx dx][dy dy][l l][color "black"]) + (unless (null? l) + (let ([x (car l)]) + (if (string? x) + (let-values ([(tw th td ta) (send dc get-text-extent x)] + [(c) (send dc get-text-foreground)] + [(f) (send dc get-font)]) + (let-values ([(x f2) (parse-string x f)]) + (send dc set-font f2) + (send dc set-text-foreground (make-object color% color)) + (send dc draw-text x dx (- h dy (- th td))) + (send dc set-text-foreground c) + (send dc set-font f))) + (case (car x) + [(offset) (loop (+ dx (cadr x)) + (+ dy (caddr x)) + (cadddr x) + color)] + [(line vector) + (let ([xs (cadr x)] + [ys (caddr x)] + [len (cadddr x)]) + (draw-line + dx (- h dy) + (+ dx (* xs len)) (- h (+ dy (* ys len)))))] + [(circle circle*) + (let ([size (cadr x)]) + (send dc draw-ellipse + dx (- h dy size) + size size))] + [(oval) + (let ([b (get-brush)]) + (set-brush (find-or-create-brush "BLACK" 'transparent)) + (send dc draw-rounded-rectangle + (- dx (/ (cadr x) 2)) + (- h dy (/ (caddr x) 2)) + (cadr x) (caddr x) + -0.2) + (set-brush b))] + [(bezier) + (if straight? + (draw-line (+ dx (list-ref x 1)) + (- h (+ dy (list-ref x 2))) + (+ dx (list-ref x 5)) + (- h (+ dy (list-ref x 6)))) + (draw-spline (+ dx (list-ref x 1)) + (- h (+ dy (list-ref x 2))) + (+ dx (list-ref x 3)) + (- h (+ dy (list-ref x 4))) + (+ dx (list-ref x 5)) + (- h (+ dy (list-ref x 6)))))] + [(with-color) + (if b&w? + (loop dx dy (caddr x) color) + (let ([p (get-pen)] + [b (get-brush)]) + (set-pen (find-or-create-pen (cadr x) (send p get-width) 'solid)) + (set-brush (find-or-create-brush (cadr x) 'solid)) + (loop dx dy (caddr x) (cadr x)) + (set-pen p) + (set-brush b)))] + [(with-thickness) + (let ([p (get-pen)]) + (set-pen (find-or-create-pen (send p get-color) + (if (eq? (cadr x) 'thicklines) + 1 + 0) + 'solid)) + (loop dx dy (caddr x) color) + (set-pen p))] + [(prog) + ((cadr x) dc dx (- h dy))] + [else (error 'rander "unknown command: ~a~n" x)]))) + (loop dx dy (cdr l) color)))) + + (render dc (pict-width p) (pict-height p) + (pict->commands p) + dx dy)) diff --git a/collects/texpict/texpict.ss b/collects/texpict/texpict.ss new file mode 100644 index 00000000..0aa09d36 --- /dev/null +++ b/collects/texpict/texpict.ss @@ -0,0 +1,13 @@ + +; For information about texpict, see texpicts.ss + +(require-library "refer.ss") + +(require-library "texpicts.ss" "texpict") + +(begin-elaboration-time + (require-library "invoke.ss")) + + +(define-values/invoke-unit/sig texpict^ + (require-library-unit/sig "texpictr.ss" "texpict")) diff --git a/collects/texpict/texpictr.ss b/collects/texpict/texpictr.ss new file mode 100644 index 00000000..c7e78a7c --- /dev/null +++ b/collects/texpict/texpictr.ss @@ -0,0 +1,1119 @@ + +; For information about texpict, see texpicts.ss + +(unit/sig + texpict^ + (import) + +(define default-seg 5) +(define recordseplinespace 4) + +(define using-pict2e-package + (make-parameter #f + (lambda (x) + (and x #t)))) + +(define use-old-connect + (make-parameter #f + (lambda (x) + (and x #t)))) + +(define output-measure-commands + (make-parameter #t + (lambda (x) + (and x #t)))) + +(define draw-bezier-lines + (make-parameter #f + (lambda (x) + (if (procedure? x) + (begin + (unless (procedure-arity-includes? x 1) + (raise-type-error 'draw-bezier-lines + "boolean or procedure of one argument" + x)) + x) + (and x #t))))) + +(define serialize-tex-picts + (make-parameter #f + (lambda (x) + (and x #t)))) + +(define tex-series-prefix + (make-parameter #f + (lambda (s) + (when s + (unless (string? s) + (raise-type-error 'tex-series-prefix "string or #f" s))) + s))) + +(define current-tex-sizer + (make-parameter (lambda (t) #f))) + +(define-struct pict (draw ; drawing instructions + width ; total width + height ; total height >= ascent + desecnt + ascent ; portion of height above top baseline + descent ; portion of height below bottom baseline + children)) ; list of child records +(define-struct child (pict dx dy)) + +(define (quotient* a b) + (if (integer? a) + (quotient a b) + (/ a b))) + +(define blank + (case-lambda + [() (blank 0 0 0)] + [(s) (blank s s)] + [(w h) (blank w h 0)] + [(w a d) (make-pict `(picture ,w ,(+ a d)) w (+ a d) a d null)])) + +(define (prog-picture f w a d) + (make-pict `(prog ,f) w (+ a d) a d null)) + +(define (extend-pict box dx dy dw da dd draw) + (let ([w (pict-width box)] + [h (pict-height box)] + [d (pict-descent box)] + [a (pict-ascent box)]) + (make-pict (if draw draw (pict-draw box)) + (+ w dw) (+ h da dd) + (+ a da) (+ d dd) + (list (make-child box dx dy))))) + +(define (single-pict-offset pict subbox) + (let floop ([box pict] + [found values] + [not-found (lambda () (error 'find-XX + "sub-pict: ~a not found in: ~a" + subbox pict))]) + (if (eq? box subbox) + (found 0 0) + (let loop ([c (pict-children box)]) + (if (null? c) + (not-found) + (floop (child-pict (car c)) + (lambda (dx dy) + (found (+ dx (child-dx (car c))) + (+ dy (child-dy (car c))))) + (lambda () + (loop (cdr c))))))))) + +(define (find-lb pict subbox-path) + (if (pict? subbox-path) + (single-pict-offset pict subbox-path) + (let loop ([p pict][l subbox-path][dx 0][dy 0]) + (if (null? l) + (values dx dy) + (let-values ([(x y) (find-lb p (car l))]) + (loop (car l) (cdr l) (+ x dx) (+ y dy))))))) + +(define-values (find-lt + find-lc + find-ltl + find-lbl + find-ct + find-cc + find-cb + find-ctl + find-cbl + find-rt + find-rc + find-rb + find-rtl + find-rbl) + (let ([lb (lambda (x w d a) x)] + [c (lambda (x w d a) (+ x (quotient* w 2)))] + [rt (lambda (x w d a) (+ x w))] + [tline (lambda (x w d a) (+ x (- w a)))] + [bline (lambda (x w d a) (+ x d))] + [find (lambda (get-x get-y) + (lambda (pict pict-path) + (let-values ([(dx dy) (find-lb pict pict-path)]) + (let ([p (let loop ([path pict-path]) + (cond + [(pict? path) path] + [(null? (cdr path)) (loop (car path))] + [else (loop (cdr path))]))]) + (values (get-x dx (pict-width p) 0 0) + (get-y dy (pict-height p) (pict-descent p) (pict-ascent p)))))))]) + (values (find lb rt) + (find lb c) + (find lb tline) + (find lb bline) + (find c rt) + (find c c) + (find c lb) + (find c tline) + (find c bline) + (find rt rt) + (find rt c) + (find rt lb) + (find rt tline) + (find rt bline)))) + +(define (launder box) + (let ([b (extend-pict box 0 0 0 0 0 #f)]) + (set-pict-children! b null) + b)) + +(define label-sizes null) +(define (extract-num s) ; strip off trainling `pt' + (let ([str (symbol->string s)]) + (inexact->exact + (ceiling + (string->number (substring str 0 (- (string-length str) 2))))))) + +(define (read-in-sizes file) + (parameterize ([read-case-sensitive #t]) + (when (file-exists? file) + (set! label-sizes + (append (with-input-from-file file + (lambda () + (let loop () + (let ([e (read)]) + (if (eof-object? e) + null + (let ([w (read)] + [h (read)] + [d (read)]) + (cons (list e + (extract-num w) + (extract-num h) + (extract-num d)) + (loop)))))))) + label-sizes))))) + +;; Marshall a tex string into a simple symbol +(define digits (make-vector 64)) +(let loop ([i 0]) + (unless (= i 10) + (vector-set! digits i (integer->char (+ i (char->integer #\0)))) + (loop (add1 i)))) +(let loop ([i 0]) + (unless (= i 26) + (vector-set! digits (+ i 10) (integer->char (+ i (char->integer #\a)))) + (vector-set! digits (+ i 36) (integer->char (+ i (char->integer #\A)))) + (loop (add1 i)))) +(vector-set! digits 62 #\-) +(vector-set! digits 63 #\+) +(define (number->base-64-string prefix n) + (let loop ([n n][s null]) + (if (zero? n) + (list->string (cons prefix s)) + (loop (arithmetic-shift n -6) + (cons (vector-ref digits (bitwise-and 63 n)) s))))) +(define serial-number 0) +(define (serialize s) + (cond + [(serialize-tex-picts) + (set! serial-number (add1 serial-number)) + (format "~a.~a" serial-number s)] + [(tex-series-prefix) + (format "~a.~a" (tex-series-prefix) s)] + [else s])) +(define (make-label s) + (string->symbol + (serialize + (number->base-64-string + #\T + (let loop ([l (string->list s)][n 0]) + (if (null? l) + n + (loop (cdr l) (+ (arithmetic-shift n 7) (char->integer (car l)))))))))) + +(define tex + (case-lambda + [(t) (tex t 10 10)] + [(t guess-width guess-height) + (let* ([label (make-label t)] + [info (or (assq label label-sizes) + (let ([v ((current-tex-sizer) t)]) + (and v + (cons label v))))] + [w (if info (cadr info) guess-width)] + [h (if info (caddr info) guess-height)] + [d (if info (cadddr info) guess-height)]) + (make-pict `(picture ,w ,(+ d h) + (put 0 ,d + ,(if (output-measure-commands) + (format "\\mztpMeasure{~a}{~a}" + t label) + t))) + w + (+ d h) + h d + null))])) + +(define (text-line/phantom text phantom . args) + (apply tex (format "\\makebox[0pt]{\\vphantom{~a}}~a" phantom text) args)) + +(define (text-line text . args) + (apply text-line/phantom text "Xy" args)) + +(define (tex-no-descent . args) + (clip-descent (apply tex args))) + +(define tex-paragraph + (case-lambda + [(w str) (tex-paragraph w str 'top)] + [(w str align) + (tex (format "\\parbox[~a]{~apt}{~a}" + (case align + [(top) 't] + [(bottom) 'b] + [else (error 'tex-paragraph "bad alignment: ~a" align)]) + w + str))])) + +(define (clip-descent b) + (let* ([w (pict-width b)] + [h (pict-height b)] + [d (pict-descent b)]) + (extend-pict + b 0 (- d) + 0 0 (- d) + `(picture ,w ,(- h d) + (put 0 ,(- d) ,(pict-draw b)))))) + +(define (thickness mode b) + (let* ([w (pict-width b)] + [h (pict-height b)]) + (extend-pict + b 0 0 0 0 0 + `(picture ,w ,h + (thickness ,mode ,(pict-draw b)))))) + +(define (thick b) (thickness 'thicklines b)) +(define (thin b) (thickness 'thinlines b)) + +(define delimit-str + "\\hbox{$\\~a{\\hbox{$\\left~a\\rule{0pt}{~apt}\\right.$}}$}") + +(define (mk-delimit left? middle? right? delim h) + (let ([str (format delimit-str + (cond + [left? "mathopen"] + [right? "mathclose"] + [middle? "mathrel"]) + delim + h)]) + (tex str 10 h))) + +(define (left-delimit delim h) + (mk-delimit #t #f #f delim h)) +(define (middle-delimit delim h) + (mk-delimit #f #t #f delim h)) +(define (right-delimit delim h) + (mk-delimit #f #f #t delim h)) + +(define (left-brace h) + (left-delimit "\\{" h)) +(define (right-brace h) + (right-delimit "\\}" h)) + +(define (make-h-brace kind w) + (tex (format "$\\~a{\\hbox{\\begin{picture}(~a,0)(0,0)\\end{picture}}}$" + kind w))) + +(define (top-brace w) + (make-h-brace "overbrace" w)) +(define (bottom-brace w) + (make-h-brace "underbrace" w)) + +(define inset + (case-lambda + [(box a) (inset box a a a a)] + [(box h v) (inset box h v h v)] + [(box l t r b) + (let ([w (+ l r (pict-width box))] + [h (+ t b (pict-height box))]) + (extend-pict + box l b + (+ l r) t b + `(picture + ,w ,h + (put ,l ,b ,(pict-draw box)))))])) + +(define dash-frame + (case-lambda + [(box) (dash-frame box default-seg)] + [(box seg) + (let ([w (pict-width box)] + [h (pict-height box)]) + (extend-pict + box 0 0 0 0 0 + `(picture + ,w ,h + (put 0 0 ,(pict-draw box)) + (put 0 0 ,(pict-draw (dash-hline w 0 seg))) + (put 0 ,h ,(pict-draw (dash-hline w 0 seg))) + (put 0 0 ,(pict-draw (dash-vline 0 h seg))) + (put ,w 0 ,(pict-draw (dash-vline 0 h seg))))))])) + +(define (frame box) + (dash-frame box (max (pict-width box) (pict-height box)))) + +(define (dash-line width height rotate seg) + (let ([vpos (quotient* height 2)]) + (make-pict + `(picture + ,@(rotate width height) + ,@(if (>= seg width) + `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,width))) + (let* ([remain (remainder width (* 2 seg))] + [count (quotient* width (* 2 seg))] + [lremain (quotient* remain 2)] + [rremain (- remain lremain)]) + `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,lremain)) + ,@(let loop ([count count][pos lremain]) + (if (zero? count) + null + (cons `(put ,@(rotate (+ pos seg) vpos) + (line ,@(rotate 1 0) ,seg)) + (loop (sub1 count) (+ pos seg seg))))) + (put ,@(rotate (- width rremain) vpos) + (line ,@(rotate 1 0) ,rremain)))))) + (car (rotate width height)) + (cadr (rotate width height)) + (cadr (rotate 0 height)) 0 + null))) + +(define (rlist b a) (list a b)) + +(define (hline width height) + (dash-line width height list width)) + +(define (vline width height) + (dash-line height width rlist height)) + +(define dash-hline + (case-lambda + [(width height) (dash-hline width height default-seg)] + [(width height seg) (dash-line width height list seg)])) + +(define dash-vline + (case-lambda + [(width height) (dash-vline width height default-seg)] + [(width height seg) (dash-line height width rlist seg)])) + +(define (oval box) + (let ([w (pict-width box)] + [h (pict-height box)]) + (extend-pict + box 0 0 0 0 0 + `(picture + ,w ,h + (put 0 0 ,(pict-draw box)) + (put ,(quotient* w 2) ,(quotient* h 2) (oval "" ,w ,h)))))) + +(define (oval/radius box r) + (let* ([w (pict-width box)] + [h (pict-height box)] + [rr (* 2 r)] + [lw (- w rr)] + [lh (- h rr)]) + (extend-pict + box 0 0 0 0 0 + `(picture + ,w ,h + (put 0 0 ,(pict-draw box)) + (put ,r ,r (oval "[bl]" ,rr ,rr)) + (put ,r 0 (line 1 0 ,lw)) + (put ,(- w r) ,r (oval "[br]" ,rr ,rr)) + (put ,w ,r (line 0 1 ,lh)) + (put ,r ,(- h r) (oval "[tl]" ,rr ,rr)) + (put ,r ,h (line 1 0 ,lw)) + (put ,(- w r) ,(- h r) (oval "[tr]" ,rr ,rr)) + (put ,0 ,r (line 0 1 ,lh)))))) + +(define (big-circle d) + (let ([r (quotient* d 2)]) + (picture + d d + `((curve 0 ,r ,r 0 0 0) + (curve ,r 0 ,d ,r ,d 0) + (curve ,d ,r ,r ,d ,d ,d) + (curve ,r ,d 0 ,r 0 ,d))))) + +(define (ghost box) + (let ([w (pict-width box)] + [h (pict-height box)]) + (extend-pict + box 0 0 0 0 0 + `(picture + ,w ,h)))) + +(define-values (vl-append + vc-append + vr-append + ht-append + hc-append + hb-append + htl-append + hbl-append) + (let ([make-append-boxes + (lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset + combine-ascent combine-descent) + (lambda (sep . args) + (unless (number? sep) + (raise-type-error 'XXX-append "number" sep)) + (let append-boxes ([args args]) + (cond + [(null? args) (blank)] + [(null? (cdr args)) (car args)] + [else + (let* ([first (car args)] + [rest (append-boxes (cdr args))] + [w (wcomb (pict-width first) (pict-width rest) sep)] + [h (hcomb (pict-height first) (pict-height rest) sep)] + [fw (pict-width first)] + [fh (pict-height first)] + [rw (pict-width rest)] + [rh (pict-height rest)] + [fd1 (pict-ascent first)] + [fd2 (pict-descent first)] + [rd1 (pict-ascent rest)] + [rd2 (pict-descent rest)] + [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] + [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] + [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] + [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]) + (make-pict + `(picture + ,w ,h + (put ,dx1 + ,dy1 + ,(pict-draw first)) + (put ,dx2 + ,dy2 + ,(pict-draw rest))) + w h + (combine-ascent fd1 rd1 fd2 rd2 fh rh h) + (combine-descent fd2 rd2 fd1 rd1 fh rh h) + (list (make-child first dx1 dy1) + (make-child rest dx2 dy2))))]))))] + [2max (lambda (a b c) (max a b))] + [zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) 0)] + [fv (lambda (a b . args) a)] + [sv (lambda (a b . args) b)] + [min2 (lambda (a b . args) (min a b))] + [max2 (lambda (a b . args) (max a b))] + [min-ad (lambda (a b oa ob ah bh h) + (if (and (= ah (+ a oa)) + (= bh (+ b ob))) + (- h (max oa ob)) + (min a b)))]) + (values + (make-append-boxes 2max + + zero (lambda (fw fh rw rh sep . a) (+ sep rh)) + zero zero + fv sv) + (make-append-boxes 2max + + (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) fw) 2)) + (lambda (fw fh rw rh sep . a) (+ sep rh)) + (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) rw) 2)) + zero + fv sv) + (make-append-boxes 2max + + (lambda (fw fh rw rh sep . a) (- (max fw rw) fw)) + (lambda (fw fh rw rh sep . a) (+ sep rh)) + (lambda (fw fh rw rh sep . a) (- (max fw rw) rw)) + zero + fv sv) + (make-append-boxes + 2max + zero + (lambda (fw fh rw rh sep . a) (- (max fh rh) fh)) + (lambda (fw fh rw rh sep . a) (+ sep fw)) + (lambda (fw fh rw rh sep . a) (- (max fh rh) rh)) + max2 min2) + (make-append-boxes + 2max + zero + (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) fh) 2)) + (lambda (fw fh rw rh sep . a) (+ sep fw)) + (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) rh) 2)) + min2 max2) + (make-append-boxes + 2max + zero zero + (lambda (fw fh rw rh sep . a) (+ sep fw)) zero + min2 max2) + (make-append-boxes + 2max + zero + (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) + (- (max fh rh) fh (- (max fd1 rd1) fd1))) + (lambda (fw fh rw rh sep . a) (+ sep fw)) + (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) + (- (max fh rh) rh (- (max fd1 rd1) rd1))) + max2 min-ad) + (make-append-boxes + 2max + zero + (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) + (- (max fd2 rd2) fd2)) + (lambda (fw fh rw rh sep . a) (+ sep fw)) + (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) + (- (max fd2 rd2) rd2)) + min-ad max2)))) + +(define-values (lt-superimpose + lb-superimpose + lc-superimpose + ltl-superimpose + lbl-superimpose + rt-superimpose + rb-superimpose + rc-superimpose + rtl-superimpose + rbl-superimpose + ct-superimpose + cb-superimpose + cc-superimpose + ctl-superimpose + cbl-superimpose) + (let ([make-superimpose + (lambda (get-h get-v get-th) + (lambda boxes + (let ([max-w (apply max (map pict-width boxes))] + [max-h (apply max (map pict-height boxes))] + [max-a (apply max (map pict-ascent boxes))] + [max-a-complement (apply max (map (lambda (b) (- (pict-height b) (pict-ascent b))) + boxes))] + [max-d (apply max (map pict-descent boxes))] + [max-d-complement (apply max (map (lambda (b) (- (pict-height b) (pict-descent b))) + boxes))]) + (picture max-w (get-th max-h max-a max-d max-a-complement max-d-complement) + (map (lambda (box) + `(place ,(get-h max-w (pict-width box)) + ,(get-v max-h (pict-height box) + max-d (pict-descent box) + max-a-complement) + ,box)) + boxes)))))] + [norm (lambda (h a d ac dc) h)] + [tbase (lambda (h a d ac dc) (+ a ac))] + [bbase (lambda (h a d ac dc) (+ d dc))] + [lb (lambda (m v . rest) 0)] + [rt (lambda (m v . rest) (- m v))] + [tline (lambda (m v md d mac) mac)] + [bline (lambda (m v md d mac) (- md d))] + [c (lambda (m v . rest) (quotient* (- m v) 2))]) + (values + (make-superimpose lb rt norm) + (make-superimpose lb lb norm) + (make-superimpose lb c norm) + (make-superimpose lb tline tbase) + (make-superimpose lb bline bbase) + (make-superimpose rt rt norm) + (make-superimpose rt lb norm) + (make-superimpose rt c norm) + (make-superimpose rt tline tbase) + (make-superimpose rt bline bbase) + (make-superimpose c rt norm) + (make-superimpose c lb norm) + (make-superimpose c c norm) + (make-superimpose c tline tbase) + (make-superimpose c bline bbase)))) + +(define table + (case-lambda + [(ncol cells col-aligns row-aligns col-seps row-seps) + (unless (positive? ncol) + (raise-type-error 'table "positive column count" ncol)) + (let ([count (length cells)]) + (unless (zero? (remainder count ncol)) + (error 'table "cell count isn't divisble by the provided column count")) + (let* ([w ncol] + [h (/ count w)] + [cells (let rloop ([r h][cells cells][r-acc null]) + (if (zero? r) + (list->vector (reverse r-acc)) + (let loop ([c w][cells cells][one-acc null]) + (if (zero? c) + (rloop (sub1 r) cells (cons (list->vector (reverse one-acc)) r-acc)) + (loop (sub1 c) (cdr cells) (cons (car cells) one-acc))))))] + [imp-list->vector (lambda (l n) + (let ([v (make-vector n)]) + (let loop ([l l][p 0]) + (unless (= n p) + (vector-set! v + p + (if (pair? l) + (car l) + l)) + (loop (if (pair? l) (cdr l) l) (add1 p)))) + v))] + [ralign (imp-list->vector row-aligns h)] + [calign (imp-list->vector col-aligns w)] + [rsep (imp-list->vector row-seps h)] + [csep (imp-list->vector col-seps w)] + [get-cell (lambda (c r) (vector-ref (vector-ref cells r) c))] + [nmap (lambda (f w) + (let loop ([n w][acc null]) + (if (zero? n) + acc + (loop (sub1 n) (cons (f (sub1 n)) acc)))))] + [rowmap (lambda (f) (nmap f h))] + [colmap (lambda (f) (nmap f w))] + [superimposed-rows (list->vector + (rowmap (lambda (r) + (apply + (vector-ref ralign r) + (colmap (lambda (c) (get-cell c r)))))))] + [superimposed-cols (list->vector + (colmap (lambda (c) + (apply + (vector-ref calign c) + (rowmap (lambda (r) (get-cell c r)))))))]) + ; No space after the last row/col + (vector-set! rsep (sub1 h) 0) + (vector-set! csep (sub1 w) 0) + + (apply + vl-append + 0 + (rowmap + (lambda (r) + (vl-append + 0 + (apply + ht-append + 0 + (colmap (lambda (c) + (ht-append + 0 + (let* ([cell (get-cell c r)] + [sc (vector-ref superimposed-cols c)] + [sr (vector-ref superimposed-rows r)] + [w (pict-width sc)] + [h (pict-height sr)]) + (let-values ([(x __) (find-lb sc cell)] + [(_ y) (find-lb sr cell)]) + (picture + w h + `((place ,x ,y ,cell))))) + (blank (vector-ref csep c) 0))))) + (blank 0 (vector-ref rsep r))))))))])) + +(define (record title . fields) + (let* ([totalwidth (apply max (pict-width title) (map pict-width fields))] + [linespace (if (null? fields) 0 recordseplinespace)] + [totalheight (+ (pict-height title) (apply + (map pict-height fields)) + linespace)] + [title-y (- totalheight (pict-height title))] + [field-ys (let loop ([pos (- totalheight (pict-height title) linespace)] + [fields fields]) + (if (null? fields) + null + (let* ([p (- pos (pict-height (car fields)))]) + (cons p + (loop p (cdr fields))))))]) + (make-pict + `(picture + ,totalwidth ,totalheight + (put 0 0 (line 1 0 ,totalwidth)) + (put 0 ,totalheight (line 1 0 ,totalwidth)) + (put 0 0 (line 0 1 ,totalheight)) + (put ,totalwidth 0 (line 0 1 ,totalheight)) + (put 0 ,title-y ,(pict-draw title)) + ,@(if (null? fields) + '() + `((put 0 ,(- totalheight (pict-height title) (quotient* linespace 2)) + (line 1 0 ,totalwidth)))) + ,@(map (lambda (f p) `(put 0 ,p ,(pict-draw f))) + fields field-ys)) + totalwidth totalheight + totalheight 0 + (cons + (make-child title 0 title-y) + (map (lambda (child child-y) (make-child child 0 child-y)) fields field-ys))))) + +(define (find-slope dh dv max-slope-num h-within v-within) ; max-slope-num is 4 or 6 + ; Result is (slope new-dh), where slope can be 'vertical, in which case + ; new-dh is really dv + (letrec ([best-of-two + (lambda (a b) + (let*-values ([(ls lh) (a)] + [(rs rh) (b)]) + (if (and ls (or (not rs) (< (abs (- lh dh)) (abs (- rh dh))))) + (values ls lh) + (values rs rh))))] + [search-h + (lambda (dh dv depth direction) + (if (zero? depth) + (values #f #f) + (if (zero? dh) + (values 'vertical dv) + (let ([slope (/ dv dh)]) + (if (and (<= (abs (numerator slope)) max-slope-num) + (<= (abs (denominator slope)) max-slope-num)) + (values slope dh) + (search-h (+ dh direction) dv (sub1 depth) direction))))))] + [sign (lambda (x) (if (positive? x) 1 -1))] + [flip + (lambda (s l) + (if s + (cond + [(eq? s 'vertical) (values (sign l) 0 (abs l))] + [(zero? s) (values 'vertical l)] + [else (values (/ 1 s) (round (* s l)))]) + (values #f #f)))] + [search-v + (lambda (dh dv depth direction) + (call-with-values (lambda () (search-h dv dh depth direction)) + flip))] + [change-h + (lambda (dh dv h-within) + (best-of-two (lambda () (search-h dh dv h-within -1)) + (lambda () (search-h dh dv h-within 1))))] + [change-v + (lambda (dh dv v-within) + (call-with-values (lambda () (change-h dv dh v-within)) + flip))]) + (cond + [(zero? v-within) (change-h dh dv h-within)] + [(zero? h-within) (change-v dh dv v-within)] + [else (let-values ([(s l) (search-h dh dv 1 0)]) + (if s + (values s l) + (best-of-two + (lambda () + (best-of-two (lambda () (find-slope dh (add1 dv) max-slope-num h-within (sub1 v-within))) + (lambda () (find-slope dh (sub1 dv) max-slope-num h-within (sub1 v-within))))) + (lambda () + (best-of-two (lambda () (find-slope (add1 dh) dv max-slope-num (sub1 h-within) v-within)) + (lambda () (find-slope (sub1 dh) dv max-slope-num (sub1 h-within) v-within)))))))]))) + +(define (parse-slope sl dh) + (if (eq? sl 'vertical) + (if (negative? dh) + (values 0 -1 (abs dh)) + (values 0 1 dh)) + (let ([d (denominator sl)] + [n (numerator sl)]) + (if (negative? dh) + (values (- d) (- n) (abs dh)) + (values d n dh))))) + +(define connect + (case-lambda + [(x1 y1 x2 y2) (connect x1 y1 x2 y2 #f)] + [(x1 y1 x2 y2 arrow?) + (if (not (or (use-old-connect) (draw-bezier-lines))) + (~connect 'r +inf.0 x1 y1 x2 y2 arrow?) + (let loop ([dd (if (draw-bezier-lines) 0 1)]) + (if (> dd (if (draw-bezier-lines) 0 4)) + ; give up + (if (draw-bezier-lines) + (let* ([get-len (lambda () (sqrt (+ (* (- x1 x2) (- x1 x2)) + (* (- y1 y2) (- y1 y2)))))] + [c (if (procedure? (draw-bezier-lines)) + ((draw-bezier-lines) (get-len)) + #f)]) + `((qbezier ,c ,x1 ,y1 ,(quotient* (+ x1 x2) 2) ,(quotient* (+ y1 y2) 2) ,x2 ,y2))) + (let ([xd (- x2 x1)]) + `((put ,x1 ,y1 (line ,(if (negative? xd) -1 1) 0 ,(abs xd)))))) + (let-values ([(s l) (find-slope (- x2 x1) (- y2 y1) + (if (using-pict2e-package) + +inf.0 + (if arrow? 4 6)) + dd dd)]) + (if s + (let-values ([(lh lv ll) (parse-slope s l)]) + `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,lh ,lv ,ll)))) + (loop (add1 dd)))))))])) + +(define ~connect + (case-lambda + [(exact close-enough x1 y1 x2 y2) (~connect exact close-enough x1 y1 x2 y2 #f)] + [(exact close-enough x1 y1 x2 y2 arrow?) + (if (= x2 x1) + ; "infinite" slope + (let ([dy (- y2 y1)]) + `((put ,x1 ,y1 (,(if arrow? 'vector 'line) 0 ,(if (negative? dy) -1 1) ,(abs dy))))) + (let ([real-slope (/ (- y2 y1) (- x2 x1))] + [split (lambda (xm ym) + (append + (~connect exact close-enough xm ym x1 y1 #f) + (~connect exact close-enough xm ym x2 y2 arrow?)))]) + (if (or (>= real-slope (if arrow? 7/8 11/12)) + (<= real-slope (if arrow? -7/8 -11/12))) + ; rounds to "infinite" slope + (if (> (abs (- x2 x1)) close-enough) + (split x1 (truncate (quotient (+ y1 y2) 2))) + (let ([dy (- y2 y1)]) + `((put ,x1 ,y1 (,(if arrow? 'vector 'line) + 0 + ,(if (negative? dy) -1 1) ,(abs dy)))))) + (let* ([slope (let loop ([slope real-slope][tolerances + (if arrow? + '(1/100 1/12 1/4) + '(1/100 1/50 1/25 1/10 1/6))]) + (if (<= (denominator slope) (if arrow? 4 6)) + slope + (loop (rationalize real-slope (car tolerances)) + (cdr tolerances))))] + [exact-x? (or (eq? exact 'x) (zero? slope))] + [r (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2))))] + [dx (cond + [exact-x? (- x2 x1)] + [(eq? exact 'r) (truncate (* r (let ([d (denominator slope)] + [n (numerator slope)]) + (/ d (sqrt (+ (* d d) (* n n)))))))] + [else (truncate (* (/ slope) (- y2 y1)))])] + [dy (truncate (* slope dx))]) + (if (or (and exact-x? + (> (abs (- dy (- y2 y1))) close-enough)) + (and (not exact-x?) (eq? exact 'y) + (> (abs (- dx (- x2 x1))) close-enough)) + (and (not exact-x?) (eq? exact 'y) + (> (abs (- (sqrt (+ (* dx dx) (* dy dy))) r)) close-enough))) + (if (or exact-x? (eq? exact 'r)) + (let ([xm (truncate (quotient (+ x1 x2) 2))]) + (split xm (+ y1 (truncate (* slope (- xm x1)))))) + (let ([ym (truncate (quotient (+ y1 y2) 2))]) + (split (+ x1 (truncate (* (/ slope) (- ym y1)))) ym))) + (let ([same-sign (lambda (v s) + (if (negative? s) + (- (abs v)) + (abs v)))]) + `((put ,x1 ,y1 (,(if arrow? 'vector 'line) + ,(same-sign (denominator slope) (- x2 x1)) + ,(same-sign (numerator slope) (- y2 y1)) + ,(abs dx))))))))))])) + +(define (picture w h commands) + (let loop ([commands commands][translated null][children null]) + (if (null? commands) + (make-pict + `(picture ,w ,h + ,@(reverse translated)) + w h + h 0 + children) + (let ([c (car commands)] + [rest (cdr commands)]) + (unless (and (pair? c) (symbol? (car c))) + (error 'picture "bad command: ~a" c)) + (case (car c) + [(connect) (loop rest + (append (apply connect (cdr c)) + translated) + children)] + [(dconnect) (loop rest + (let ([x (cadr c)] + [y (caddr c)] + [dx (cadddr c)] + [dy (list-ref c 4)]) + (append (connect x y (+ x dx) (+ y dy) + (if (null? (list-tail c 5)) + #t + (list-ref c 5))) + translated)) + children)] + [(connect~y) (loop rest + (append (apply ~connect 'x (cdr c)) + translated) + children)] + [(connect~x) (loop rest + (append (apply ~connect 'y (cdr c)) + translated) + children)] + [(connect~xy) (loop rest + (append (apply ~connect 'r (cdr c)) + translated) + children)] + [(curve) (loop rest + (let ([x1 (cadr c)] + [y1 (caddr c)] + [x2 (cadddr c)] + [y2 (list-ref c 4)] + [xm (list-ref c 5)] + [ym (list-ref c 6)] + [d (if (null? (list-tail c 7)) + 1.0 + (list-ref c 7))]) + (let ([p (if (and d (>= d 0)) + (inexact->exact (floor (* d (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))))) + #f)]) + (if (and (= x1 x2) (= y1 y2)) + translated + (cons `(qbezier ,p ,x1 ,y1 ,xm ,ym ,x2 ,y2) + translated)))) + children)] + [(place) (let ([x (cadr c)] + [y (caddr c)] + [p (cadddr c)]) + (loop rest + (cons + `(put ,x ,y ,(pict-draw p)) + translated) + (cons + (make-child p x y) + children)))] + [else (loop rest (cons c translated) children)]))))) + +(define (cons-picture p commands) + (picture + (pict-width p) (pict-height p) + (cons + `(place 0 0 ,p) + commands))) + +(define black-and-white + (make-parameter #f + (lambda (x) + (and x #t)))) + +(define (colorize p color) + (if (black-and-white) + p + (extend-pict + p 0 0 0 0 0 + `(color ,color ,(pict-draw p))))) + +(define (optimize s) + (let o-loop ([s s][dx 0][dy 0]) + (if (string? s) + s + (let ([tag (car s)]) + (case tag + [(picture) + (list* 'picture (cadr s) (caddr s) + (map optimize (cdddr s)))] + [(color) + (let ([next (caddr s)]) + (if (and (pair? next) (eq? (car next) 'color)) + (optimize next) + (list* 'color (cadr s) + (list 'put dx dy (optimize next)))))] + [(thickness) + (let ([t (cadr s)] + [p (caddr s)]) + (list 'put dx dy + (list 'thickness t + (optimize p))))] + [(put) + (let ([x (cadr s)] + [y (caddr s)] + [next (cadddr s)]) + (if (and (pair? next) (eq? (car next) 'picture)) + ; optmize put-picture to just contents ... + (cons 'begin (map (lambda (s) (o-loop s (+ x dx) (+ y dy))) (cdddr next))) + ; normal + (list 'put (+ x dx) (+ y dy) (optimize next))))] + [(qbezier) + (let ([x1 (list-ref s 2)] + [y1 (list-ref s 3)] + [xm (list-ref s 4)] + [ym (list-ref s 5)] + [x2 (list-ref s 6)] + [y2 (list-ref s 7)] + [p (list-ref s 1)]) + (list 'qbezier p + (+ x1 dx) (+ y1 dy) + (+ xm dx) (+ ym dy) + (+ x2 dx) (+ y2 dy)))] + [(frame) + (list 'frame (optimize (cadr s)))] + [(colorbox) + (list 'colorbox (cadr s) (optimize (caddr s)))] + [(line vector circle circle* make-box oval prog) s] + [else (error 'optimize "bad tag: ~s" tag)]))))) + +(define (fixup-top s) + (cond + [(and (pair? s) (eq? (car s) 'color)) + ;; Drop initial put + (list* 'color (cadr s) (caddr (cdddr s)))] + [(and (pair? s) (eq? (car s) 'put)) + ;; Wrap initial put (from thickness) in a pair of braces + `(local ,(cadddr s))] + [else + ;; Do nothing + s])) + +(define (pict->string s) + (let output ([s (fixup-top (optimize (pict-draw s)))]) + (if (string? s) + s + (let ([tag (car s)]) + (case tag + [(local) + (format "{~a}~n" (output (cadr s)))] + [(begin) + (apply string-append (map output (cdr s)))] + [(picture) + (format "\\begin{picture}(~a,~a)~n~a\\end{picture}~n" + (cadr s) (caddr s) + (apply string-append (map output (cdddr s))))] + [(color) + (format "\\special{color push ~a}~n~a\\special{color pop}~n" + (cadr s) (output (cddr s)))] + [(thickness) + (format "\\~a~a" (cadr s) (output (caddr s)))] + [(put) + (format "\\put(~a,~a){~a}~n" (cadr s) (caddr s) (output (cadddr s)))] + [(qbezier) + (apply format "\\qbezier~a(~a,~a)(~a,~a)(~a,~a)~n" + (if (cadr s) + (format "[~a]" (cadr s)) + "") + (cddr s))] + [(line vector) + (format "\\~a(~a,~a){~a}" tag (cadr s) (caddr s) (cadddr s))] + [(circle) + (format "\\circle{~a}" (cadr s))] + [(circle*) + (format "\\circle*{~a}" (cadr s))] + [(frame) + (format "\\frame{~a}" (output (cadr s)))] + [(colorbox) + (format "\\colorbox{~a}{~a}" (cadr s) (output (caddr s)))] + [(oval) + (format "\\oval(~a,~a)~a" (caddr s) (cadddr s) (cadr s))] + [(make-box) + (format "\\makebox(~a, ~a)[~a]{~a}" + (cadr s) (caddr s) (cadddr s) (car (cddddr s)))] + [(prog) + (error 'pict->string "cannot handle prog pict")] + [else (error 'pict->string "bad tag: ~s" tag)]))))) + +(define (pict->commands s) + (let output ([s (fixup-top (optimize (pict-draw s)))]) + (if (string? s) + (list s) + (let ([tag (car s)]) + (case tag + [(local) + (output (cadr s))] + [(begin) + (apply append (map output (cdr s)))] + [(picture) + (apply append (map output (cdddr s)))] + [(color) + `((with-color ,(cadr s) ,(output (cddr s))))] + [(thickness) + `((with-thickness ,(cadr s) ,(output (caddr s))))] + [(put) + `((offset ,(cadr s) ,(caddr s) ,(output (cadddr s))))] + [(qbezier) + `((bezier ,@(cddr s)))] + [(line vector) + `((,tag ,(cadr s) ,(caddr s) ,(cadddr s)))] + [(circle circle*) + `((,tag ,(cadr s)))] + [(frame) + `((frame ,(output (cadr s))))] + [(colorbox) + `((colorbox ,(cadr s) ,(output (caddr s))))] + [(oval) + `((oval ,(caddr s) ,(cadddr s) ,(cadr s)))] + [(make-box) + `((make-box ,(cadr s) ,(caddr s) ,(cadddr s) ,(car (cddddr s))))] + [(prog) + `((prog ,(cadr s)))] + [else (error 'pict->commands "bad tag: ~s" tag)]))))) + +) diff --git a/collects/texpict/texpicts.ss b/collects/texpict/texpicts.ss new file mode 100644 index 00000000..2031275e --- /dev/null +++ b/collects/texpict/texpicts.ss @@ -0,0 +1,121 @@ + +;; documentation moved to doc.txt + +(define-signature texpict^ + ((struct pict (draw width height ascent descent children)) + (struct child (pict dx dy)) + + read-in-sizes ; string -> void + + using-pict2e-package + + draw-bezier-lines + + output-measure-commands + + tex-series-prefix + serialize-tex-picts + + current-tex-sizer + + black-and-white + + find-lt ; (left & top) ; pict pict-path -> dx dy + find-lc ; (left & vertical center) + find-lb ; (left & bottom) + find-ltl ; (left and top baseline) + find-lbl ; (left and bottom baseline) + find-ct ; (horizontal center & top) + find-cc + find-cb + find-ctl + find-cbl + find-rt + find-rc + find-rb + find-rtl + find-rbl + + launder ; pict -> pict + + blank ; -> pict + ; w h -> pict + ; w h d -> pict + + tex ; string -> pict + text-line ; string -> pict + text-line/phantom ; string string -> pict + tex-paragraph ; w string ['top|'bottom] -> pict + + left-brace ; h -> pict + right-brace ; h -> pict + left-delimit ; str h -> pict + right-delimit ; str h -> pict + middle-delimit ; str h -> pict + top-brace ; w -> pict + bottom-brace ; w -> pict + + clip-descent ; pict -> pict + inset ; pict i -> pict + ; pict hi vi -> pict + ; pict l t r b -> pict + + hline ; w h -> pict + dash-hline ; w h seg-length -> pict ; default seg-length is 5 + vline ; w h -> pict + dash-vline ; w h seg-length -> pict ; default seg-length is 5 + + frame ; pict -> pict + dash-frame ; pict seg-length -> pict ; default seg-length is 5 + oval ; pict -> pict + oval/radius ; pict r -> pict ; r is radius of corners + + big-circle ; diameter -> pict + + thick ; pict -> pict + thin ; pict -> pict + + ghost ; pict -> pict + + record ; pict pict ... -> pict + + vl-append ; d pict ... -> pict ; d units between each picture + vc-append + vr-append + ht-append + hc-append + hb-append + htl-append ; align bottoms of ascents + hbl-append ; align tops of descents (normal text alignment) + + lt-superimpose ; pict ... -> pict + lb-superimpose + lc-superimpose + ltl-superimpose + lbl-superimpose + rt-superimpose + rb-superimpose + rc-superimpose + rtl-superimpose + rbl-superimpose + ct-superimpose + cb-superimpose + cc-superimpose + ctl-superimpose + cbl-superimpose + + table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict + + colorize ; pict color-string -> pict + + picture ; w h command-list -> pict + + cons-picture ; pict command-list -> pict + + prog-picture ; (dx dy -> void) -> pict + + pict->string + + pict->commands + + use-old-connect)) diff --git a/collects/typeset/doc.txt b/collects/typeset/doc.txt new file mode 100644 index 00000000..548786f2 --- /dev/null +++ b/collects/typeset/doc.txt @@ -0,0 +1,106 @@ +_Typeset_ + +This tools provides a typesetting tool embedded into DrScheme. Unlike other +typesetting programs, this one has the full power of a modern programming +language (It only works in DrScheme's Full Scheme / Graphical with +Debugging language level currently). + +The typeset menu provides three options. Each inserts a new editor snip +boxes into DrScheme's main window. The first two insert blue boxes that +contain formatted text. The third inserts a red box whose contents are +Scheme text. These boxes can be nested, ala quasiquote. + +The blue boxes evaluate to their contents, except that any nested red boxes +are evaluated and their results are placed into the blue box. If the red +box evaluates to a value other than a blue box, the value is display'd into +the blue box. + +Technically speaking, the blue boxes evalute to an editor-snip% object, so +any of the methods of an editor snip will work on the objects. Using these +methods is discouraged, except possibly to provide better memory or time +performance. The editor-snip%'s set-tight-text-fit method is called with #t +and it's set-align-top-line method is called with #t. + +The tool also provides several new primitive functions: + + - postscript : (instance editor-snip%) string -> void + + generates postscript for the editor-snip% object and saves it into + the filename named by the second argument. + + - single-bracket : TST -> snip + + produces a snip that looks like its argument, except with square + brackets around it. + + - double-bracket : TST -> snip + + produces a snip that looks like its argument, except with double square + brackets around it. + + - tb-align : ((union 'base 'top 'center 'bottom) TST -> snip) + + if the second argument is not a snip, it just returns the second + argument. If it is a snip, this produces a new snip identical to the + second argument, except that it is aligned according to the first + argument. + + - greek : ((union char string number) -> snip) + + formats it's input in the symbol font, which contains greek letters and + mathemtical symbols. Evaluate this loop to see what is available (note + that the symbol font is the same on all platforms): + + (define (g n) (list n (integer->char n) (greek n))) + + (define (f n) + (cond + [(= n 33) null] + [else + (cons + (g (- n 1)) + (f (- n 1)))])) + + (f 256) + + - sup : (TST TST -> snip) + - sub : (TST TST -> snip) + + aligns the first two arguments as either base/superscript or + base/subscript positioning. The first argument is the base in each + case. + + - ellipses : snip + + This is vertically centered ellipses. It does not really look like + three periods, tho. + + - drawing : (string + (dc<%> -> exact-integer exact-integer exact-integer exact-integer) + (dc<%> exact-integer exact-integer -> void) + -> + snip) + + This is used to make snips that encode arbitrary drawing. The first + argument is name and it must be unique (it is used for copying, pasting + and saving the snip to disk). + + The second argument calculates the width, height, descent, space, + left-hand space and right-hand space of the snip. The last four numbers + are insets into the width and height. The descent is the bottom inset, + the space is the top inset and the left-hand and right-hand space are + the left and right insets. These insets are used when lining up the + snip with it's horizontal (and possibly vertical) neighbors. The dc<%> + is provided for size calculations but should not be drawn into. + + The final argument actually draws the snip into the dc<%>. It should be + drawn at the (x,y) coordinates given by the final argument's second and + third parameters. + + - typeset-size : (union (-> integer) (integer -> void)) + + This is a parameter-like function (not a true parameter) that controls + the size of the rendered font. It defaults to drscheme's font size, as + set in the preferences dialog. + + - position : ... diff --git a/collects/typeset/tool-sig.ss b/collects/typeset/tool-sig.ss new file mode 100644 index 00000000..5e1fdd3d --- /dev/null +++ b/collects/typeset/tool-sig.ss @@ -0,0 +1,22 @@ +(define-signature typeset:utils-input^ + (typeset-size)) + +(define-signature typeset:utils^ + (single-bracket + double-bracket + tb-align + greek + drawing + ellipses + + ;(struct size (width height descent space left right)) + ;(struct pos (x y)) + position + sup sub + postscript + + typeset-size + + arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow)) ;; these should move out + +(require-library "invoke.ss") \ No newline at end of file diff --git a/collects/typeset/tool.ss b/collects/typeset/tool.ss new file mode 100644 index 00000000..7cbbe46e --- /dev/null +++ b/collects/typeset/tool.ss @@ -0,0 +1,345 @@ +(unit/sig () + (import mred^ + framework^ + [drscheme : drscheme:export^] + [zodiac : zodiac:system^]) + +(define read/snips (lambda x (error x))) + +(define (snipize obj) + (if (is-a? obj snip%) + obj + (make-string-snip obj))) + +(define (make-string-snip obj) + (let* ([str (format "~a" obj)] + [sn (make-object string-snip% (string-length str))]) + (send sn insert str (string-length str) 0) + sn)) + +(define void-snip% + (class snip% () + (inherit get-style) + (override + [copy + (lambda () + (let ([ans (make-object void-snip%)]) + (send ans set-style (get-style)) + ans))]) + (sequence (super-init)))) + +(define (make-delta family) + (let ([d (make-object style-delta% 'change-family family)]) + (send d set-size-mult 0) + (send d set-size-add (preferences:get 'drscheme:font-size)) + ;(send d set-delta-foreground "BLACK") + d)) + +(define renderable-editor-snip% + (class editor-snip% (family color) + (inherit get-editor get-style) + + (private + [pen (send the-pen-list find-or-create-pen color 1 'solid)] + [brush (send the-brush-list find-or-create-brush "BLACK" 'transparent)]) + + (inherit get-extent get-inset) + (rename [super-draw draw]) + (override + [draw + (lambda (dc x y left top right bottom dx dy draw-caret) + (let ([bl (box 0)] + [br (box 0)] + [bt (box 0)] + [bb (box 0)] + [bw (box 0)] + [bh (box 0)]) + (get-extent dc x y bw bh #f #f #f #f) + (get-inset bl br bt bb) + (super-draw dc x y left top right bottom dx dy draw-caret) + (let ([old-pen (send dc get-pen)] + [old-brush (send dc get-brush)]) + (send dc set-pen pen) + (send dc set-brush brush) + (send dc draw-rectangle + (+ x (unbox bl)) + (+ y (unbox bt)) + (- (unbox bw) (unbox bl) (unbox br)) + (- (unbox bh) (unbox bt) (unbox bb))) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))]) + + (override + [write + (lambda (stream-out) + (send (get-editor) write-to-file stream-out 0 'eof))]) + (override + [copy + (lambda () + (let ([snip (make-snip)]) + (send snip set-editor (send (get-editor) copy-self)) + (send snip set-style (get-style)) + snip))]) + (public + [make-snip (lambda () (error 'make-snip "abstract method"))]) + + (public + [make-editor + (lambda () + (make-object (drscheme:unit:program-editor-mixin plain-text%) (make-delta family)))]) + + (sequence + (super-init (make-editor) #f)))) + +(define constant-snip% + (class* renderable-editor-snip% (zodiac:expands<%>) (family) + (inherit get-editor) + + (public + [expand + (lambda (obj) + (zodiac:structurize-syntax + `(,replace-in-template + ',family + ;,this + ;,(make-object editor-snip% (get-editor)) + ,(make-object editor-snip% (send (get-editor) copy-self)) + ,@(let loop ([snip (send (get-editor) find-first-snip)]) + (cond + [(not snip) `()] + [(transformable? snip) + `(,snip + . + ,(loop (send snip next)))] + [else (loop (send snip next))]))) + obj))]) + + (public + [get-family (lambda () family)]) + + (override + [write + (lambda (stream-out) + (send stream-out << (symbol->string family)) + (send (get-editor) write-to-file stream-out 0 'eof))] + [make-snip (lambda () (make-object constant-snip% family))]) + + (inherit show-border set-snipclass) + (sequence + (super-init family "BLUE") + (show-border #t) + (set-snipclass constant-snipclass)))) + +(define constant-snipclass% + (class snip-class% () + (override + [read + (lambda (stream-in) + (let* ([family (string->symbol (send stream-in get-string))] + [snip (make-object constant-snip% (if (member family '(roman modern)) + family + 'modern))]) + (send (send snip get-editor) read-from-file stream-in) + snip))]) + (sequence (super-init)))) +(define constant-snipclass (make-object constant-snipclass%)) +(send constant-snipclass set-version 1) +(send constant-snipclass set-classname "robby:constant-snip") +(send (get-the-snip-class-list) add constant-snipclass) + +(define evaluated-snip% + (class* renderable-editor-snip% (zodiac:expands<%>) () + (inherit get-editor) + + (public + [expand + (lambda (obj) + (let ([text (get-editor)]) + (let* ([loc (zodiac:make-location 0 0 0 text)] + [read + (zodiac:read + (gui-utils:read-snips/chars-from-text text 0 (send text last-position)) + loc + #t 1)]) + (zodiac:structurize-syntax + `(,snipize ,(read)) + (zodiac:make-zodiac #f loc loc)))))]) + + +;; MATTHEW +;; cannot do this because the styles information in the saved texts screws up. + (override + [make-editor + (lambda () + (make-object (drscheme:unit:program-editor-mixin (scheme:text-mixin text:basic%))))]) + + (override + [make-snip (lambda () (make-object evaluated-snip%))]) + + (inherit show-border set-snipclass) + (sequence + (super-init 'modern "RED") + (show-border #t) + (set-snipclass evaluated-snipclass)))) + +(define evaluated-snipclass% + (class snip-class% () + (override + [read + (lambda (stream-in) + (let* ([snip (make-object evaluated-snip%)] + [editor (send snip get-editor)]) + (send editor read-from-file stream-in) + snip))]) + (sequence (super-init)))) + +(define evaluated-snipclass (make-object evaluated-snipclass%)) +(send evaluated-snipclass set-version 1) +(send evaluated-snipclass set-classname "robby:evaluated-snip") +(send (get-the-snip-class-list) add evaluated-snipclass) + +(define plain-text% + (class text:keymap% ([delta (make-object style-delta%)]) + (inherit change-style copy-self-to) + (rename [super-after-insert after-insert] + [super-on-insert on-insert]) + (inherit begin-edit-sequence end-edit-sequence) + (override + [copy-self + (lambda () + (let ([t (make-object plain-text% delta)]) + (copy-self-to t) + t))] + [on-insert + (lambda (x y) + (super-on-insert x y) + (begin-edit-sequence))] + [after-insert + (lambda (x y) + (super-after-insert x y) + (change-style delta x (+ x y)) + (end-edit-sequence))]) + (inherit set-styles-sticky) + (sequence + (super-init) + (set-styles-sticky #f)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; EVALUATION ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (transformable? snip) + (or (is-a? snip constant-snip%) + (is-a? snip evaluated-snip%))) + +(define typeset-size + (let ([value (preferences:get 'drscheme:font-size)]) + (case-lambda + [() value] + [(x) + (unless (and (exact? x) + (integer? x) + (> x 0)) + (error 'typeset-size + "expected an exact integer strictly greater than zero")) + (set! value x)]))) + +(define (replace-in-template family template-snip . replacements) + (let* ([delta (make-delta family)] + [_ (begin (send delta set-delta-foreground "BLACK") + (send delta set-size-mult 0) + (send delta set-size-add (typeset-size)))] + [text (make-object plain-text% delta)]) + (let loop ([replacements replacements] + [snip (send (send template-snip get-editor) find-first-snip)]) + (cond + [(not snip) + (unless (null? replacements) + (error 'replace-in-template "found end without doing all replacements: ~s" replacements)) + (void)] + + [(transformable? snip) + (when (null? replacements) + (error 'replace-in-template "found replacable without replacement")) + (let ([replacement (car replacements)] + [pos (send text get-snip-position snip)]) + (send text insert (if (is-a? replacement snip%) + (send replacement copy) + (make-string-snip replacement)) + (send text last-position) (send text last-position)) + (loop (cdr replacements) + (send snip next)))] + + [else + (send text insert (send snip copy) (send text last-position) (send text last-position)) + (loop replacements (send snip next))])) + + (let ([snip (make-object editor-snip% text #f + 0 0 0 0 + 0 0 0 0)]) + (send text hide-caret #t) + (send snip set-tight-text-fit #t) + (send snip set-align-top-line #t) + snip))) + +(define (typeset-frame-extension super%) + (class/d super% args + ((inherit get-editor get-menu-bar get-edit-target-object)) + + (apply super-init args) + + (let* ([mb (get-menu-bar)] + [menu (make-object menu% "Typeset" mb)] + [insert-snip + (lambda (make-obj) + (let ([editor (get-edit-target-object)]) + (when editor + (let loop ([editor editor]) + (let ([focused (send editor get-focus-snip)]) + (if (and focused + (is-a? focused editor-snip%)) + (loop (send focused get-editor)) + (let ([snip (make-obj)]) + (send editor insert snip) + (send editor set-caret-owner snip 'display))))))))]) + (make-object menu-item% "Modern Constant Snip" menu + (lambda (menu evt) + (insert-snip + (lambda () (make-object constant-snip% 'modern)))) + #\m) + (make-object menu-item% "Roman Constant Snip" menu + (lambda (menu evt) + (insert-snip + (lambda () (make-object constant-snip% 'roman)))) + #\r) + (make-object menu-item% "Evaluated Snip" menu + (lambda (menu evt) + (insert-snip + (lambda () (make-object evaluated-snip%)))))) + + (frame:reorder-menus this))) + +(define utils (invoke-unit/sig (require-library "utils.ss" "typeset") + mred^ framework^ + typeset:utils-input^)) + +(define (typeset-rep-extension super-text%) + (class/d super-text% args + ((override reset-console) + (rename [super-reset-console reset-console]) + (inherit user-namespace)) + + (define (reset-console) + (super-reset-console) + (parameterize ([current-namespace user-namespace]) + (global-define-values/invoke-unit/sig typeset:utils^ utils))) + + (apply super-init args))) + +(drscheme:get/extend:extend-unit-frame typeset-frame-extension) +(drscheme:get/extend:extend-interactions-text typeset-rep-extension) + + +) diff --git a/collects/typeset/utils.ss b/collects/typeset/utils.ss new file mode 100644 index 00000000..1ee8ba4c --- /dev/null +++ b/collects/typeset/utils.ss @@ -0,0 +1,957 @@ +(unit/sig () + (import mred^ + framework^ + typeset:utils-input^) + + (define (snipize obj) + (if (is-a? obj snip%) + obj + (make-object string-snip% (format "~a" obj)))) + + (define (snipize/copy obj) + (if (is-a? obj snip%) + (send obj copy) + (make-object string-snip% (format "~a" obj)))) + + (define (set-box/f! b v) (when (box? b) (set-box! b v))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; POSTSCRIPT ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define ps-figure-editor-admin% + (class/d editor-admin% (filename editor) + ((override get-dc + get-max-view + get-view + grab-caret + needs-update + refresh-delayed? + resized + scroll-to + update-cursor)) + + (define delayed? #t) + + (define dc + (let ([ps-setup (make-object ps-setup%)]) + (send ps-setup copy-from (current-ps-setup)) + (send ps-setup set-file filename) + (send ps-setup set-mode 'file) + (parameterize ([current-ps-setup ps-setup]) + (make-object post-script-dc% #f)))) + + (define (get-dc xb yb) + (set-box/f! xb 0) + (set-box/f! yb 0) + dc) + + (define (calc-view xb yb wb hb full?) + (set-box/f! xb 0) + (set-box/f! yb 0) + (let-values ([(w h) (send dc get-size)]) + (set-box/f! wb w) + (set-box/f! hb h))) + (define (get-max-view xb yb wb hb full?) + (calc-view xb yb wb hb full?)) + + (define (get-view xb yb wb hb full?) + (calc-view xb yb wb hb full?)) + + (define (grab-caret domain) + (void)) + (define (needs-update localx localy x y) + (void)) + (define (refresh-delayed?) + delayed?) + (define (resized refresh?) + (when refresh? + (let-values ([(w h) (send dc get-size)]) + (send editor refresh 0 0 w h 'no-caret)))) + + (define (scroll-to localx localy w h refresh? bias) + (when refresh? + (let-values ([(w h) (send dc get-size)]) + (send editor refresh 0 0 w h 'no-caret)))) + (define (update-cursor) (void)) + + (super-init) + + (send dc start-doc (format "Creating ~a" filename)) + (send dc start-page) + + (set! delayed? #t) + (send editor set-admin #f) + (send editor size-cache-invalid) + (send editor set-admin this) + + (set! delayed? #f) + (let-values ([(w h) (send dc get-size)]) + (send editor refresh 0 0 w h 'no-caret)) + (send dc end-page) + (send dc end-doc))) + + (define (postscript snip filename) + (unless (is-a? snip editor-snip%) + (error 'postscript + "expected first argument to be an editor-snip%, got: ~e, other args: ~e" + snip filename)) + (unless (string? filename) + (error 'postscript + "expected second argument to be a string, got: ~e, other args: ~e" + filename + snip)) + (let* ([editor (send snip get-editor)] + [editor-admin (send editor get-admin)]) + (make-object ps-figure-editor-admin% filename editor) + (send editor set-admin editor-admin))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; ALIGNMENT ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (para-align alignment) + (lambda (snip) + (if (is-a? snip editor-snip%) + (let* ([new (send snip copy)] + [new-e (send new get-editor)]) + (when (is-a? new-e text%) + (let loop ([pn (+ (send new-e last-paragraph) 1)]) + (unless (zero? pn) + (send new-e set-paragraph-alignment (- pn 1) alignment) + (loop (- pn 1))))) + new) + snip))) + + (define lr-align-center (para-align 'center)) + (define lr-align-left (para-align 'left)) + (define lr-align-right (para-align 'right)) + + (define (tb-align alignment snip) + (if (is-a? snip editor-snip%) + (let* ([new (send snip copy)] + [new-e (send new get-editor)]) + (when (is-a? new-e text%) + (let ([sd (make-object style-delta%)]) + (send sd set-alignment-on alignment) + (send new-e change-style sd 0 (send new-e last-position)))) + new) + snip)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; BRACKETS ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define bracket-snip% + (class editor-snip% (between-snip left-margin top-margin right-margin bottom-margin) + (inherit get-editor) + (override + [write + (lambda (p) + (send (get-editor) write-to-file p))]) + (public + [height #f] + [width #f]) + (rename [super-get-extent get-extent] + [super-draw draw]) + (override + [get-extent + (lambda (dc x y w h descent space lspace rspace) + (for-each (lambda (x) (when (and (box? x) (> 0 (unbox x))) (set-box! x 0))) + (list w h descent space lspace rspace)) + (super-get-extent dc x y w h descent space lspace rspace) + + ;(when (box? descent) (set-box! descent (+ (unbox descent) bottom-margin))) + ;(when (box? space) (set-box! space (+ (unbox space) top-margin))) + ;(when (box? lspace) (set-box! lspace (+ (unbox lspace) left-margin))) + ;(when (box? rspace) (set-box! rspace (+ (unbox rspace) right-margin))) + + (when (box? h) + (set! height (unbox h))) + (when (box? w) + (set! width (unbox w))))]) + + (inherit get-style) + (inherit set-tight-text-fit) + (sequence + (let ([text (make-object text:basic%)]) + (super-init text #f + left-margin top-margin right-margin bottom-margin + 0 0 0 0) + (set-tight-text-fit #t) + (send text insert (send between-snip copy)))))) + + (define double-bracket-snip% + (class* bracket-snip% () (between-snip) + (inherit get-style) + (override + [copy + (lambda () + (let ([snip (make-object double-bracket-snip% between-snip)]) + (send snip set-style (get-style)) + snip))]) + + (inherit height width) + (rename [super-draw draw]) + (override + [draw + (lambda (dc x y left top right bottom dx dy draw-caret) + (let ([vertical-line + (lambda (x) + (send dc draw-line x y x (+ y height -1)))] + [horizontal-lines + (lambda (x) + (send dc draw-line x y (+ x 5) y) + (send dc draw-line x (+ y height -1) (+ x 5) (+ y height -1)))] + [old-pen (send dc get-pen)]) + + (when (is-a? dc post-script-dc%) + (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) + + (horizontal-lines x) + (horizontal-lines (+ x width -6)) + (vertical-line x) + (vertical-line (+ x width -1)) + (vertical-line (+ x 3)) + (vertical-line (+ x width -4)) + + (send dc set-pen old-pen)) + (super-draw dc x y left top right bottom dx dy draw-caret))]) + (inherit set-snipclass) + (sequence + (super-init between-snip 6 1 6 1) + (set-snipclass double-bracket-snipclass)))) + + (define single-bracket-snip% + (class* bracket-snip% () (between-snip) + (inherit get-style) + (override + [copy + (lambda () + (let ([snip (make-object single-bracket-snip% between-snip)]) + (send snip set-style (get-style)) + snip))]) + + (inherit height width) + (rename [super-draw draw]) + (override + [draw + (lambda (dc x y left top right bottom dx dy draw-caret) + (let ([vertical-line + (lambda (x) + (send dc draw-line x y x (+ y height -1)))] + [horizontal-lines + (lambda (x) + (send dc draw-line x y (+ x 3) y) + (send dc draw-line x (+ y height -1) (+ x 3) (+ y height -1)))] + [old-pen (send dc get-pen)]) + + (when (is-a? dc post-script-dc%) + (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) + + (horizontal-lines (+ x 1)) + (horizontal-lines (+ x width -5)) + (vertical-line (+ x 1)) + (vertical-line (+ x width -2)) + (send dc set-pen old-pen)) + (super-draw dc x y left top right bottom dx dy draw-caret))]) + (inherit set-snipclass) + (sequence + (super-init between-snip 4 1 4 1) + (set-snipclass single-bracket-snipclass)))) + + (define bracket-snipclass% + (class snip-class% (%) + (override + [read + (lambda (p) + (let* ([bs (make-object % (make-object snip%))] + [t (send bs get-editor)]) + (send t read-from-file p)))]) + (sequence (super-init)))) + + (define single-bracket-snipclass (make-object bracket-snipclass% single-bracket-snip%)) + (send single-bracket-snipclass set-version 1) + (send single-bracket-snipclass set-classname "robby:single-bracket") + (send (get-the-snip-class-list) add single-bracket-snipclass) + + (define double-bracket-snipclass (make-object bracket-snipclass% double-bracket-snip%)) + (send double-bracket-snipclass set-version 1) + (send double-bracket-snipclass set-classname "robby:double-bracket") + (send (get-the-snip-class-list) add double-bracket-snipclass) + + ;; bracket : snip -> snip + ;; adds double square brackets around the snip + (define (double-bracket snip) + (make-object double-bracket-snip% (snipize snip))) + + (define (single-bracket snip) + (make-object single-bracket-snip% (snipize snip))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; GREEK ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; greek : (union char string number) -> snip + ;; renders the alphabetic characters in the argument into greek letters + (define greek + (letrec ([snipclass + (make-object (class snip-class% () + (override + [read + (lambda (stream-in) + (make-object greek-snip% + (send stream-in get-string) + (send stream-in get-number)))]) + (sequence (super-init))))] + [greek-snip% + (class snip% (str size) + (inherit get-style) + (private + [font + (send the-font-list find-or-create-font + size 'symbol 'normal 'normal #f)]) + (override + [write + (lambda (stream-out) + (send stream-out << str) + (send stream-out << size))] + [get-extent + (lambda (dc x y wb hb descentb spaceb lspace rspace) + (let-values ([(width height descent ascent) + (send dc get-text-extent str font)]) + (set-box/f! wb (max 0 width)) + (set-box/f! hb (max 0 height)) + (set-box/f! descentb (max 0 descent)) + (set-box/f! spaceb (max 0 ascent)) + (set-box/f! lspace 0) + (set-box/f! rspace 0)))] + [draw + (lambda (dc x y left top right bottom dx dy draw-caret) + (let ([old-font (send dc get-font)]) + (send dc set-font font) + (send dc draw-text str x y) + (send dc set-font old-font)))] + [copy + (lambda () + (let ([snip (make-object greek-snip% str size)]) + (send snip set-style (get-style)) + snip))]) + (inherit set-snipclass) + (sequence + (super-init) + (set-snipclass snipclass)))]) + + (send snipclass set-version 1) + (send snipclass set-classname "robby:greek") + (send (get-the-snip-class-list) add snipclass) + (lambda (in) + (let ([str (cond + [(string? in) in] + [(char? in) (string in)] + [(number? in) (string (integer->char in))])]) + (make-object greek-snip% str (typeset-size)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; DRAWINGS ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; drawing : ((dc -> exact-int exact-int exact-int) (dc exact-int + ;; exact-int -> void) -> snip) get-extent determines the amount of + ;; space the new snip needs. The six results are the width, height, + ;; descent, ascent, lspace and rspace. (The descent and space do not + ;; actually add space to the snip, they only helps to determine + ;; where to lineup adjacent snips.) draw actually draws the snip. + (define (drawing name eextent ddraw) + (unless (string? name) + (error + 'draw + "expected string as first argument, got: ~e; other args: ~e ~e" + name eextent ddraw)) + (unless (and (procedure? eextent) (procedure? ddraw)) + (error + 'draw + "expected procedures as second and third arguments, got: ~e ~e; first args: ~e" + eextent ddraw name)) + (letrec ([drawing% + (class snip% () + (inherit get-style) + (override + [write + (lambda (stream-out) + (send stream-out put name))] + [copy + (lambda () + (let ([ans (make-object drawing%)]) + (send ans set-style (get-style)) + ans))] + [draw + (lambda (dc x y left top right bottom dx dy draw-caret) + (ddraw dc x y))] + [get-extent + (lambda (dc x y width-b height-b descent-b space-b lspace-b rspace-b) + (let ([old-font (send dc get-font)]) + (send dc set-font (send (get-style) get-font)) + (let-values ([(width height descent space lspace rspace) (eextent dc)]) + (set-box/f! width-b width) + (set-box/f! height-b height) + (set-box/f! descent-b descent) + (set-box/f! space-b space) + (set-box/f! lspace-b lspace) + (set-box/f! rspace-b rspace)) + (send dc set-font old-font)))]) + (inherit set-snipclass) + (sequence + (super-init) + (set-snipclass drawing-snipclass)))]) + (send drawing-snipclass add-drawing name drawing%) + (make-object drawing%))) + + (define drawing-snipclass + (make-object (class/d snip-class% () + ((override read) + (public add-drawing)) + + (define drawing-table null) + + (define (add-drawing name class%) + (let ([binding (assoc name drawing-table)]) + (if binding + (set-car! (cdr binding) class%) + (set! drawing-table (cons (list name class%) drawing-table))))) + + (define (read stream-in) + (let* ([name (send stream-in get-string)] + [class (assoc name drawing-table)]) + (if class + (make-object (cadr class)) + (let* ([bad-bitmap (make-object bitmap% 10 10 #t)] + [bdc (make-object bitmap-dc% bad-bitmap)]) + (send bdc clear) + (send bdc draw-rectangle 0 0 10 10) + (send bdc draw-line 0 0 10 10) + (send bdc draw-line 10 0 0 10) + (send bdc set-bitmap #f) + (make-object image-snip% bad-bitmap))))) + (super-init)))) + (send drawing-snipclass set-version 1) + (send drawing-snipclass set-classname "robby:drawing") + (send (get-the-snip-class-list) add drawing-snipclass) + + (define ellipses + (let* ([margin 2] + [get-w/h/d/s/l/r + (lambda (dc) + (let ([old-font (send dc get-font)]) + (send dc set-font (send the-font-list find-or-create-font (typeset-size) + 'roman 'normal 'normal #f)) + (let-values ([(width height descent space) (send dc get-text-extent "a")]) + (begin0 (values (+ margin (* 3 width) margin) height descent space margin margin) + (send dc set-font old-font)))))]) + (drawing "robby:ellipses" + get-w/h/d/s/l/r + (lambda (dc x y) + (let*-values ([(w h d s _1 _2) (get-w/h/d/s/l/r dc)] + [(yp) (+ y s (floor (+ 1/2 (/ (- h s d) 2))))] + [(l) (+ x margin)] + [(r) (+ x w (- margin))] + [(ellipse-size) 2/3] + [(draw-dot) + (lambda (x y) + (if (is-a? dc post-script-dc%) + (send dc draw-ellipse + (- x (/ ellipse-size 2)) (- y (/ ellipse-size 2)) + ellipse-size ellipse-size) + (send dc draw-point x y)))] + [(old-pen) (send dc get-pen)] + [(old-brush) (send dc get-brush)]) + ;(send dc draw-rectangle x y w h) + ;(send dc draw-rectangle x (+ y s) w (- h d s)) + + (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush "BLACK" 'solid)) + + (draw-dot l yp) + (draw-dot (/ (+ l r) 2) yp) + (draw-dot r yp) + + (send dc set-brush old-brush) + (send dc set-pen old-pen)))))) + + (define-values (arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow) + (let* ([arrow/letter-space 1] + [arrow-height 6] + [get-w/h/d/s/l/r + (lambda (descender?) + (lambda (dc) + (let*-values ([(width height descent space) (send dc get-text-extent "bg")] + [(cap-size) (- height space descent)] + [(text-height) (- height (if descender? 0 descent))] + [(arrow-space) (- (+ text-height arrow/letter-space) + (- (/ cap-size 2) (/ arrow-height 2)))] + [(total-arrow-height) (+ cap-size arrow-space)]) + (values (* width 2) + total-arrow-height + 0 + arrow-space + 0 + 0))))] + [draw-arrow + (lambda (dc x y descender?) + (let*-values ([(w h d s _1 _2) ((get-w/h/d/s/l/r descender?) dc)] + [(bgw bgh bgd bgs) (send dc get-text-extent "bg")] + [(text-height) (- bgh (if descender? 0 bgd))] + [(cap-size) (- h d s)]) + + ;(send dc draw-rectangle x y w h) + ;(send dc draw-rectangle x (+ y s) w (- h d s)) + + (let* ([x1 (+ x w)] + [y1 (+ y (- h (/ cap-size 2)))] + [x2 (- x1 4)] + [y2 (- y1 3)] + [x3 x2] + [y3 (+ y1 3)] + [old-pen (send dc get-pen)]) + + (when (is-a? dc post-script-dc%) + (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) + + (send dc draw-line x2 y1 x y1) + + (send dc draw-line x1 y1 x2 y2) + (send dc draw-line x2 y2 x3 y3) + (send dc draw-line x3 y3 x1 y1) + + (send dc set-pen old-pen))))] + + [draw-text + (lambda (dc x y text descender? set-font?) + (let-values ([(w h d s _1 _2) ((get-w/h/d/s/l/r descender?) dc)] + [(bw bh bd bs) (send dc get-text-extent text)] + [(old-font) (send dc get-font)]) + (when set-font? + (send dc set-font (send the-font-list find-or-create-font (typeset-size) + 'roman 'normal 'normal #f))) + (send dc draw-text text (floor (+ x (- (/ w 2) (/ bw 2)))) y) + (send dc set-font old-font)))] + + [arrow + (drawing "robby:arrow" + (get-w/h/d/s/l/r #t) + (lambda (dc x y) (draw-arrow dc x y #t)))] + [b-arrow + (drawing "robby:b-arrow" + (get-w/h/d/s/l/r #f) + (lambda (dc x y) + (draw-text dc x y "b" #f #t) + (draw-arrow dc x y #f)))] + [g-arrow + (drawing "robby:g-arrow" + (get-w/h/d/s/l/r #t) + (lambda (dc x y) + (draw-text dc x y "g" #t #t) + (draw-arrow dc x y #t)))] + [bg-arrow + (drawing "robby:bg-arrow" + (get-w/h/d/s/l/r #t) + (lambda (dc x y) + (draw-text dc x y "bg" #t #t) + (draw-arrow dc x y #t)))] + [checked-arrow + (drawing "robby:checked-arrow" + (get-w/h/d/s/l/r #f) + (lambda (dc x y) + (let ([old-font (send dc get-font)]) + (send dc set-font (send the-font-list + find-or-create-font + (typeset-size) + 'symbol + (send old-font get-style) + (send old-font get-weight) + (send old-font get-underlined))) + (draw-text dc x y (string (integer->char 214)) #f #f) + (send dc set-font old-font) + (draw-arrow dc x y #f))))] + [blank-arrow + (drawing "robby:blank-arrow" + (get-w/h/d/s/l/r #f) + (lambda (dc x y) + (void)))]) + (values arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; SUB/SUPERSCRIPT ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-struct size (width height descent space left right)) + (define-struct pos (x y)) + + (define position-admin% + (class/d snip-admin% (position-snip calc-positions snips) + ((public get-sizes get-poss) + (override get-dc get-editor + get-view get-view-size + needs-update + recounted release-snip + resized + scroll-to + set-caret-owner + update-cursor)) + + (define sizes (map (lambda (snip) (make-size 0 0 0 0 0 0)) snips)) + (define poss (map (lambda (snip) (make-pos 0 0)) snips)) + + (define (get-sizes) + (update-sizes/poss) + sizes) + + (define (get-poss) + (update-sizes/poss) + poss) + + (define (update-sizes/poss) + (with-editor + (lambda (editor) + (let ([dc (send editor get-dc)]) + (when dc + (set! sizes + (map + (lambda (snip) + (let ([bwb (box 0)] + [bhb (box 0)] + [bdb (box 0)] + [bsb (box 0)] + [blb (box 0)] + [brb (box 0)] + [xb (box 0)] + [yb (box 0)]) + ;(send editor get-snip-location position-snip xb yb) + (send snip get-extent dc (unbox xb) (unbox yb) bwb bhb bdb bsb blb brb) + (make-size (unbox bwb) + (unbox bhb) + (unbox bdb) + (unbox bsb) + (unbox blb) + (unbox brb)))) + snips)) + (set! poss (calc-positions sizes))))))) + + (define (with-editor f) + (let ([admin (send position-snip get-admin)]) + (if admin + (let ([editor (send admin get-editor)]) + (if editor + (f editor) + #f)) + #f))) + (define (with-editor-admin f) + (with-editor + (lambda (editor) + (let ([admin (send editor get-admin)]) + (if admin + (f admin) + #f))))) + + (define (get-dc) + (with-editor (lambda (editor) (send editor get-dc)))) + (define (get-editor) (with-editor (lambda (x) x))) + (define (get-view xb yb wb hb wanted-snip) + (for-each (lambda (b) (set-box/f! b 10)) (list xb yb wb hb)) + (with-editor + (lambda (editor) + (if wanted-snip + (begin + (update-sizes/poss) + (let loop ([snips snips] + [sizes sizes] + [poss poss]) + (cond + [(null? snips) (void)] + [else + (let ([snip (car snips)] + [size (car sizes)] + [pos (car poss)]) + (if (eq? wanted-snip snip) + (begin + (set-box/f! xb (pos-x pos)) + (set-box/f! yb (pos-y pos)) + (set-box/f! wb (size-width size)) + (set-box/f! hb (size-height size))) + (loop (cdr snips) + (cdr sizes) + (cdr poss))))]))) + (send editor get-view xb yb wb hb wanted-snip)))) + (void)) + + (define (get-view-size wb hb) + (set-box/f! wb 10) + (set-box/f! hb 10) + (with-editor + (lambda (editor) + (send editor get-view #f #f wb hb position-snip)))) + + (define (needs-update wanted-snip localx localy w h) + (with-editor-admin + (lambda (admin) + (update-sizes/poss) + (let-values ([(thisx thisy) + (let loop ([snips snips] + [poss poss]) + (cond + [(null? snips) (values 0 0)] + [else (let ([snip (car snips)] + [pos (car poss)]) + (if (eq? wanted-snip snip) + (values (pos-x pos) + (pos-y pos)) + (loop (cdr snips) + (cdr poss))))]))]) + (send admin needs-update position-snip thisx thisy w h))))) + + (define (refresh-snip wanted-snip) + (with-editor + (lambda (editor) + (let ([dc (send editor get-dc)]) + (when dc + (update-sizes/poss) + (let loop ([snips snips] + [sizes sizes]) + (cond + [(null? snips) (void)] + [else + (let ([snip (car snips)] + [size (car sizes)]) + (if (eq? snip wanted-snip) + (needs-update snip 0 0 (size-width size) (size-height size)) + (loop (cdr snips))))]))))))) + + (define (recounted snip update-now?) + (when update-now? + (refresh-snip snip))) + + (define (release-snip snip) #f) + + (define (resized snip refresh?) + (update-sizes/poss) + (when refresh? + (refresh-snip snip))) + + (define (scroll-to wanted-snip localx localy w h refresh? bias) + (with-editor-admin + (lambda (admin) + (let-values ([(thisx thisy) + (let loop ([snips snips] + [poss poss]) + (cond + [(null? snips) (values 0 0)] + [else (let ([snip (car snips)] + [pos (car poss)]) + (if (eq? wanted-snip snip) + (values (pos-x pos) + (pos-y pos)) + (loop (cdr snips) + (cdr poss))))]))]) + (send admin scroll-to thisx thisy w h refresh? bias))))) + + (define (set-caret-owner snip domain) + (void)) + + (define (update-cursor) + (with-editor-admin + (lambda (admin) + (send admin update-cursor)))) + + (super-init) + (for-each (lambda (snip) (send snip set-admin this)) snips))) + + (define position-snip% + (class/d snip% (position-snipclass calc-positions calc-size _snips) + ((inherit set-snipclass get-style) + (override get-extent draw copy write)) + + (define snips (map (lambda (snip) (send snip copy)) _snips)) + + (define (write p) + (send p << (length snips)) + (for-each (lambda (snip) + (send p << (send (send snip get-snipclass) get-classname)) + (send snip write p)) + snips)) + + (define (copy) + (let ([snip (make-object position-snip% + position-snipclass + calc-positions + calc-size + snips)]) + (send snip set-style (get-style)) + snip)) + + (define (get-extent dc x y wb hb db sb lb rb) + (let ([sizes (send admin get-sizes)]) + (let ([size (calc-size sizes)]) + (set-box/f! wb (size-width size)) + (set-box/f! hb (size-height size)) + (set-box/f! db (size-descent size)) + (set-box/f! sb (size-space size)) + (set-box/f! lb (size-left size)) + (set-box/f! rb (size-right size))))) + + (define (draw dc x y left top right bottom dx dy draw-caret) + (let ([positions (calc-positions (send admin get-sizes))]) + (for-each + (lambda (snip pos) + (send snip draw dc + (+ x (pos-x pos)) + (+ y (pos-y pos)) + left top right bottom dx dy draw-caret)) + snips + positions))) + + (super-init) + + (define admin (make-object position-admin% this calc-positions snips)) + (set-snipclass position-snipclass))) + + (define position-snipclass% + (class/d snip-class% (calc-positions calc-size) + ((override read)) + + (define (read f) + (define (get-next) + (let* ([classname (send f get-string)] + [snipclass (send (get-the-snip-class-list) find classname)]) + (send snipclass read f))) + + (make-object position-snip% + this + calc-positions + calc-size + (let loop ([n (send f get-exact)]) + (cond + [(<= n 0) null] + [else (cons (get-next) (loop (- n 1)))])))) + + (super-init))) + + (define (position calc-positions calc-size name) + (define position-snipclass (make-object position-snipclass% calc-positions calc-size)) + (send position-snipclass set-classname name) + (send position-snipclass set-version 1) + (send (get-the-snip-class-list) add position-snipclass) + + (lambda (snips) + (make-object position-snip% position-snipclass calc-positions calc-size snips))) + + (define sup + (let ([make-sup + (position + (lambda (sizes) + (let ([base (car sizes)] + [pow (cadr sizes)]) + (list (make-pos + 0 + (- (max (/ (size-height pow) 2) (size-space base)) + (size-space base))) + (make-pos + (size-width base) + (max 0 (- (size-space base) (/ (size-height pow) 2))))))) + (lambda (sizes) + (let ([base (car sizes)] + [pow (cadr sizes)]) + (make-size + (+ (size-width base) (size-width pow)) + (+ (- (size-height base) (size-space base)) (max (size-space base) (floor (/ (size-height pow) 2)))) + (size-descent base) + (max (size-space base) (floor (/ (size-height pow) 2))) + (size-left base) + (size-right pow)))) + "robby:sup")]) + (lambda (base pow) + (make-sup + (list (snipize/copy base) + (snipize/copy pow)))))) + + (define sub + (let ([make-sub + (position + (lambda (sizes) + (let ([base (car sizes)] + [sub (cadr sizes)]) + (list (make-pos 0 0) + (make-pos + (size-width base) + (- (size-height base) + (size-descent base) + (floor (/ (size-height sub) 2))))))) + (lambda (sizes) + (let ([base (car sizes)] + [sub (cadr sizes)]) + (make-size + (+ (size-width base) (size-width sub)) + (+ (- (size-height base) (size-descent base)) (max (size-descent base) (floor (/ (size-height sub) 2)))) + (max (size-descent base) (floor (/ (size-height sub) 2))) + (size-space base) + (size-left base) + (size-right sub)))) + "robby:sub")]) + (lambda (base sub) + (make-sub + (list (snipize/copy base) + (snipize/copy sub)))))) + + (unit/sig typeset:utils^ + (import) + (rename (-single-bracket single-bracket) + (-double-bracket double-bracket) + (-tb-align tb-align) + (-greek greek) + (-drawing drawing) + (-ellipses ellipses) + + (-position position) + (-sup sup) (-sub sub) + + (-postscript postscript) + + (-arrow arrow) (-b-arrow b-arrow) + (-g-arrow g-arrow) (-bg-arrow bg-arrow) + (-checked-arrow checked-arrow) + (-blank-arrow blank-arrow) + (-typeset-size typeset-size)) + + (define -single-bracket single-bracket) + (define -double-bracket double-bracket) + (define -tb-align tb-align) + (define -greek greek) + (define -drawing drawing) + (define -ellipses ellipses) + + (define -position position) + (define -sup sup) + (define -sub sub) + + (define -postscript postscript) + + (define -arrow arrow) + (define -b-arrow b-arrow) + (define -g-arrow g-arrow) + (define -bg-arrow bg-arrow) + (define -checked-arrow checked-arrow) + (define -blank-arrow blank-arrow) + + (define -typeset-size typeset-size))) \ No newline at end of file diff --git a/collects/userspce/advancedr.ss b/collects/userspce/advancedr.ss new file mode 100644 index 00000000..0aa5dc6d --- /dev/null +++ b/collects/userspce/advancedr.ss @@ -0,0 +1,13 @@ +(compound-unit/sig + (import) + (link [core : mzlib:core-flat^ ((require-library "coreflatr.ss"))] + [turtles : turtle^ ((require-library "turtler.ss" "graphics") + (core : mzlib:function^))] + [posn : ((struct posn (x y))) + ((unit/sig ((struct posn (x y))) + (import) + (define-struct posn (x y))))]) + (export + (open core) + (open turtles) + (open posn))) diff --git a/collects/userspce/basis.ss b/collects/userspce/basis.ss new file mode 100644 index 00000000..30868e6b --- /dev/null +++ b/collects/userspce/basis.ss @@ -0,0 +1,28 @@ +(compound-unit/sig + (import [import : plt:basis-import^] + [params : plt:userspace:params^] + [zodiac : zodiac:system^] + [zodiac:interface : drscheme:interface^] + [aries : plt:aries^] + [mzlib:print-convert : mzlib:print-convert^] + [mzlib:pretty-print : mzlib:pretty-print^] + [mzlib:function : mzlib:function^]) + (link + [init-params : plt:init-params^ ((require-relative-library "init-paramr.ss") + import + init-namespace + params + zodiac + zodiac:interface + aries + mzlib:print-convert + mzlib:pretty-print + mzlib:function)] + [init-namespace : plt:init-namespace^ ((require-relative-library "init-namespacer.ss") + import + init-params + mzlib:function)]) + (export + (open init-params) + (open init-namespace))) + diff --git a/collects/userspce/doc.txt b/collects/userspce/doc.txt new file mode 100644 index 00000000..e32b4c91 --- /dev/null +++ b/collects/userspce/doc.txt @@ -0,0 +1,31 @@ +_Userspace_ libraries implement the common functionality +between DrScheme and DrScheme Jr. + +The libraries _beginner.ss_, _intermediate.ss_, and _advanced.ss_ +implement the additional function definitions that appear in the +initial namespace in the respective language levels. The other +language levels do not have any additional function definitions beyond +what is in the namespace automatically. + +- beginner.ss adds: + - mzlib's core libraries + - simple-draw.ss + - posn struture, without mutators + +- intermediate.ss adds exactly what beginner.ss does + +- advanced.ss adds: + - mzlib's core libraries + - the turtles, from turtle.ss in the graphics library, but only if + the namespace already contains mred@ + - posn struture, including mutators + +Each of the beginner.ss, intermediate.ss, and advanced.ss and +libraries returns a procedure that installs the corresponding bindings +into the current namespace. + +The file _advancedr.ss_ contains a unit that exports all of the defintions +in advanced.ss. + +The _simple-draw.ss_ library implements a simple drawing +library on top of sixlib. It uses _error.ss_. diff --git a/collects/userspce/errorr.ss b/collects/userspce/errorr.ss new file mode 100644 index 00000000..fad49200 --- /dev/null +++ b/collects/userspce/errorr.ss @@ -0,0 +1,22 @@ +(unit/sig userspace:error^ + (import) + + ;; check-arg : sym bool str str TST -> void + (define (check-arg pname condition expected arg-posn given) + (unless condition + (error pname "expected <~a> as ~a argument, given: ~e" expected arg-posn given))) + + ;; check-arity : sym num (list-of TST) -> void + (define (check-arity name arg# args) + (if (>= (length args) arg#) + (void) + (error name "expects at least ~a arguments, given ~e" arg# (length args)))) + + ;; check-proc : sym (... *->* ...) num (union sym str) (union sym str) -> void + (define (check-proc proc f exp-arity arg# arg-err) + (unless (procedure? f) + (error proc "procedure expected as ~s argument; given ~e" arg# f)) + (unless (and (number? (arity f)) (= (arity f) exp-arity)) + (error proc + "procedure of ~a expected as ~s argument; given procedure of ~s args" + arg-err arg# (arity f))))) \ No newline at end of file diff --git a/collects/userspce/errors.ss b/collects/userspce/errors.ss new file mode 100644 index 00000000..b177aac5 --- /dev/null +++ b/collects/userspce/errors.ss @@ -0,0 +1 @@ +(define-signature userspace:error^ (check-arg check-arity check-proc)) diff --git a/collects/userspce/info.ss b/collects/userspce/info.ss new file mode 100644 index 00000000..c558c71e --- /dev/null +++ b/collects/userspce/info.ss @@ -0,0 +1,20 @@ +(let ([userspace-info + (lambda (what failure) + (case what + [(name) "Userspace"] + [(compile-prefix) + '(begin + (require-library "refer.ss") + (require-library "coreflats.ss") + (when (with-handlers ([void (lambda (x) #f)]) + (collection-path "mred")) + (require-library "turtles.ss" "graphics") + (require-library "sig.ss" "mred")) + (require-library "errors.ss" "userspce") + (require-library "params.ss" "userspce") + (require-library "sig.ss" "userspce"))] + [(compile-omit-files) (list "sig.ss" "errors.ss" "params.ss" "ricedefs.ss" + "launcher-bootstrap.ss")] + [(compile-elaboration-zos) (list "sig.ss")] + [else (failure)]))]) + userspace-info) diff --git a/collects/userspce/init-namespacer.ss b/collects/userspce/init-namespacer.ss new file mode 100644 index 00000000..4022755f --- /dev/null +++ b/collects/userspce/init-namespacer.ss @@ -0,0 +1,155 @@ +(unit/sig plt:init-namespace^ + (import plt:basis-import^ + [init-params : plt:init-params^] + mzlib:function^) + + (define (exploded->flattened exploded) + (let ([sig exploded]) + (let loop ([l (vector->list sig)][r null]) + (cond + [(null? l) r] + [(symbol? (car l)) (loop (cdr l) (cons (car l) r))] + [else (let ([sub (loop (vector->list (cadr l)) null)] + [prefix (string-append (symbol->string (car l)) ":")]) + (loop (cdr l) + (append + (map (lambda (s) + (string->symbol + (string-append + prefix + (symbol->string s)))) + sub))))])))) + + (define (build-gdvs exploded) + (let ([flattened (exploded->flattened exploded)]) + (map + (lambda (x) `(global-defined-value ',x ,x)) + flattened))) + + (define core-flat@ (require-library-unit/sig "coreflatr.ss")) + + ;; build-single-teachpack-unit : string -> (union #f (unit () X)) + (define (build-single-teachpack-unit v) + (with-handlers + ([(lambda (x) #t) + (lambda (x) + (invalid-teachpack (exn-message x)) + #f)]) + (let ([new-unit (parameterize ([read-case-sensitive #t]) + (load/cd v))]) + (if (unit/sig? new-unit) + ; Put the unit into a procedure that invokes it into + ; the current namespace + (let* ([signature + (exploded->flattened (unit-with-signature-exports new-unit))]) + (eval + `(unit/sig () + (import plt:userspace^) + (with-handlers ([(lambda (x) #t) + (lambda (x) + ((error-display-handler) + (format + "Invalid Teachpack: ~a~n~a" + ,v + (if (exn? x) + (exn-message x) + x))))]) + (global-define-values/invoke-unit/sig + ,signature + ,new-unit + #f + plt:userspace^))))) + (begin + (invalid-teachpack + (format "loading Teachpack file does not result in a unit/sig, got: ~e" + new-unit)) + #f))))) + + ;; build-namespace-thunk : (listof string) -> (union #f (list (union 'mz 'mr) (-> void))) + ;; accepts a filename and returns a thunk that invokes the corresponding teachpack and + ;; a symbol indicating if this is a mzscheme teachpack or a mred teachpack. + (define (build-namespace-thunk v) + (unless (and (list? v) + (andmap string? v)) + (error 'build-teachpack-thunk "expected a list of strings, got: ~e" v)) + (let* ([tagn 0] + [link-clauses + (let loop ([units v] + [link-clauses null]) + (cond + [(null? units) (reverse link-clauses)] + [else + (let ([unit (build-single-teachpack-unit (car units))]) + (if unit + (begin + (set! tagn (+ tagn 1)) + (loop (cdr units) + (cons + `[,(string->symbol (format "teachpack~a" tagn)) : () + (,unit userspace)] + link-clauses))) + (loop (cdr units) + link-clauses)))]))] + [cu + (eval + `(compound-unit/sig + (import) + (link + ,@(list* + `[userspace + : plt:userspace^ + (,(if (defined? 'mred@) + `(compound-unit/sig + (import) + (link [core : mzlib:core-flat^ (,core-flat@)] + [mred : mred^ (,(global-defined-value 'mred@))] + [turtles : turtle^ ((require-library "turtler.ss" "graphics") + (core : mzlib:function^))] + [posn : ((struct posn (x y))) + ((unit/sig ((struct posn (x y))) + (import) + (define-struct posn (x y))))]) + (export (open core) + (open mred) + (open posn) + (open turtles))) + `(compound-unit/sig + (import) + (link [core : mzlib:core-flat^ (,core-flat@)] + [posn : ((struct posn (x y))) + ((unit/sig ((struct posn (x y))) + (import) + (define-struct posn (x y))))]) + (export (open core) + (open posn)))))] + `[language-specific-additions + : () + ((unit/sig () + (import plt:userspace^) + + (cond + [(,init-params:beginner-language? (,init-params:current-setting)) + ,@(build-gdvs (signature->symbols plt:beginner-extras^))] + [(,init-params:intermediate-language? (,init-params:current-setting)) + ,@(build-gdvs (signature->symbols plt:intermediate-extras^))] + [(,init-params:advanced-language? (,init-params:current-setting)) + ,@(build-gdvs (signature->symbols plt:advanced-extras^))] + [(,init-params:full-language? (,init-params:current-setting)) (void)])) + userspace)] + + link-clauses)) + (export)))]) + (lambda () + (invoke-unit/sig + cu)))) + + (define (teachpack-ok? x) + (if (build-single-teachpack-unit x) + #t + #f)) + + (define namespace-thunk void) + (define init-namespace (lambda () (namespace-thunk))) + + (define (teachpack-changed v) + (set! namespace-thunk (build-namespace-thunk v)))) diff --git a/collects/userspce/init-paramr.ss b/collects/userspce/init-paramr.ss new file mode 100644 index 00000000..9ed8d78e --- /dev/null +++ b/collects/userspce/init-paramr.ss @@ -0,0 +1,715 @@ +(unit/sig plt:init-params^ + (import [import : plt:basis-import^] + [init-namespace : plt:init-namespace^] + [params : plt:userspace:params^] + [zodiac : zodiac:system^] + [zodiac:interface : drscheme:interface^] + [aries : plt:aries^] + [mzlib:print-convert : mzlib:print-convert^] + [mzlib:pretty-print : mzlib:pretty-print^] + [mzlib:function : mzlib:function^]) + + (define initial-line 1) + (define initial-column 1) + (define initial-offset 0) + + (define original-output-port (current-output-port)) + (define (printf . args) + (apply fprintf original-output-port args)) + + (define (report-error . x) (error 'report-error)) + (define (report-unlocated-error . x) (error 'report-unlocated-error)) + + (define primitive-load (current-load)) + (define primitive-eval (current-eval)) + + (define r4rs-style-printing (make-parameter #f)) + + (define this-program (with-handlers ([void (lambda (x) "mzscheme")]) + (global-defined-value 'program))) + + (define-struct/parse setting (key + name + vocabulary-symbol + macro-libraries + case-sensitive? + allow-set!-on-undefined? + unmatched-cond/case-is-error? + allow-improper-lists? + allow-reader-quasiquote? + sharing-printing? + abbreviate-cons-as-list? + signal-undefined + signal-not-boolean + eq?-only-compares-symbols? + <=-at-least-two-args + disallow-untagged-inexact-numbers + print-tagged-inexact-numbers + whole/fractional-exact-numbers + print-booleans-as-true/false + printing + print-exact-as-decimal? + read-decimal-as-exact? + define-argv? + use-pretty-printer?)) + + ;; settings : (list-of setting) + (define settings + (list (make-setting/parse + `((key beginner) + (name "Beginning Student") + (macro-libraries ()) + (vocabulary-symbol beginner) + (case-sensitive? #t) + (allow-set!-on-undefined? #f) + (unmatched-cond/case-is-error? #t) + (allow-improper-lists? #f) + (allow-reader-quasiquote? #f) + (sharing-printing? #f) + (abbreviate-cons-as-list? #f) + (signal-undefined #t) + (signal-not-boolean #t) + (eq?-only-compares-symbols? #t) + (<=-at-least-two-args #t) + (disallow-untagged-inexact-numbers #f) + (print-tagged-inexact-numbers #t) + (whole/fractional-exact-numbers #f) + (print-booleans-as-true/false #t) + (printing constructor-style) + (print-exact-as-decimal? #t) + (read-decimal-as-exact? #t) + (define-argv? #f) + (use-pretty-printer? #t))) + (make-setting/parse + `((key intermediate) + (name "Intermediate Student") + (macro-libraries ()) + (vocabulary-symbol intermediate) + (case-sensitive? #t) + (allow-set!-on-undefined? #f) + (unmatched-cond/case-is-error? #t) + (allow-improper-lists? #f) + (allow-reader-quasiquote? #t) + (sharing-printing? #f) + (abbreviate-cons-as-list? #t) + (signal-undefined #t) + (signal-not-boolean #t) + (eq?-only-compares-symbols? #t) + (<=-at-least-two-args #t) + (disallow-untagged-inexact-numbers #f) + (print-tagged-inexact-numbers #t) + (whole/fractional-exact-numbers #f) + (print-booleans-as-true/false #t) + (printing constructor-style) + (print-exact-as-decimal? #t) + (read-decimal-as-exact? #t) + (define-argv? #f) + (use-pretty-printer? #t))) + (make-setting/parse + `((key advanced) + (name "Advanced Student") + (macro-libraries ()) + (vocabulary-symbol advanced) + (case-sensitive? #t) + (allow-set!-on-undefined? #f) + (unmatched-cond/case-is-error? #t) + (allow-improper-lists? #f) + (allow-reader-quasiquote? #t) + (sharing-printing? #t) + (abbreviate-cons-as-list? #t) + (signal-undefined #t) + (signal-not-boolean #f) + (eq?-only-compares-symbols? #f) + (<=-at-least-two-args #t) + (disallow-untagged-inexact-numbers #f) + (print-tagged-inexact-numbers #t) + (whole/fractional-exact-numbers #f) + (print-booleans-as-true/false #t) + (printing constructor-style) + (print-exact-as-decimal? #t) + (read-decimal-as-exact? #t) + (define-argv? #f) + (use-pretty-printer? #t))) + (make-setting/parse + `((key full) + (name "Textual Full Scheme (MzScheme)") + (vocabulary-symbol mzscheme-debug) + (macro-libraries ()) + (case-sensitive? #f) + (allow-set!-on-undefined? #f) + (unmatched-cond/case-is-error? #f) + (allow-improper-lists? #t) + (allow-reader-quasiquote? #t) + (sharing-printing? #f) + (abbreviate-cons-as-list? #t) + (signal-undefined #f) + (signal-not-boolean #f) + (eq?-only-compares-symbols? #f) + (<=-at-least-two-args #f) + (disallow-untagged-inexact-numbers #f) + (print-tagged-inexact-numbers #f) + (whole/fractional-exact-numbers #f) + (print-booleans-as-true/false #f) + (printing r4rs-style) + (print-exact-as-decimal? #f) + (read-decimal-as-exact? #f) + (define-argv? #t) + (use-pretty-printer? #t))) + (make-setting/parse + `((key full) + (name "Textual Full Scheme without Debugging (MzScheme)") + (macro-libraries ()) + (vocabulary-symbol mzscheme) + (case-sensitive? #f) + (allow-set!-on-undefined? #f) + (unmatched-cond/case-is-error? #f) + (allow-improper-lists? #t) + (allow-reader-quasiquote? #t) + (sharing-printing? #f) + (abbreviate-cons-as-list? #t) + (signal-undefined #f) + (signal-not-boolean #f) + (eq?-only-compares-symbols? #f) + (<=-at-least-two-args #f) + (disallow-untagged-inexact-numbers #f) + (print-tagged-inexact-numbers #f) + (whole/fractional-exact-numbers #f) + (print-booleans-as-true/false #f) + (printing r4rs-style) + (print-exact-as-decimal? #f) + (read-decimal-as-exact? #f) + (define-argv? #t) + (use-pretty-printer? #t))))) + + (define (snoc x y) (append y (list x))) + + ;; add-setting : (symbol setting -> void) + (define add-setting + (case-lambda + [(setting) (add-setting setting (length settings))] + [(setting number) + (set! settings + (let loop ([number number] + [settings settings]) + (cond + [(or (zero? number) (null? settings)) + (cons setting settings)] + [else + (cons + (car settings) + (loop (- number 1) + (cdr settings)))])))])) + + ;; find-setting-named : string -> setting + ;; effect: raises an exception if no setting named by the string exists + (define (find-setting-named name) + (unless (string? name) + (error 'find-setting-named "expected string, got ~e" name)) + (let loop ([settings settings]) + (cond + [(null? settings) (error 'find-setting-named "no setting named ~e" name)] + [else (let* ([setting (car settings)]) + (if (string=? name (setting-name setting)) + setting + (loop (cdr settings))))]))) + + + ;; copy-setting : setting -> setting + (define copy-setting + (lambda (x) + (unless (setting? x) + (error 'copy-setting "expected a setting, got ~e" x)) + (apply make-setting (cdr (vector->list (struct->vector x)))))) + + ;; get-default-setting : (-> setting) + (define (get-default-setting) (copy-setting (car settings))) + + ;; get-default-setting-name : (-> symbol) + (define (get-default-setting-name) (setting-name (get-default-setting))) + + ;; setting-name->number : string -> int + (define setting-name->number + (lambda (name) + (let loop ([n 0] + [settings settings]) + (cond + [(null? settings) (error 'level->number "unexpected level: ~a" name)] + [else (let ([setting (car settings)]) + (if (string=? name (setting-name setting)) + n + (loop (+ n 1) + (cdr settings))))])))) + + ;; number->setting : (int -> symbol) + (define number->setting (lambda (n) (list-ref settings n))) + + ;; zodiac-vocabulary? : setting -> boolean + (define (zodiac-vocabulary? setting) + (not (or (eq? (setting-vocabulary-symbol setting) 'mzscheme) + (eq? (setting-vocabulary-symbol setting) 'mred)))) + + ;; X-language : setting -> boolean + ;; returns true if the input language is the specified language + (define (beginner-language? setting) (eq? (setting-key setting) 'beginner)) + (define (intermediate-language? setting) (eq? (setting-key setting) 'intermediate)) + (define (advanced-language? setting) (eq? (setting-key setting) 'advanced)) + (define (full-language? setting) (eq? (setting-key setting) 'full)) + + ;; r4rs-style-printing? : setting -> boolean + (define (r4rs-style-printing? setting) + (eq? 'r4rs-style (setting-printing setting))) + + ;; current-setting : (parameter (+ #f setting)) + (define current-setting + (make-parameter + #f + (lambda (x) + (if (or (not x) + (setting? x)) + x + (error 'current-setting + "must be a setting or #f"))))) + + ;; current-vocabulary : (parameter (+ #f zodiac:vocabulary)) + (define current-vocabulary (make-parameter #f)) + + ;; current-zodiac-namespace : (parameter (+ #f namespace)) + ;; If another namespace is installed, drscheme-eval uses primitive-eval + (define current-zodiac-namespace (make-parameter #f)) + + ;; syntax-checking-primitive-eval : sexp -> value + ;; effect: raises user-exn if expression ill-formed + (define (syntax-checking-primitive-eval expr) + (primitive-eval + (with-handlers ([(lambda (x) #t) + (lambda (x) + (error 'internal-syntax-error + (format "~a" (exn-message x))))]) + (expand-defmacro expr)))) + + (define-struct process-finish (error?)) + + ;; process-file/zodiac : string + ;; (((+ process-finish sexp zodiac:parsed) ( -> void) -> void) + ;; boolean + ;; -> void + ;; note: the boolean controls which variant of the union is passed to the 3rd arg. + ;; expects to be called with user's parameter settings active + (define (process-file/zodiac filename f annotate?) + (let ([port (open-input-file filename 'text)] + [setting (current-setting)]) + (dynamic-wind + void + (lambda () + (process/zodiac + (zodiac:read port + (zodiac:make-location initial-line + initial-column + initial-offset + (path->complete-path filename)) + #t 1) + f + annotate?)) + (lambda () (close-input-port port))))) + + ;; process-file/no-zodiac : string + ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) + ;; -> void + ;; expects to be called with user's parameter settings active + (define (process-file/no-zodiac filename f) + (call-with-input-file filename + (lambda (port) + (process/no-zodiac (lambda () (read port)) f)))) + + ;; process-sexp/no-zodiac : sexp + ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) + ;; -> void + ;; expects to be called with user's parameter settings active + (define (process-sexp/no-zodiac sexp f) + (process/no-zodiac (let ([first? #t]) + (lambda () + (if first? + (begin (set! first? #f) + sexp) + eof))) + f)) + + ;; process-sexp/zodiac : sexp + ;; zodiac:sexp + ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) + ;; boolean + ;; -> void + ;; note: the boolean controls which variant of the union is passed to the 2nd arg. + ;; expects to be called with user's parameter settings active + (define (process-sexp/zodiac sexp z f annotate?) + (let* ([reader + (let ([gone #f]) + (lambda () + (or gone + (begin (set! gone (zodiac:make-eof z)) + (zodiac:structurize-syntax sexp z)))))]) + (process/zodiac reader f annotate?))) + + ;; process/zodiac : ( -> zodiac:sexp) + ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) + ;; boolean + ;; -> void + ;; expects to be called with user's parameter settings active + (define (process/zodiac reader f annotate?) + (let ([setting (current-setting)] + [vocab (current-vocabulary)] + [cleanup + (lambda (error?) + (f (make-process-finish error?) void))]) + (let loop () + (let ([next-iteration + (let/ec k + (let ([annotate + (lambda (term read-expr) + (dynamic-wind + (lambda () (zodiac:interface:set-zodiac-phase 'expander)) + (lambda () (aries:annotate term read-expr)) + (lambda () (zodiac:interface:set-zodiac-phase #f))))] + ; Always read with zodiac + [zodiac-read + (dynamic-wind + (lambda () (zodiac:interface:set-zodiac-phase 'reader)) + (lambda () (reader)) + (lambda () (zodiac:interface:set-zodiac-phase #f)))] + ; Sometimes, we throw away source information and + ; expand with MzScheme + [use-z-exp? (and (zodiac-vocabulary? (current-setting)) + (eq? (current-namespace) (current-zodiac-namespace)))]) + (if (zodiac:eof? zodiac-read) + (lambda () (cleanup #f)) + (let* ([evaluator + (lambda (exp _ macro) + (primitive-eval (annotate exp #f)))] + [user-macro-body-evaluator + (lambda (x . args) + (primitive-eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args))))] + [exp + (if use-z-exp? + (dynamic-wind + (lambda () (zodiac:interface:set-zodiac-phase 'expander)) + (lambda () (parameterize ([zodiac:user-macro-body-evaluator user-macro-body-evaluator] + [zodiac:elaboration-evaluator evaluator]) + (zodiac:scheme-expand + zodiac-read + 'previous + vocab))) + (lambda () (zodiac:interface:set-zodiac-phase #f))) + + ;; call expand-defmacro here so errors + ;; are raised at the right time. + (expand-defmacro (zodiac:sexp->raw zodiac-read)))] + [heading-out (if (and annotate? use-z-exp?) + (annotate exp zodiac-read) + exp)]) + (lambda () (f heading-out loop))))))]) + (next-iteration))))) + + ;; process/no-zodiac : ( -> sexp) ((+ sexp process-finish) ( -> void) -> void) -> void + (define (process/no-zodiac reader f) + (let loop () + (let ([expr (reader)]) + (if (eof-object? expr) + (f (make-process-finish #f) void) + (f expr loop))))) + + (define format-source-loc + (case-lambda + [(start-location end-location) + (format-source-loc start-location end-location #t)] + [(start-location end-location start-at-one?) + (format-source-loc start-location end-location start-at-one? #t)] + [(start-location end-location start-at-one? lines-and-columns?) + (let ([file (zodiac:location-file start-location)]) + (if lines-and-columns? + (let ([offset (if start-at-one? 0 -1)]) + (format "~a: ~a.~a-~a.~a: " + file + (+ offset (zodiac:location-line start-location)) + (+ offset (zodiac:location-column start-location)) + (+ offset (zodiac:location-line end-location)) + (+ offset 1 (zodiac:location-column end-location)))) + (let ([offset (if start-at-one? 1 0)]) + (format "~a: ~a-~a: " + file + (+ offset (zodiac:location-offset start-location)) + (+ 1 offset (zodiac:location-offset end-location))))))])) + + + ;; (parameter (string zodiac:zodiac exn -> void)) + (define error-display/debug-handler + (make-parameter + (lambda (msg debug exn) + ((error-display-handler) + (if (zodiac:zodiac? debug) + (string-append (format-source-loc (zodiac:zodiac-start debug) + (zodiac:zodiac-finish debug)) + msg) + msg))))) + + ;; bottom-escape-handler : (parameter ( -> A)) + ;; escapes + (define bottom-escape-handler (make-parameter void)) + + ;; drscheme-exception-handler : exn -> A + ;; effect: displays the exn-message and escapes + (define (drscheme-exception-handler exn) + (let ([dh (error-display/debug-handler)]) + (if (exn? exn) + (let* ([marks (exn-continuation-marks exn)] + [debug (if (continuation-mark-set? marks) + (aries:extract-zodiac-location marks) + #f)]) + (dh (format "~a" (exn-message exn)) debug exn)) + (dh (format "uncaught exception: ~e" exn) #f #f))) + ((error-escape-handler)) + ((error-display-handler) "Exception handler did not escape") + ((bottom-escape-handler))) + + ;; drscheme-error-value->string-handler : TST number -> string + (define (drscheme-error-value->string-handler x n) + (let ([port (open-output-string)]) + (parameterize ([current-output-port port] + [mzlib:pretty-print:pretty-print-columns 'infinity]) + (drscheme-print/void x)) + (let* ([long-string (get-output-string port)]) + (close-output-port port) + (if (<= (string-length long-string) n) + long-string + (let ([short-string (substring long-string 0 n)] + [trim 3]) + (unless (<= n trim) + (let loop ([i trim]) + (unless (<= i 0) + (string-set! short-string (- n i) #\.) + (loop (sub1 i))))) + short-string))))) + + ;; intermediate-values-during-load : (parameter (TST *-> void)) + ;; probably obsolete + (define intermediate-values-during-load (make-parameter (lambda x (void)))) + + ;; drscheme-load-handler : string ->* TST + (define (drscheme-load-handler filename) + (unless (string? filename) + (raise (make-exn:application:arity + (format "drscheme-load-handler: expects argument of type ; given: ~e" filename) + (current-continuation-marks) + filename + 'string))) + (let ([zo-file? + (let ([l (string-length filename)]) + (and (<= 3 l) + (string=? ".zo" (substring filename (- l 3) l))))]) + + (cond + [zo-file? + (parameterize ([current-eval primitive-eval]) + (primitive-load filename))] + [(zodiac-vocabulary? (current-setting)) + (let* ([process-sexps + (let ([last (list (void))]) + (lambda (sexp recur) + (cond + [(process-finish? sexp) + last] + [else + (set! last + (call-with-values + (lambda () (syntax-checking-primitive-eval sexp)) + (lambda x + (apply (intermediate-values-during-load) x) + x))) + (recur)])))]) + (apply values (process-file/zodiac filename process-sexps #t)))] + [else + (primitive-load filename)]))) + + ;; drscheme-eval : sexp ->* TST + (define (drscheme-eval-handler sexp) + (if (and (zodiac-vocabulary? (current-setting)) + (eq? (current-namespace) (current-zodiac-namespace))) + (let* ([z (let ([continuation-stack (continuation-mark-set->list + (current-continuation-marks) + aries:w-c-m-key)]) + (if (null? continuation-stack) + (let ([loc (zodiac:make-location + initial-line initial-column initial-offset + 'eval)]) + (zodiac:make-zodiac 'mzrice-eval loc loc)) + (car continuation-stack)))] + [answer (list (void))] + [f + (lambda (annotated recur) + (if (process-finish? annotated) + answer + (begin (set! answer + (call-with-values + (lambda () (syntax-checking-primitive-eval annotated)) + (lambda x x))) + (recur))))]) + (apply values (process-sexp/zodiac sexp z f #t))) + (primitive-eval sexp))) + + + ;; drscheme-print : TST -> void + ;; effect: prints the value, on the screen, attending to the values of the current setting + (define drscheme-print + (lambda (v) + (unless (void? v) + (drscheme-print/void v)))) + + ;; drscheme-print/void : TST -> void + ;; effect: prints the value, on the screen, attending to the values of the current setting + (define (drscheme-print/void v) + (let* ([setting (current-setting)] + [value (if (r4rs-style-printing? setting) + v + (mzlib:print-convert:print-convert v))]) + (if (setting-use-pretty-printer? setting) + (mzlib:pretty-print:pretty-print value) + (write value)))) + + ;; drscheme-port-print-handler : TST port -> void + ;; effect: prints the value on the port + (define (drscheme-port-print-handler value port) + (parameterize ([mzlib:pretty-print:pretty-print-columns 'infinity] + [current-output-port port]) + (drscheme-print/void value))) + + (define ricedefs@ (require-library "ricedefr.ss" "userspce")) + + + (define (teaching-level? setting) + (let* ([name (setting-name setting)] + [ans (or (equal? name "Beginning Student") + (equal? name "Intermediate Student") + (equal? name "Advanced Student"))]) + ans)) + + ;; initialize-parameters : custodian + ;; (list-of symbols) + ;; setting + ;; -> void + ;; effect: sets the parameters for drscheme and drscheme-jr + (define (initialize-parameters custodian setting) + (let*-values ([(namespace-flags) (let ([name (setting-name setting)]) + (if (regexp-match "MrEd" name) + (list 'mred) + (list)))] + [(n) (apply make-namespace + (if (zodiac-vocabulary? setting) + (append (list 'hash-percent-syntax) namespace-flags) + namespace-flags))]) + + (when (zodiac-vocabulary? setting) + (use-compiled-file-kinds 'non-elaboration)) + (current-setting setting) + (compile-allow-set!-undefined #f) + (compile-allow-cond-fallthrough #f) + (current-custodian custodian) + (error-value->string-handler drscheme-error-value->string-handler) + (current-exception-handler drscheme-exception-handler) + (initial-exception-handler drscheme-exception-handler) + (current-namespace n) + (current-zodiac-namespace n) + (break-enabled #t) + (read-curly-brace-as-paren #t) + (read-square-bracket-as-paren #t) + (print-struct (not (eq? 'r4rs-style (setting-printing setting)))) + (read-decimal-as-inexact (not (setting-read-decimal-as-exact? setting))) + + (init-namespace:init-namespace) + + (error-print-width 250) + (current-print drscheme-print) + + (current-load-relative-directory #f) + (current-require-relative-collection #f) + + (when (zodiac-vocabulary? setting) + (current-vocabulary + (zodiac:create-vocabulary + 'scheme-w/user-defined-macros/drscheme + (case (setting-vocabulary-symbol setting) + [(beginner) zodiac:beginner-vocabulary] + [(intermediate) zodiac:intermediate-vocabulary] + [(advanced) zodiac:advanced-vocabulary] + [(mzscheme-debug mred-debug) zodiac:scheme-vocabulary] + [else (error 'init "bad vocabulary spec: ~a ~e" + (setting-vocabulary-symbol setting) setting)]))) + (zodiac:reset-previous-attribute + #f + (eq? (setting-vocabulary-symbol setting) + 'mred-debug))) + + (read-case-sensitive (setting-case-sensitive? setting)) + + (aries:signal-undefined (setting-signal-undefined setting)) + (aries:signal-not-boolean (setting-signal-not-boolean setting)) + + ;; Allow ` , and ,@ ? - FIXME! + (zodiac:allow-reader-quasiquote (setting-allow-reader-quasiquote? setting)) + (zodiac:disallow-untagged-inexact-numbers (setting-disallow-untagged-inexact-numbers setting)) + + ;; ricedefs + (let ([improper-lists? + (or (not (zodiac-vocabulary? setting)) + (setting-allow-improper-lists? setting))]) + (zodiac:allow-improper-lists improper-lists?) + (params:allow-improper-lists improper-lists?)) + (params:eq?-only-compares-symbols (setting-eq?-only-compares-symbols? setting)) + (params:<=-at-least-two-args (setting-<=-at-least-two-args setting)) + (when (teaching-level? setting) + (global-define-values/invoke-unit/sig ricedefs^ ricedefs@ #f (params : plt:userspace:params^))) + ;; end ricedefs + + (compile-allow-set!-undefined (setting-allow-set!-on-undefined? setting)) + (compile-allow-cond-fallthrough (not (setting-unmatched-cond/case-is-error? setting))) + + (current-eval drscheme-eval-handler) + (current-load drscheme-load-handler) + + (when (setting-define-argv? setting) + (global-defined-value 'argv #()) + (global-defined-value 'program this-program)) + + (global-port-print-handler drscheme-port-print-handler) + + (case (setting-printing setting) + [(constructor-style) + (r4rs-style-printing #f) + (mzlib:print-convert:constructor-style-printing #t)] + [(quasi-style) + (r4rs-style-printing #f) + (mzlib:print-convert:constructor-style-printing #f) + (mzlib:print-convert:quasi-read-style-printing #f)] + [(quasi-read-style) + (r4rs-style-printing #f) + (mzlib:print-convert:constructor-style-printing #f) + (mzlib:print-convert:quasi-read-style-printing #t)] + [(r4rs-style) (r4rs-style-printing #t)] + [else (error 'install-language "found bad setting-printing: ~a~n" + (setting-printing setting))]) + + (mzlib:pretty-print:pretty-print-exact-as-decimal + (setting-print-exact-as-decimal? setting)) + (mzlib:pretty-print:pretty-print-show-inexactness + (setting-print-tagged-inexact-numbers setting)) + (mzlib:print-convert:show-sharing (setting-sharing-printing? setting)) + (mzlib:print-convert:whole/fractional-exact-numbers + (setting-whole/fractional-exact-numbers setting)) + (mzlib:print-convert:booleans-as-true/false + (setting-print-booleans-as-true/false setting)) + (print-graph (and (r4rs-style-printing) (setting-sharing-printing? setting))) + (mzlib:print-convert:abbreviate-cons-as-list (setting-abbreviate-cons-as-list? setting)) + + ;; ROBBY : attempt to back out of John's changes + (global-defined-value '#%break aries:break) + + (for-each (lambda (l) (apply require-library/proc l)) + (setting-macro-libraries setting))))) diff --git a/collects/userspce/interface.ss b/collects/userspce/interface.ss new file mode 100644 index 00000000..99cb8e27 --- /dev/null +++ b/collects/userspce/interface.ss @@ -0,0 +1,55 @@ +(unit/sig drscheme:interface^ + (import [aries : plt:aries^] + [zodiac : zodiac:system^]) + + (define zodiac-phase #f) + (define (set-zodiac-phase sym) + (unless (or (not sym) + (memq sym '(reader expander))) + (error 'set-zodiac-phase "unknown phase: ~a~n" sym)) + (set! zodiac-phase sym)) + + ;; dispatch-report : string zodiac:zodiac -> ALPHA + ;; escapes + (define dispatch-report + (lambda (string object) + (raise + (with-continuation-mark + aries:w-c-m-key + (aries:make-zodiac-mark object) + (case zodiac-phase + [(expander) (make-exn:syntax string (current-continuation-marks) #f)] + [(reader) (make-exn:read string (current-continuation-marks) #f)] + [else (make-exn:user string (current-continuation-marks))]))))) + + ;; report-error : symbol -> (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA + ;; escapes + (define report-error + (lambda (type) + (lambda (z s . args) + (let ([string (apply format (if (eq? type 'internal) + (string-append "report error.Internal error: " + s) + s) + args)]) + (cond + [(zodiac:zodiac? z) (dispatch-report string z)] + [(zodiac:eof? z) (dispatch-report string (zodiac:make-zodiac 'origin + (zodiac:eof-location z) + (zodiac:eof-location z)))] + [(zodiac:period? z) (dispatch-report string (zodiac:make-zodiac 'origin + (zodiac:period-location z) + (zodiac:period-location z)))] + [else ((error-display-handler) (format "internal-error.report-error: ~a: ~a" z string))]))))) + + ;; static-error : (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA + ;; escapes + (define static-error (report-error 'static)) + + ;; dynamic-error : (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA + ;; escapes + (define dynamic-error (report-error 'dynamic)) + + ;; internal-error : (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA + ;; escapes + (define internal-error (report-error 'internal))) diff --git a/collects/userspce/launcher-bootstrap.ss b/collects/userspce/launcher-bootstrap.ss new file mode 100644 index 00000000..80531a7c --- /dev/null +++ b/collects/userspce/launcher-bootstrap.ss @@ -0,0 +1,52 @@ +;; set things up so that the load-handler opens files into +;; a text when the file begins with WXME so that mred saved +;; files still load properly. + +(require-library "errortrace.ss" "errortrace") +(require-library "core.ss" "drscheme-jr") + +(define main-unit + (let ([settings settings] + [teachpacks teachpacks] + [filename filename] + [mred@ mred@]) + (unit/sig drscheme-jr:settings^ + (import [prims : prims^] + [basis : plt:basis^] + [mzlib : mzlib:core^] + mred^) + + (basis:teachpack-changed teachpacks) + + (define show-banner? #f) + (define repl? #f) + (define (run-in-new-user-thread thunk) + (parameterize ([current-eventspace (make-eventspace)]) + (let ([thread #f] + [sema (make-semaphore 0)]) + (queue-callback (lambda () + (set! thread (current-thread)) + (semaphore-post sema))) + (semaphore-wait sema) + (queue-callback + thunk) + thread))) + (define (initialize-userspace) + + ;; add mred to the namespace + (global-define-values/invoke-unit/sig mred^ mred@)) + + (define setting (apply basis:make-setting (cdr (vector->list settings)))) + (define startup-file filename)))) + +(define go + (make-go + (compound-unit/sig + (import [prims : prims^] + [basis : plt:basis^] + [mzlib : mzlib:core^]) + (link [mred : mred^ (mred@)] + [main : drscheme-jr:settings^ (main-unit prims basis mzlib mred)]) + (export (open main))))) + +(go) diff --git a/collects/userspce/paramr.ss b/collects/userspce/paramr.ss new file mode 100644 index 00000000..69104b06 --- /dev/null +++ b/collects/userspce/paramr.ss @@ -0,0 +1,5 @@ +(unit/sig plt:userspace:params^ + (import) + (define <=-at-least-two-args (make-parameter #t)) + (define allow-improper-lists (make-parameter #t)) + (define eq?-only-compares-symbols (make-parameter #f))) diff --git a/collects/userspce/params.ss b/collects/userspce/params.ss new file mode 100644 index 00000000..0dfb5eb3 --- /dev/null +++ b/collects/userspce/params.ss @@ -0,0 +1,4 @@ +(define-signature plt:userspace:params^ + (<=-at-least-two-args + allow-improper-lists + eq?-only-compares-symbols)) \ No newline at end of file diff --git a/collects/userspce/ricedefr.ss b/collects/userspce/ricedefr.ss new file mode 100644 index 00000000..d7b2b0fe --- /dev/null +++ b/collects/userspce/ricedefr.ss @@ -0,0 +1,129 @@ +(unit/sig ricedefs^ + (import [params : plt:userspace:params^]) + + (define check-second + (lambda (prim-name a b) + (unless (list? b) + (error prim-name + "second argument must be of type , given ~e and ~e" + a b)))) + + (define check-last + (lambda (prim-name args) + (let loop ([l args]) + (cond + [(null? l) (void)] + [(null? (cdr l)) + (let ([last (car l)]) + (unless (list? last) + (error prim-name + "last argument must be of type , given ~e; all args: ~a" + last + (map (lambda (x) (format "~e" x)) args))))] + [else (loop (cdr l))])))) + + (define (check-arity prim len lst) + (let ([lst-len (length lst)]) + (unless (#%>= lst-len len) + (error prim + "expects at least ~a arguments, given ~a" + len + (if (#%= 0 lst-len) + 0 + (format + "~a: ~a" + lst-len + (apply string-append + (cons (format "~e" (car lst)) + (let loop ([rst (cdr lst)]) + (cond + [(null? rst) null] + [else (cons (format " ~e" (car rst)) + (loop (cdr rst)))])))))))))) + + + (define = + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '= 2 args) + (apply #%= args)) + #%=)) + + (define + + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '+ 2 args) + (apply #%+ args)) + #%+)) + + (define / + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '/ 2 args) + (apply #%/ args)) + #%/)) + + (define * + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '* 2 args) + (apply #%* args)) + #%*)) + + (define >= + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '>= 2 args) + (apply #%>= args)) + #%>=)) + + (define < + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '< 2 args) + (apply #%< args)) + #%<)) + + (define > + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '> 2 args) + (apply #%> args)) + #%>)) + + (define <= + (if (params:<=-at-least-two-args) + (lambda args + (check-arity '<= 2 args) + (apply #%<= args)) + #%<=)) + + (define cons (if (params:allow-improper-lists) + #%cons + (lambda (a b) + (check-second 'cons a b) + (#%cons a b)))) + + (define set-cdr! (if (params:allow-improper-lists) + #%set-cdr! + (lambda (a b) + (check-second 'set-cdr! a b) + (#%set-cdr! a b)))) + + (define list* (if (params:allow-improper-lists) + #%list* + (lambda x + (check-last 'list* x) + (apply #%list* x)))) + + (define append (if (params:allow-improper-lists) + #%append + (lambda x + (check-last 'append x) + (apply #%append x)))) + + (define append! (if (params:allow-improper-lists) + #%append! + (lambda x + (check-last 'append! x) + (apply #%append! x))))) diff --git a/collects/userspce/ricedefs.ss b/collects/userspce/ricedefs.ss new file mode 100644 index 00000000..86d683ea --- /dev/null +++ b/collects/userspce/ricedefs.ss @@ -0,0 +1,8 @@ +(define-signature ricedefs^ + (<= < > >= + = + * / + cons + set-cdr! + list* + append + append!)) diff --git a/collects/userspce/sig.ss b/collects/userspce/sig.ss new file mode 100644 index 00000000..8461eb02 --- /dev/null +++ b/collects/userspce/sig.ss @@ -0,0 +1,158 @@ +(require-relative-library "ricedefs.ss") +(require-library "sig.ss" "stepper") +(require-library "cores.ss") +(require-library "pconvers.ss") +(require-library "zsigs.ss" "zodiac") +(require-library "sigs.ss" "zodiac") +(require-library "coreflats.ss") +(require-relative-library "ricedefs.ss") +(require-library "sig.ss" "mred") +(require-library "turtles.ss" "graphics") + +(define-signature plt:beginner-extras^ + ((struct posn (x y) -setters) + (open mzlib:core-flat^))) + +(define-signature plt:intermediate-extras^ + plt:beginner-extras^) + +(begin-construction-time + (if (defined? 'mred@) + `(define-signature plt:userspace^ + ((open mred^) + (open mzlib:core-flat^) + (open turtle^) + (struct posn (x y)))) + `(define-signature plt:userspace^ + ((open mzlib:core-flat^) + (struct posn (x y)))))) + +(begin-construction-time + (if (defined? 'mred@) + `(define-signature plt:advanced-extras^ + ((struct posn (x y)) + (open mzlib:core-flat^) + (open turtle^))) + `(define-signature plt:advanced-extras^ + ((struct posn (x y)) + (open mzlib:core-flat^))))) + +;; extend structs with a parsing constructor +(define-macro define-struct/parse + (lambda (str fields) + (unless (symbol? str) + (error 'define-struct/parse "no super structs allowed")) + (let* ([first car] + [second cadr] + [second-name 'cadr] + [third caddr] + [defn (expand-defmacro `(#%define-struct ,str ,fields))] + [_ (unless (and (pair? defn) + (eq? (car defn) '#%define-values)) + (error 'define-struct/parse "expand-defmacro didn't return expected value: ~s~n" defn))] + [bindings (second defn)] + [exp (third defn)] + [make-parse (string->symbol (string-append "make-" (symbol->string str) "/parse"))] + [maker-name (second bindings)] + [parser + `(lambda (inits) + (apply ,maker-name + (map (lambda (field) + (let ([m (assq field inits)]) + (unless m + (error ',make-parse "no binding for: ~a" field)) + (unless (= (length m) 2) + (error ',make-parse "malformed binding: ~a" m)) + (,second-name m))) + ',fields)))]) + `(define-values ,(cons make-parse bindings) + (call-with-values (lambda () ,exp) + (lambda bindings (apply values (cons ,parser bindings)))))))) + +(define-signature plt:init-params^ + (initialize-parameters + settings + get-default-setting + get-default-setting-name + + drscheme-load-handler + + zodiac-vocabulary? + beginner-language? + intermediate-language? + advanced-language? + full-language? + + error-display/debug-handler + current-vocabulary + current-setting + intermediate-values-during-load + bottom-escape-handler + + drscheme-print + + initial-line + initial-column + initial-offset + + format-source-loc + + primitive-eval + primitive-load + syntax-checking-primitive-eval + + process/zodiac + process/no-zodiac + + process-file/zodiac + process-file/no-zodiac + process-sexp/zodiac + process-sexp/no-zodiac + + (struct process-finish (error?)) + + setting-name->number + number->setting + (struct setting (name + vocabulary-symbol + macro-libraries + case-sensitive? + allow-set!-on-undefined? + unmatched-cond/case-is-error? + allow-improper-lists? + sharing-printing? + abbreviate-cons-as-list? + signal-undefined + signal-not-boolean + eq?-only-compares-symbols? + <=-at-least-two-args + disallow-untagged-inexact-numbers + print-tagged-inexact-numbers + whole/fractional-exact-numbers + print-booleans-as-true/false + printing + use-pretty-printer?)) + make-setting/parse + + find-setting-named + add-setting + copy-setting + + r4rs-style-printing?)) + +(define-signature plt:init-namespace^ + (init-namespace + teachpack-ok? + teachpack-changed)) + +(define-signature plt:basis^ + ((open plt:init-params^) + (open plt:init-namespace^))) + +(define-signature drscheme:interface^ + ((open zodiac:interface^) + set-zodiac-phase)) + +(define-signature plt:basis-import^ + (invalid-teachpack + in-mzscheme?)) diff --git a/collects/userspce/userspce.ss b/collects/userspce/userspce.ss new file mode 100644 index 00000000..9c3df22d --- /dev/null +++ b/collects/userspce/userspce.ss @@ -0,0 +1,17 @@ +; require this file within MrEd to install into the top-level +; the bindings normally available to a DrScheme library + +(begin-elaboration-time + (require-library "params.ss" "userspce")) + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig ((open plt:userspace:params^) + (open plt:userspace^)) + (compound-unit/sig + (import) + (link [p : plt:userspace:params^ ((require-relative-library "paramr.ss"))] + [u : plt:userspace^ ((require-relative-library "userspcr.ss") p)]) + (export (open p) + (open u)))) diff --git a/collects/userspce/userspcr.ss b/collects/userspce/userspcr.ss new file mode 100644 index 00000000..cf949d84 --- /dev/null +++ b/collects/userspce/userspcr.ss @@ -0,0 +1,5 @@ +(compound-unit/sig (import [params : plt:userspace:params^]) + (link [core : mzlib:core-flat^ ((require-library "coreflatr.ss"))] + [mred : mred^ (mred@)]) + (export (open core) + (open mred))) diff --git a/collects/xml/doc.txt b/collects/xml/doc.txt new file mode 100644 index 00000000..d1f51311 --- /dev/null +++ b/collects/xml/doc.txt @@ -0,0 +1,177 @@ +_XML_ Library +============= + +Basic XML Data Types +==================== + +Document: + This structure represents an XML document. The only useful part is + the document-element, which contains all the content. The rest of + of the structure contains DTD information, which isn't supported, + and processing-instructions. + +Element: + Each pair of start/end tags and everything in between is an element. + It has the following pieces: + a name + attributes + contents including sub-elements +Xexpr: + S-expression representations of XML data. + +The end of this document has more details. + +Functions +========= + +> read-xml : [Input-port] -> Document + reads in an XML document from the given or current input port + XML documents contain exactly one element. It throws an xml-read:error + if there isn't any element or if there are more than one element. + +> write-xml : Document [Output-port] -> Void + writes a document to the given or current output port, currently + ignoring everything except the document's root element. + +> write-xml/content : Content [Output-port] -> Void + writes a document's contents to the given or current output port + +> display-xml : Document [Output-port] -> Void + just like write-xml, but newlines and indentation make the output more + readable, though less technically correct when white space is + significant. + +> display-xml/content : Content [Output-port] -> Void + just like write-xml/content, but with indentation and newlines + +> xml->xexpr : Content -> Xexpr + converts the interesting part of an XML document into an Xexpression + +> xexpr->xml : Xexpr -> Content + converts an Xexpression into the interesting part of an XML document + +> xexpr->string : Xexpression -> String + converts an Xexpression into a string representation + +> eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element + Some elements should not contain any text, only other tags, except they + often contain whitespace for formating purposes. Given a list of tag names + and the identity function, eliminate-whitespace produces a function that + filters out pcdata consisting solely of whitespace from those elements and + raises and error if any non-whitespace text appears. Passing in the function + called "not" instead of the identity function filters all elements which are not + named in the list. Using void filters all elements regardless of the list. + +Parameters +========== + +> empty-tag-shorthand : 'always | 'never | (listof Symbol) + Default: 'always + This determines if the output functions should use the tag + notation instead of writing . The first form is the + preferred XML notation. However, most browsers designed for HTML + will only properly render XHTML if the document uses a mixture of the + two formats. _html-empty-tags_ contains the W3 consortium's + recommended list of XHTML tags that should use the shorthand. + +> collapse-whitespace : Bool + Default: #f + All consecutive whitespace is replaced by a single space. + CDATA sections are not affected. + +> trim-whitespace : Bool + This parameter no longer exists. Consider using collapse-whitespace + and eliminate-whitespace instead. + +> read-comments : Bool + Default: #f + Comments, by definition, should be ignored by programs. However, + interoperating with ad hoc extentions to other languages sometimes + requires processing comments anyway. + +> xexpr-drop-empty-attributes : Bool + Default: #f + It's easier to write functions processing Xexpressions, if they always + have a list of attributes. On the other hand, it's less cumbersome to + write Xexpresssions by hand without empty lists of attributes + everywhere. Normally xml->xexpr leaves in empty attribute lists. + Setting this parameter to #t drops them, so further editing the + Xexpression by hand is less annoying. + +Examples +======== + +Reading an Xexpression: + (xml->xexpr (document-element (read-xml input-port))) + +Writing an Xexpression: + (empty-tag-shorthand html-empty-tags) + (write-xml/content (xexpr->xml `(html (head (title ,banner)) + (body ((bgcolor "white")) + ,text))) + output-port) + +What this Library Doesn't Provide +================================= + + Document Type Declaration (DTD) processing + Validation + Expanding user-defined entites + Reading user-defined entites in attributes + Unicode support + +XML Datatype Details +==================== + +Note: Users of the XML collection don't need to know most of these definitions. + +Note: Xexpr is the only important one to understand. Even then, + Processing-instructions may be ignored. + +> Xexpr ::= String + | (list* Symbol (listof (list Symbol String)) (list Xexpr)) + | (cons Symbol (listof Xexpr)) ;; an element with no attributes + | Symbol ;; symbolic entities such as   + | Number ;; numeric entities like  + | Misc + +> Document ::= (make-document Prolog Element (listof Processing-instruction)) + (define-struct document (prolog element misc)) + +> Prolog ::= (make-prolog (listof Misc) #f) + (define-struct prolog (misc dtd)) + +> Element ::= (make-element Location Location + Symbol + (listof Attribute) + (listof Content)) + (define-struct (element struct:source) (name attributes content)) + +> Attribute ::= (make-attribute Location Location Symbol String) + (define-struct (attribute struct:source) (name value)) + +> Content ::= Pcdata + | Element + | Entity + | Misc + + Misc ::= Comment + | Processing-instruction + +> Pcdata ::= (make-pcdata Location Location String) + (define-struct (pcdata struct:source) (string)) + +> Entity ::= (make-entity (U Nat Symbol)) + (define-struct entity (text)) + +> Processing-instruction ::= (make-pi Location Location String (list String)) + (define-struct (pi struct:source) (target-name instruction)) + +> Comment ::= (make-comment String) + (define-struct comment (text)) + + Source ::= (make-source Location Location) + (define-struct source (start stop)) + + Location ::= Nat + | Symbol diff --git a/collects/xml/info.ss b/collects/xml/info.ss new file mode 100644 index 00000000..93336256 --- /dev/null +++ b/collects/xml/info.ss @@ -0,0 +1,10 @@ +(lambda (sym fail) + (let* ([sig "xmls.ss"] + [signatures (list sig)]) + (case sym + [(name) "XML"] + [(compile-prefix) `(require-library ,sig "xml")] + [(compile-omit-files) signatures] + [(compile-elaboration-zos) signatures] + ;[(compile-subcollections) (list (list "xml" "xt3d"))] + [else (fail)]))) diff --git a/collects/xml/reader.ss b/collects/xml/reader.ss new file mode 100644 index 00000000..8407c35d --- /dev/null +++ b/collects/xml/reader.ss @@ -0,0 +1,346 @@ +(unit/sig reader^ + (import xml-structs^ mzlib:function^) + + ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) + (define-struct (start-tag struct:source) (name attrs)) + + ;; End-tag ::= (make-end-tag Location Location Symbol) + (define-struct (end-tag struct:source) (name)) + + ;; Token ::= Contents | Start-tag | End-tag | Eof + + (define read-comments (make-parameter #f)) + (define collapse-whitespace (make-parameter #f)) + + ;; read-xml : [Input-port] -> Document + (define read-xml + (case-lambda + [(in) (read-from-port in)] + [() (read-from-port (current-input-port))])) + + ;; read-from-port : Input-port -> Document + (define (read-from-port in) + (let*-values ([(in pos) (positionify in)] + [(misc0 start) (read-misc in pos)]) + (make-document (make-prolog misc0 #f) + (cond + [(start-tag? start) (read-element start in pos)] + [(element? start) start] + [else (error 'read-xml "expected root element - received ~a" start)]) + (let-values ([(misc1 end-of-file) (read-misc in pos)]) + (unless (eof-object? end-of-file) + (error 'read-xml "extra stuff at end of document ~a" end-of-file)) + misc1)))) + + ;; read-misc : Input-port (-> Nat) -> (listof Misc) Token + (define (read-misc in pos) + (let read-more () + (let ([x (lex in pos)]) + (cond + [(or (pi? x) (comment? x)) + (let-values ([(lst next) (read-more)]) + (values (cons x lst) next))] + [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x)))) + (read-more)] + [else (values null x)])))) + + ;; read-element : Start-tag Input-port (-> Nat) -> Element + (define (read-element start in pos) + (let ([name (start-tag-name start)] + [a (source-start start)] + [b (source-stop start)]) + (make-element + a b name (start-tag-attrs start) + (let read-content () + (let ([x (lex in pos)]) + (cond + [(eof-object? x) + (error 'read-xml "unclosed ~a tag at [~a ~a]" name a b)] + [(start-tag? x) (cons (read-element x in pos) (read-content))] + [(end-tag? x) + (unless (eq? name (end-tag-name x)) + (error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]" + name a b (end-tag-name x) (source-start x) (source-stop x))) + null] + [(entity? x) (cons (expand-entity x) (read-content))] + [(comment? x) (if (read-comments) + (cons x (read-content)) + (read-content))] + [else (cons x (read-content))])))))) + + ;; expand-entity : Entity -> (U Entity Pcdata) + ;; more here - allow expansion of user defined entities + (define (expand-entity x) + (let ([expanded (default-entity-table (entity-text x))]) + (if expanded + (make-pcdata (source-start x) (source-stop x) expanded) + x))) + + ;; default-entity-table : Symbol -> (U #f String) + (define (default-entity-table name) + (case name + [(amp) "&"] + [(lt) "<"] + [(gt) ">"] + [(quot) "\""] + [(apos) "'"] + [else #f])) + + ;; lex : Input-port (-> Nat) -> Token + (define (lex in pos) + (let ([c (peek-char in)]) + (cond + [(eof-object? c) c] + [(eq? c #\&) (lex-entity in pos)] + [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)] + [else (lex-pcdata in pos)]))) + + ;; lex-entity : Input-port (-> Nat) -> Entity + (define (lex-entity in pos) + (let ([start (pos)]) + (read-char in) + (let ([data (case (peek-char in) + [(#\#) + (read-char in) + (let ([n (case (peek-char in) + [(#\x) (read-char in) + (string->number (read-until #\; in pos) 16)] + [else (string->number (read-until #\; in pos))])]) + (unless (number? n) + (lex-error in pos "malformed numeric entity")) + n)] + [else + (begin0 + (lex-name in pos) + (unless (eq? (read-char in) #\;) + (lex-error in pos "expected ; at the end of an entity")))])]) + (make-entity start (pos) data)))) + + ;; lex-tag-cdata-pi-comment : Input-port (-> Nat) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment + (define (lex-tag-cdata-pi-comment in pos) + (let ([start (pos)]) + (read-char in) + (case (non-eof peek-char in pos) + [(#\!) + (read-char in) + (case (non-eof peek-char in pos) + [(#\-) (read-char in) + (unless (eq? (read-char in) #\-) + (lex-error in pos "expected second - after ) + (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)")) + ;(make-comment start (pos) data) + (make-comment data))] + [(#\[) (read-char in) + (unless (string=? (read-string 6 in) "CDATA[") + (lex-error in pos "expected CDATA following <[")) + (let ([data (lex-cdata-contents in pos)]) + (make-pcdata start (pos) data))] + [else (skip-dtd in pos) + (skip-space in) + (unless (eq? (peek-char in) #\<) + (lex-error in pos "expected pi, comment, or element after doctype")) + (lex-tag-cdata-pi-comment in pos)])] + [(#\?) (read-char in) + (let ([name (lex-name in pos)]) + (skip-space in) + (let ([data (lex-pi-data in pos)]) + (make-pi start (pos) name data)))] + [(#\/) (read-char in) + (let ([name (lex-name in pos)]) + (skip-space in) + (unless (eq? (read-char in) #\>) + (lex-error in pos "expected > to close ~a's end tag" name)) + (make-end-tag start (pos) name))] + [else + (let ([name (lex-name in pos)] + [attrs (lex-attributes in pos)]) + (skip-space in) + (case (read-char in) + [(#\/) + (unless (eq? (read-char in) #\>) + (lex-error in pos "expected > to close empty element ~a" name)) + (make-element start (pos) name attrs null)] + [(#\>) (make-start-tag start (pos) name attrs)] + [else (lex-error in pos "expected / or > to close tag ~a" name)]))]))) + + ;; lex-attributes : Input-port (-> Nat) -> (listof Attribute) + (define (lex-attributes in pos) + (quicksort (let loop () + (skip-space in) + (cond + [(name-start? (peek-char in)) + (cons (lex-attribute in pos) (loop))] + [else null])) + (lambda (a b) + (let ([na (attribute-name a)] + [nb (attribute-name b)]) + (cond + [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)] + [else (stringstring na) (symbol->string nb))]))))) + + ;; lex-attribute : Input-port (-> Nat) -> Attribute + (define (lex-attribute in pos) + (let ([start (pos)] + [name (lex-name in pos)]) + (skip-space in) + (unless (eq? (read-char in) #\=) + (lex-error in pos "expected = in attribute ~a" name)) + (skip-space in) + ;; more here - handle entites and disallow "<" + (let* ([delimiter (read-char in)] + [value (case delimiter + [(#\' #\") + (list->string + (let read-more () + (let ([c (non-eof peek-char in pos)]) + (cond + [(eq? c delimiter) (read-char in) null] + [(eq? c #\&) + (let ([entity (expand-entity (lex-entity in pos))]) + (if (pcdata? entity) + (append (string->list (pcdata-string entity)) (read-more)) + ;; more here - do something with user defined entites + (read-more)))] + [else (read-char in) (cons c (read-more))]))))] + [else (lex-error in pos "attribute values must be in ''s or in \"\"s")])]) + (make-attribute start (pos) name value)))) + + ;; skip-space : Input-port -> Void + ;; deviation - should sometimes insist on at least one space + (define (skip-space in) + (let loop () + (let ([c (peek-char in)]) + (when (and (not (eof-object? c)) (char-whitespace? c)) + (read-char in) + (loop))))) + + ;; lex-pcdata : Input-port (-> Nat) -> Pcdata + ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec + (define (lex-pcdata in pos) + (let ([start (pos)] + [data (let loop () + (let ([next (peek-char in)]) + (cond + [(or (eof-object? next) (eq? next #\&) (eq? next #\<)) + null] + [(and (char-whitespace? next) (collapse-whitespace)) + (skip-space in) + (cons #\space (loop))] + [else (cons (read-char in) (loop))])))]) + (make-pcdata start + (pos) + (list->string data)))) + + ;; lex-name : Input-port (-> Nat) -> Symbol + (define (lex-name in pos) + (let ([c (read-char in)]) + (unless (name-start? c) + (lex-error in pos "expected name, received ~a" c)) + (string->symbol + (list->string + (cons c (let lex-rest () + (cond + [(name-char? (peek-char in)) + (cons (read-char in) (lex-rest))] + [else null]))))))) + + ;; skip-dtd : Input-port (-> Nat) -> Void + (define (skip-dtd in pos) + (let skip () + (case (non-eof read-char in pos) + [(#\') (read-until #\' in pos) (skip)] + [(#\") (read-until #\" in pos) (skip)] + [(#\<) + (case (non-eof read-char in pos) + [(#\!) (case (non-eof read-char in pos) + [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)] + [else (skip) (skip)])] + [(#\?) (lex-pi-data in pos) (skip)] + [else (skip) (skip)])] + [(#\>) (void)] + [else (skip)]))) + + ;; name-start? : Char -> Bool + (define (name-start? ch) + (or (char-alphabetic? ch) + (eq? ch #\_) + (eq? ch #\:))) + + ;; name-char? : Char -> Bool + (define (name-char? ch) + (or (name-start? ch) + (char-numeric? ch) + (eq? ch #\.) + (eq? ch #\-))) + + ;; read-until : Char Input-port (-> Nat) -> String + ;; discards the stop character, too + (define (read-until char in pos) + (list->string + (let read-more () + (let ([c (non-eof read-char in pos)]) + (cond + [(eq? c char) null] + [else (cons c (read-more))]))))) + + ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Nat) -> Char + (define (non-eof f in pos) + (let ([c (f in)]) + (cond + [(eof-object? c) (lex-error in pos "unexpected eof")] + [else c]))) + + ;; gen-read-until-string : String -> Input-port (-> Nat) -> String + ;; uses Knuth-Morris-Pratt from + ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 + ;; discards stop from input + (define (gen-read-until-string stop) + (let* ([len (string-length stop)] + [prefix (make-vector len 0)] + [fall-back + (lambda (k c) + (let ([k (let loop ([k k]) + (cond + [(and (> k 0) (not (eq? (string-ref stop k) c))) + (loop (vector-ref prefix (sub1 k)))] + [else k]))]) + (if (eq? (string-ref stop k) c) + (add1 k) + k)))]) + (let init ([k 0] [q 1]) + (when (< q len) + (let ([k (fall-back k (string-ref stop q))]) + (vector-set! prefix q k) + (init k (add1 q))))) + ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop + (lambda (in pos) + (list->string + (let/ec out + (let loop ([matched 0] [out out]) + (let* ([c (non-eof read-char in pos)] + [matched (fall-back matched c)]) + (cond + [(= matched len) (out null)] + [(zero? matched) (cons c (let/ec out (loop matched out)))] + [else (cons c (loop matched out))])))))))) + + ;; "-->" makes more sense, but "--" follows the spec. + (define lex-comment-contents (gen-read-until-string "--")) + (define lex-pi-data (gen-read-until-string "?>")) + (define lex-cdata-contents (gen-read-until-string "]]>")) + + ;; positionify : Input-port -> Input-port (-> Nat) + (define (positionify in) + (let ([n 0]) + (values (make-input-port + (lambda () (set! n (add1 n)) (read-char in)) + (lambda () (char-ready? in)) + (lambda () (peek-char in))) + (lambda () n)))) + + ;; lex-error : Input-port String (-> Nat) TST* -> alpha + (define (lex-error in pos str . rest) + (error 'lex-error " at positon ~a: ~a" (pos) + (apply format str rest)))) \ No newline at end of file diff --git a/collects/xml/space.ss b/collects/xml/space.ss new file mode 100644 index 00000000..6eec5302 --- /dev/null +++ b/collects/xml/space.ss @@ -0,0 +1,28 @@ +(unit/sig space^ + (import xml-structs^ mzlib:function^) + + ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element + (define (eliminate-whitespace special eliminate-special?) + (letrec ([blank-it + (lambda (el) + (let ([name (element-name el)] + [content (map (lambda (x) + (if (element? x) (blank-it x) x)) + (element-content el))]) + (make-element + (source-start el) + (source-stop el) + name + (element-attributes el) + (cond + [(eliminate-special? (memq (element-name el) special)) + (filter (lambda (s) + (not (and (pcdata? s) + (or (all-blank (pcdata-string s)) + (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~s" name (pcdata-string s)))))) + content)] + [else content]))))]) + blank-it)) + + ;; all-blank : String -> Bool + (define (all-blank s) (andmap char-whitespace? (string->list s)))) diff --git a/collects/xml/structures.ss b/collects/xml/structures.ss new file mode 100644 index 00000000..392c81e4 --- /dev/null +++ b/collects/xml/structures.ss @@ -0,0 +1,43 @@ +(unit/sig xml-structs^ + (import) + + ;; Location ::= Nat | Symbol + ;; Source ::= (make-source Location Location) + (define-struct source (start stop)) + + ;; Document ::= (make-document Prolog Element (listof Misc)) + (define-struct document (prolog element misc)) + + ;; Prolog ::= (make-prolog (listof Misc) #f) + (define-struct prolog (misc dtd)) + + ;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content)) + (define-struct (element struct:source) (name attributes content)) + + ;; Attribute ::= (make-attribute Location Location Symbol String) + (define-struct (attribute struct:source) (name value)) + + ;; Pcdata ::= (make-pcdata Location Location String) + (define-struct (pcdata struct:source) (string)) + + ;; Content ::= Pcdata + ;; | Element + ;; | Entity + ;; | Misc + + ;; Misc ::= Comment + ;; | Processing-instruction + + ;; Entity ::= (make-entity Location Location (U Nat Symbol)) + (define-struct (entity struct:source) (text)) + + ;; Processing-instruction ::= (make-pi Location Location String (list String)) + ;; also represents XMLDecl + (define-struct (pi struct:source) (target-name instruction)) + + ;; Comment ::= (make-comment String) + (define-struct comment (text)) + + ;; content? : TST -> Bool + (define (content? x) + (or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))) \ No newline at end of file diff --git a/collects/xml/writer.ss b/collects/xml/writer.ss new file mode 100644 index 00000000..7c674e9a --- /dev/null +++ b/collects/xml/writer.ss @@ -0,0 +1,130 @@ +(unit/sig writer^ + (import xml-structs^ mzlib:function^) + + ;;(define empty-tag-shorthand (make-parameter #t)) + ;;(define empty-tag-shorthand (make-parameter void)) + + ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol)) + (define empty-tag-shorthand (make-parameter 'always)) + + (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) + + ;; var-argify : (a Output-port -> b) -> (a [Output-port] -> b) + (define (var-argify f) + (case-lambda + [(x out) (f x out)] + [(x) (f x (current-output-port))])) + + ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void + (define (gen-write/display-xml/content dent) + (var-argify (lambda (c out) (write-xml-content c 0 dent out)))) + + ;; indent : Nat Output-port -> Void + (define (indent n out) + (newline out) + (let loop ([n n]) + (unless (zero? n) + (display #\space out) + (loop (sub1 n))))) + + ;; write-xml/content : Content [Output-port] -> Void + (define write-xml/content (gen-write/display-xml/content void)) + + ;; display-xml/content : Content [Output-port] -> Void + (define display-xml/content (gen-write/display-xml/content indent)) + + ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void + (define (gen-write/display-xml output-content) + (var-argify (lambda (doc out) + (display-outside-misc (prolog-misc (document-prolog doc)) out) + (output-content (document-element doc) out) + (display-outside-misc (document-misc doc) out)))) + + ;; write-xml : Document [Output-port] -> Void + (define write-xml (gen-write/display-xml write-xml/content)) + + ;; display-xml : Document [Output-port] -> Void + (define display-xml (gen-write/display-xml display-xml/content)) + + ;; display-outside-misc : (listof Misc) Output-port -> Void + (define (display-outside-misc misc out) + (for-each (lambda (x) + ((cond + [(comment? x) write-xml-comment] + [(pi? x) write-xml-pi]) x 0 void out) + (newline out)) + misc)) + + ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-content el over dent out) + ((cond + [(element? el) write-xml-element] + [(pcdata? el) write-xml-pcdata] + [(entity? el) write-xml-entity] + [(comment? el) write-xml-comment] + [(pi? el) write-xml-pi] + [else (error 'write-xml-content "received ~a" el)]) + el over dent out)) + + ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-element el over dent out) + (let* ([name (element-name el)] + [start (lambda (f) (write-xml-base (format f name) over dent out))] + [content (element-content el)]) + (start "<~a") + (for-each (lambda (att) + (fprintf out " ~s=~s" (attribute-name att) + (escape (attribute-value att) escape-attribute-table))) + (element-attributes el)) + (if (and (null? content) + (let ([short (empty-tag-shorthand)]) + (case short + [(always) #t] + [(never) #f] + [else (memq name short)]))) + (fprintf out " />") + (begin + (fprintf out ">") + (for-each (lambda (c) (write-xml-content c (incr over) dent out)) content) + (start ""))))) + + ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-base el over dent out) + (dent over out) + (display el out)) + + ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-pcdata str over dent out) + (write-xml-base (escape (pcdata-string str) escape-table) over dent out)) + + ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-pi pi over dent out) + (write-xml-base (format "" (pi-target-name pi) (pi-instruction pi)) over dent out)) + + ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void + (define (write-xml-comment comment over dent out) + (write-xml-base (format "" (comment-text comment)) over dent out)) + + ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void + (define (write-xml-entity entity over dent out) + (let ([n (entity-text entity)]) + (fprintf out (if (number? n) "&#~a;" "&~a;") n))) + + (define escape-table + (map (lambda (x y) (cons (regexp (symbol->string x)) y)) + '(< > &) + '("\\<" "\\>" "\\&"))) + + (define escape-attribute-table + (list* (cons (regexp "'") "\\'") (cons (regexp "\"") "\\"") escape-table)) + + ;; escape : String -> String + ;; more here - this could be much more efficient + (define (escape x table) + (foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc))) + x + table)) + + ;; incr : Nat -> Nat + (define (incr n) (+ n 2))) diff --git a/collects/xml/xexpr.ss b/collects/xml/xexpr.ss new file mode 100644 index 00000000..16e8dd0e --- /dev/null +++ b/collects/xml/xexpr.ss @@ -0,0 +1,82 @@ +(unit/sig extra-xexpr^ + (import xml-structs^ writer^ mzlib:function^) + ;; Xexpr ::= String + ;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) + ;; | (cons Symbol (listof Xexpr)) + ;; | Symbol + ;; | Nat + ;; | Comment + ;; | Processing-instruction + ;; Attribute-srep ::= (list Symbol String) + + ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts. + + ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a)) + (define (assoc-sort to-sort) + (quicksort to-sort (bcompose stringstring car)))) + + (define xexpr-drop-empty-attributes (make-parameter #f)) + + ;; xml->xexpr : Content -> Xexpr + ;; The contract is loosely enforced. + (define (xml->xexpr x) + (let* ([non-dropping-combine + (lambda (atts body) + (cons (assoc-sort (map attribute->srep atts)) + body))] + [combine (if (xexpr-drop-empty-attributes) + (lambda (atts body) + (if (null? atts) + body + (non-dropping-combine atts body))) + non-dropping-combine)]) + (let loop ([x x]) + (cond + [(element? x) + (let ([body (map loop (element-content x))] + [atts (element-attributes x)]) + (cons (element-name x) (combine atts body)))] + [(pcdata? x) (pcdata-string x)] + [(entity? x) (entity-text x)] + [(or (comment? x) (pi? x)) x] + [(document? x) (error 'xml->xexpr "Expected content, given ~a~nUse document-element to extract the content." x)] + [else (error 'xml->xexpr "Expected content, given ~a" x)])))) + + ;; attribute->srep : Attribute -> Attribute-srep + (define (attribute->srep a) + (list (attribute-name a) (attribute-value a))) + + ;; srep->attribute : Attribute-srep -> Attribute + (define (srep->attribute a) + (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a))) + (error 'srep->attribute "expected (cons Symbol String) given ~a" a)) + (make-attribute 'scheme 'scheme (car a) (cadr a))) + + ;; xexpr->xml : Xexpr -> Content + ;; The contract is enforced. + (define (xexpr->xml x) + (cond + [(pair? x) + (let ([f (lambda (atts body) + (unless (list? body) + (error 'xexpr->xml "expected a list of xexprs a the body in ~a" x)) + (make-element 'scheme 'scheme (car x) + atts + (map xexpr->xml body)))]) + (if (and (pair? (cdr x)) (or (null? (cadr x)) (and (pair? (cadr x)) (pair? (caadr x))))) + (f (map srep->attribute (cadr x)) (cddr x)) + (f null (cdr x))))] + [(string? x) (make-pcdata 'scheme 'scheme x)] + [(or (symbol? x) (and (integer? x) (>= x 0))) (make-entity 'scheme 'scheme x)] + [(or (comment? x) (pi? x)) x] + [else (error 'xexpr->xml "malformed xexpr ~s" x)])) + + ;; xexpr->string : Xexpression -> String + (define (xexpr->string xexpr) + (let ([port (open-output-string)]) + (write-xml/content (xexpr->xml xexpr) port) + (get-output-string port))) + + ;; bcompose : (a a -> c) (b -> a) -> (b b -> c) + (define (bcompose f g) + (lambda (x y) (f (g x) (g y))))) diff --git a/collects/xml/xml.ss b/collects/xml/xml.ss new file mode 100644 index 00000000..6632de9d --- /dev/null +++ b/collects/xml/xml.ss @@ -0,0 +1,9 @@ +(require-library "xmls.ss" "xml") +(define-values/invoke-unit/sig + xml^ + (compound-unit/sig + (import) + (link + (FUN : mzlib:function^ ((require-library "functior.ss"))) + (X : xml^ ((require-library "xmlr.ss" "xml") FUN))) + (export (open X)))) \ No newline at end of file diff --git a/collects/xml/xmlr.ss b/collects/xml/xmlr.ss new file mode 100644 index 00000000..680a9cf8 --- /dev/null +++ b/collects/xml/xmlr.ss @@ -0,0 +1,9 @@ +(compound-unit/sig + (import (FUN : mzlib:function^)) + (link + (S : xml-structs^ ((require-library "structures.ss" "xml"))) + (R : reader^ ((require-library "reader.ss" "xml") S FUN)) + (U : writer^ ((require-library "writer.ss" "xml") S FUN)) + (T : xexpr^ ((require-library "xexpr.ss" "xml") S U FUN)) + (W : space^ ((require-library "space.ss" "xml") S FUN))) + (export (open S) (open R) (open U) (open T) (open W))) diff --git a/collects/xml/xmls.ss b/collects/xml/xmls.ss new file mode 100644 index 00000000..0a8e00c7 --- /dev/null +++ b/collects/xml/xmls.ss @@ -0,0 +1,23 @@ +(require-library "functios.ss") +(require-library "invoke.ss") + +(define-signature xml-structs^ + ((struct document (prolog element misc)) + (struct comment (text)) + (struct prolog (misc dtd)) + (struct element (name attributes content)) + (struct attribute (name value)) + (struct pi (target-name instruction)) + (struct source (start stop)) + (struct pcdata (string)) + (struct entity (text)) + content?)) + +(define-signature writer^ (write-xml display-xml write-xml/content display-xml/content empty-tag-shorthand html-empty-tags)) +(define-signature reader^ (read-xml read-comments collapse-whitespace)) + +(define-signature xexpr^ (xml->xexpr xexpr->xml xexpr->string xexpr-drop-empty-attributes)) +(define-signature extra-xexpr^ ((open xexpr^) assoc-sort bcompose attribute->srep)) +(define-signature space^ (eliminate-whitespace)) +(define-signature xml^ ((open xml-structs^) (open reader^) (open writer^) (open xexpr^) (open space^))) + diff --git a/collects/zodiac/back.ss b/collects/zodiac/back.ss new file mode 100644 index 00000000..4cb76422 --- /dev/null +++ b/collects/zodiac/back.ss @@ -0,0 +1,85 @@ +; $Id: back.ss,v 1.4 1997/07/21 15:51:43 shriram Exp $ + +(unit/sig zodiac:back-protocol^ + (import zodiac:misc^ zodiac:interface^) + + (define-struct secure-box (value)) + + (define init-value-list '()) + + (define register-initial-value + (lambda (index value-thunk) + (set! init-value-list + (append init-value-list + (list value-thunk))))) + + (define make-initial-value-vector + (lambda () + (let ((v (make-vector current-vector-size uninitialized-flag))) + (let loop ((index 0) (inits init-value-list)) + (unless (null? inits) + (vector-set! v index ((car inits))) + (loop (add1 index) (cdr inits)))) + v))) + + (define make-empty-back-box + (lambda () + (make-secure-box (make-initial-value-vector)))) + + (define current-vector-size 2) + + (define next-client-count + (let ((count -1)) + (lambda () + (set! count (add1 count)) + (when (>= count current-vector-size) + (set! current-vector-size (* 2 current-vector-size))) + count))) + + (define-struct uninitialized-back ()) + (define uninitialized-flag (make-uninitialized-back)) + + (define client-registry (make-hash-table)) + + (define register-client + (lambda (client-name default-initial-value-thunk) + (when (hash-table-get client-registry client-name + (lambda () #f)) + (internal-error client-name "Attempting duplicate registration")) + (hash-table-put! client-registry client-name #t) + (let ((index (next-client-count))) + (register-initial-value index default-initial-value-thunk) + (values + (lambda (back) ; getter + (let ((v (secure-box-value back))) + (with-handlers + ((exn:application:mismatch? + (lambda (exception) + (vector-ref (extend-back-vector back) index)))) + (let ((value (vector-ref v index))) + (if (uninitialized-back? value) + (let ((correct-value + ((list-ref init-value-list index)))) + (vector-set! v index correct-value) + correct-value) + value))))) + (lambda (back value) ; setter + (let ((v (secure-box-value back))) + (with-handlers + ((exn:application:mismatch? + (lambda (exception) + (vector-set! (extend-back-vector back) index value)))) + (vector-set! v index value)))))))) + + (define extend-back-vector + (lambda (back-box) + (let ((v (secure-box-value back-box))) + (let ((new-v (make-initial-value-vector))) + (let loop ((n (sub1 (vector-length v)))) + (when (>= n 0) + (vector-set! new-v n (vector-ref v n)) + (loop (sub1 n)))) + (set-secure-box-value! back-box new-v) + new-v)))) + + ) diff --git a/collects/zodiac/basestr.ss b/collects/zodiac/basestr.ss new file mode 100644 index 00000000..39744a07 --- /dev/null +++ b/collects/zodiac/basestr.ss @@ -0,0 +1,19 @@ +;; +;; zodiac:structures@ +;; $Id$ +;; +;; Top-level zodiac structures (outside the hierarchy) +;; and base of zodiac hierarchy. +;; + +(unit/sig zodiac:structures^ + (import) + + (define-struct origin (who how)) + (define-struct location (line column offset file)) + (define-struct period (location)) + (define-struct eof (location)) + + (define-struct zodiac (origin start finish)) + ) + diff --git a/collects/zodiac/corelate.ss b/collects/zodiac/corelate.ss new file mode 100644 index 00000000..00386e98 --- /dev/null +++ b/collects/zodiac/corelate.ss @@ -0,0 +1,34 @@ +; $Id$ + +(unit/sig zodiac:correlate^ + (import zodiac:structures^) + + (define-struct entry (location slots)) + + (define make-correlator + (lambda () + (box '()))) + + (define find-in-correlator + (lambda (location correlator) + (let loop ((entries (unbox correlator))) + (if (null? entries) #f + (let ((first (car entries))) + (if (same-location? location (entry-location first)) first + (loop (cdr entries)))))))) + + (define add-to-correlator + (lambda (location slot correlator) + (let ((entry (find-in-correlator location correlator))) + (if entry + (set-entry-slots! entry (cons slot (entry-slots entry))) + (set-box! correlator + (cons (make-entry location (list slot)) + (unbox correlator))))))) + + (define same-location? + (lambda (l1 l2) + (and (= (location-offset l1) (location-offset l2)) + (equal? (location-file l1) (location-file l2))))) + + ) diff --git a/collects/zodiac/doc.txt b/collects/zodiac/doc.txt new file mode 100644 index 00000000..69498350 --- /dev/null +++ b/collects/zodiac/doc.txt @@ -0,0 +1,195 @@ + +Using _Zodiac_ +-------------- + +The top-level way: + + (require-library "invoke.ss" "zodiac") + ; binds global names prefixed with `zodiac:'; + ; zodiac:internal-error and zodiac:static-error + ; can be redefined afterwards. + +The unit/sig way: + + Elaboration time: + (require-library "zsigs.ss" "zodiac") + (require-library "sigs.ss" "zodiac") + + Link time: + (require-library-unit/sig "link.ss" "zodiac") + Imports: + zodiac:interface^ ; see "Error Handlers" below + mzlib:pretty-print^ + mzlib:file^ + Exports: + zodiac:system^ ; no `zodiac:' prefix + +Reader Procedures +----------------- + +> (zodiac:read p (zodiac:make-location 1 1 0 filename)) - reads from + the port `p', which represents the file indicated by the `filename' + string. Returns a PROCEDURE that gets each expression as a zodiac + AST. When the reader encounters an eof-of-file, it returns an + instance of zodiac:eof. + +Expander Procedures +------------------- + +> (zodiac:scheme-expand expr [attr 'previous] [vocab #f]) - expands + one expression, reprsented as a zodiac AST, returning a zodiac AST. + +> (zodiac:scheme-expand-program exprs [attr 'previous] [vocab #f]) - + expands several expressions, reprsented as a list of zodiac ASTs, + returning a list of zodiac ASTs. + +Zodiac AST -> S-Expression +-------------------------- + +> (zodiac:parsed->raw expr) - converts a zodiac AST to an S-expression + (losing location information, obviously). + +Vocabularies +------------ + +> beginner-vocabulary +> intermediate-vocabulary +> advanced-vocabulary +> full-vocabulary - advanced + units and objects +> scheme-vocabulary - MzScheme (unlike full-vocabulary, local, send*, + etc. are not present until the correcponding + `define-macro' expression in MzLib is evaluated + at elaboration time) + +Handler Parameters +------------------ + +> (elaboration-evaluator [proc]) - parameter for the evaluatotr used + to evaluate begin-elaboration-time bodies and the RHS of a macro + definition. + + default: (lambda (expr parsed->raw phase) + (eval (parsed->raw expr))) + +> (user-macro-body-evaluator [proc]) - parameter for the evaluator + used to evaluate macro applications. + + default: (lambda (x . args) + (eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args)))) + +Error Handlers +-------------- + +Zodiac relies on two error handlers that are provided by its +> zodiac:interface^ +import: +> internal-error - for when things go wrong in zodiac that should + never go wrong +> static-error - for input errors during read or expand. + +A zodiac error handler takes a zodiac AST followed by format-style + arguments. For example: + + (define (static-error where fmt-spec . args) + (printf "Error at: ~s~n" where) ; or, pull location out of `where' + (apply error 'syntax-error fmt-spec args)) + +Example +------- + + (require-library "invoke.ss" "zodiac") + (let ([r ((zodiac:read (open-input-string "(cons 1 null)") + (zodiac:make-location 1 1 0 "string")))]) + (eval (zodiac:parsed->raw (zodiac:scheme-expand r)))) + = (list 1) + + +Correlating Source +------------------ + +Quickref: + + who how principal to a source expression? + --- --- --------------------------------- + 'source ... yes + 'reader ... yes + 'duplicate ... no + 'micro expr iff expr is principal + 'macro expr iff expr is principal + 'non-source ... no + +Details: + +Zodiac's start and end locations provide a client with a mapping from +fully elaborated "E-expressions" to source S-expressions. For example, +Aries relies on the E->S mapping to hilite a specific S-expression in +response to a run-time error for a particular E-expression. Certain +tools, such as DrScheme's syntax checker, require an S->E mapping, +instead. However, the inverse of the E->S relation is not a mapping, +because E->S can map many E-expressions to one S-expression, and it +can map zero E-expressions to some S-expressions. For example, (cond +[#f 5][#t 6]) expands to (if #f 5 (if #t 6)), where the `cond' +S-expression is identified as the source of both `if' +E-expressions. Other elaborations drop an S-expression entirely, such +that an S-expression has no reprentative in the final E-expression. + +The `origin' field of an E-expression provides information +for approximating an S->E function by dropping E-expression elements +from the E->S domain before inverting the relation. More specifically, +the `origin' field identifies each E-expression as either the +principal representative of its source expression or not. Zodiac +guarantees that at most one E-expression is a principal expression for +each S-expression in the source. + +Principal E-Expressions +- - - - - - - - - - - - + +A principal E-expression is not chosen arbitrarily. In the case of +'source, 'reader, 'macro, and 'micro principals, the E-expression is +equivalent to its S-expression in the sense that it encapsulates the +entire original expression. Thus, in the elaboration from (cond [#f +5][#t 6]) to (if #f 5 (if #t 6)), the outer `if' is identified as the +principal E-expression. The inner `if' encapsulates only a part of the +original `cond' expression (and it does not encapsulate any complete +expression from the source). + +Here's a more complete dissection of a slightly larger example: + + (cond [#f 5][#t (+ 3 3)]) + => (if #f 5 (if #t (+ 3 3))) + ^ ^ ^ ^ ^ ^^ ^-^- 'reader + | | | | | |`- 'source + | | | | | `- 'source + | | | | `- 'reader + | | | `- 'non-source + | | `- 'reader + | `- 'reader + `- 'micro; the how field points to the `cond' expression, which + has a source-who value of 'source + +Macros/micros that expand to macros/micros produce chains of origin +records. For example, (or a b) expands to (let ([g a]) ...) which +expands to (let-values ([(g) a]) ...). The source for the final +`letrec-values' expression is 'macro; the source-how field points to +the `let' expression, whose source is also 'macro. Finally, the +source-how field for the `let' expression is the `or' expression, +which has a 'source origin. + +Non-principal E-Expressions +- - - - - - - - - - - - - - + +The 'duplicate who value is used when a macro/micro duplcates a source +expression in its output, such as the `loop' in `(let loop () (loop))' +=> `(letrec ([loop (lambda () (loop))]) (loop))'). All but the first +instance of the duplicated expression get a 'duplcate source-who +annotation. (The source-how field contains the original source +record.) + +The 'non-source value for the who field indicates that there is no +source expression that is equivalent to the expanded expression. In +this case, a macro or micro must have manufactured the syntax; for +example, the `this' binding intoroduced by class* -> class*/names has +source-who value 'non-source. Of course, the location field of +"non-source" syntax still matches the syntax to a particular source +expression. Similarly, the nested `if' in the expansion of `cons' +contains a manufactured `if' expression. diff --git a/collects/zodiac/info.ss b/collects/zodiac/info.ss new file mode 100644 index 00000000..e6c4e56d --- /dev/null +++ b/collects/zodiac/info.ss @@ -0,0 +1,13 @@ + +(lambda (request failure) + (case request + [(name) "zodiac"] + [(compile-prefix) '(begin + (require-library "refer.ss") + (require-library "zsigs.ss" "zodiac") + (require-library "sigs.ss" "zodiac"))] + [(compile-omit-files) + (list "sigs.ss" "zsigs.ss" "scm-hanc.ss" "quasi.ss")] + [(compile-elaboration-zos) + (list "zsigs.ss" "sigs.ss")] + [else (failure)])) diff --git a/collects/zodiac/invoke.ss b/collects/zodiac/invoke.ss new file mode 100644 index 00000000..9a174891 --- /dev/null +++ b/collects/zodiac/invoke.ss @@ -0,0 +1,79 @@ +; $Id: invoke.ss,v 1.40 1999/05/27 15:48:55 mflatt Exp $ + +(begin-elaboration-time + (require-library "cores.ss")) + +(require-library "coreu.ss") + +(require-library "load.ss" "zodiac") + +(define zodiac:default-interface@ + (unit/sig zodiac:interface^ + (import) + (define default-error-handler + (lambda (keyword) + (lambda (where fmt-spec . args) + (printf "Error at: ~s~n" where) + (apply error keyword fmt-spec args)))) + (define internal-error + (default-error-handler 'internal-error)) + (define static-error + (default-error-handler 'syntax-error)))) + +(define zodiac:system@ + (require-library-unit/sig "link.ss" "zodiac")) + +(begin-elaboration-time + (require-library "invoke.ss")) + +(define-values/invoke-unit/sig ((open zodiac:system^) + (open zodiac:interface^)) + (compound-unit/sig + (import) + (link + (INTERFACE : zodiac:interface^ + (zodiac:default-interface@)) + (SYSTEM : zodiac:system^ + (zodiac:system@ INTERFACE + (MZLIB-CORE pretty-print) + (MZLIB-CORE file))) + (MZLIB-CORE : mzlib:core^ + (mzlib:core@))) + (export (open SYSTEM) (open INTERFACE))) + zodiac) + +(define (zodiac:make-see expander) + (opt-lambda ((show-raw? #t)) + (parameterize ([current-prompt-read + (lambda () + (newline) + (display "e> ") + (flush-output) + (let ([read ((zodiac:read))]) + (newline) + (flush-output) + (if (zodiac:eof? read) + eof + read)))] + [current-eval + (lambda (in) + (let ((e (car (expander in)))) + (if show-raw? + (zodiac:parsed->raw e) + e)))]) + (read-eval-print-loop)))) + +(define zodiac:see (zodiac:make-see + (lambda (in) + (zodiac:scheme-expand-program (list in))))) + +(define zodiac:see-parsed (zodiac:make-see + (lambda (in) + (zodiac:scheme-expand-program (list in))))) + +(define zodiac:spidey-see (zodiac:make-see + (lambda (in) + (zodiac:scheme-expand-program + (list in) + (zodiac:make-attributes) + zodiac:mrspidey-vocabulary)))) diff --git a/collects/zodiac/link.ss b/collects/zodiac/link.ss new file mode 100644 index 00000000..b13f4ddb --- /dev/null +++ b/collects/zodiac/link.ss @@ -0,0 +1,80 @@ +; $Id: link.ss,v 1.16 1999/02/02 19:33:14 mflatt Exp $ + +(compound-unit/sig + (import + (INTERFACE : zodiac:interface^) + (PRETTY : mzlib:pretty-print^) + (MZLIB-FILE : mzlib:file^)) + (link + [MISC : zodiac:misc^ + ((require-relative-library-unit/sig "misc.ss") PRETTY)] + [TOP-STRUCTS : zodiac:structures^ + ((require-relative-library-unit/sig "basestr.ss"))] + [SCAN-STRUCTS : zodiac:scanner-structs^ + ((require-relative-library-unit/sig "scanstr.ss") + TOP-STRUCTS)] + [READ-STRUCTS : zodiac:reader-structs^ + ((require-relative-library-unit/sig "readstr.ss") + TOP-STRUCTS)] + [SCAN-PARMS : zodiac:scanner-parameters^ + ((require-relative-library-unit/sig "scanparm.ss") + TOP-STRUCTS)] + [SCAN-CODE : zodiac:scanner-code^ + ((require-relative-library-unit/sig "scanner.ss") + TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS + SCAN-PARMS INTERFACE)] + [READ-CODE : zodiac:reader-code^ + ((require-relative-library-unit/sig "reader.ss") + TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS + SCAN-PARMS INTERFACE SCAN-CODE)] + [SEXP : zodiac:sexp^ + ((require-relative-library-unit/sig "sexp.ss") + MISC TOP-STRUCTS READ-STRUCTS INTERFACE + SCHEME-MAIN)] + [PATTERN : zodiac:pattern^ + ((require-relative-library-unit/sig "pattern.ss") + MISC SEXP READ-STRUCTS SCHEME-CORE)] + [EXPANDER : zodiac:expander^ + ((require-relative-library-unit/sig "x.ss") + MISC SEXP TOP-STRUCTS READ-STRUCTS + SCHEME-CORE INTERFACE)] + [CORRELATE : zodiac:correlate^ + ((require-relative-library-unit/sig "corelate.ss") + TOP-STRUCTS)] + [BACK-PROTOCOL : zodiac:back-protocol^ + ((require-relative-library-unit/sig "back.ss") + MISC INTERFACE)] + [SCHEME-CORE : zodiac:scheme-core^ + ((require-relative-library-unit/sig "scm-core.ss") + TOP-STRUCTS MISC SEXP READ-STRUCTS + BACK-PROTOCOL EXPANDER INTERFACE PATTERN)] + [SCHEME-MAIN : zodiac:scheme-main^ + ((require-relative-library-unit/sig "scm-main.ss") + MISC TOP-STRUCTS SCAN-PARMS + READ-STRUCTS READ-CODE SEXP + PATTERN SCHEME-CORE BACK-PROTOCOL EXPANDER INTERFACE)] + [SCHEME-SPIDEY : zodiac:scheme-mrspidey^ + ((require-relative-library-unit/sig "scm-spdy.ss") + MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP PATTERN + SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE + MZLIB-FILE)] + [SCHEME-OBJ : zodiac:scheme-objects^ + ((require-relative-library-unit/sig "scm-obj.ss") + MISC TOP-STRUCTS READ-STRUCTS SEXP + PATTERN SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE)] + [SCHEME-UNIT : zodiac:scheme-units^ + ((require-relative-library-unit/sig "scm-unit.ss") + MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP + PATTERN SCHEME-CORE SCHEME-MAIN SCHEME-OBJ BACK-PROTOCOL EXPANDER INTERFACE)] + [SCHEME-OBJ+UNIT : zodiac:scheme-objects+units^ + ((require-relative-library-unit/sig "scm-ou.ss") + MISC TOP-STRUCTS READ-STRUCTS SEXP PATTERN EXPANDER INTERFACE + SCHEME-CORE SCHEME-MAIN SCHEME-OBJ SCHEME-UNIT)]) + (export (open TOP-STRUCTS) (open SCAN-PARMS) + (open READ-STRUCTS) (open READ-CODE) + (open SEXP) (open PATTERN) (open CORRELATE) (open BACK-PROTOCOL) + (open EXPANDER) + (open SCHEME-CORE) (open SCHEME-MAIN) + (open SCHEME-OBJ) (open SCHEME-UNIT) + (open SCHEME-OBJ+UNIT) + (open SCHEME-SPIDEY))) diff --git a/collects/zodiac/load.ss b/collects/zodiac/load.ss new file mode 100644 index 00000000..02c9f990 --- /dev/null +++ b/collects/zodiac/load.ss @@ -0,0 +1,12 @@ +; $Id: load.ss,v 1.20 1998/04/21 02:59:55 robby Exp $ + +(require-library "macro.ss") +(require-library "cores.ss") + +(require-library "zsigs.ss" "zodiac") +(require-library "sigs.ss" "zodiac") + +; All this stuff needs to be disappeared. + +(define zodiac:system@ + (require-library-unit/sig "link.ss" "zodiac")) diff --git a/collects/zodiac/make.ss b/collects/zodiac/make.ss new file mode 100644 index 00000000..63c9db93 --- /dev/null +++ b/collects/zodiac/make.ss @@ -0,0 +1,27 @@ +; $Id$ + +(printf "Loading ...~n") +(load "invoke.ss") + +(require-library "compile.ss") + +(define file-names + '("corelate" "invoke" "link" "misc" "pattern" "back" + "scm-core" "scm-main" "scm-obj" "scm-unit" "scm-ou" "scm-spdy" + "sexp" "sigs" "x" "zsigs" "basestr" "readstr" "reader" + "scanner" "scanparm" "scanstr")) + +(printf "Deleting ...~n") +(for-each (lambda (f) + (delete-file (string-append f ".zo"))) + file-names) + +(for-each (lambda (f) + (printf "Compiling ~a~n" f) + (compile-file (string-append f ".ss") + (string-append f ".zo"))) + file-names) + +(printf "Done!~n") + +(exit) diff --git a/collects/zodiac/misc.ss b/collects/zodiac/misc.ss new file mode 100644 index 00000000..eefce6fd --- /dev/null +++ b/collects/zodiac/misc.ss @@ -0,0 +1,46 @@ +; $Id: misc.ss,v 1.8 1998/03/15 00:08:15 mflatt Exp $ + +(unit/sig zodiac:misc^ + (import (mz-pp : mzlib:pretty-print^)) + + (define attributes-resetters + (let ([x null]) + (case-lambda + [() x] + [(y) (set! x y)]))) + + ; This is to get around an ordering problem. Otherwise uses of + ; pretty-print show up as #, since this pretty-print + ; captures the MzScheme pretty-print too soon. + + (define pretty-print + (lambda args + (apply mz-pp:pretty-print args))) + + (define debug-level-list '(expand expose resolve lex-res)) + (define debug-level '()) + + (define symbol-append + (lambda args + (string->symbol + (apply string-append + (map (lambda (s) + (cond + ((string? s) s) + ((symbol? s) (symbol->string s)) + ((number? s) (number->string s)) + (else + (error 'symbol-append "~s illegal" s)))) + args))))) + + (define flush-printf + (lambda (format . args) + (apply printf format args) + (flush-output))) + + (define print-and-return + (lambda (v) + (pretty-print v) (newline) + v)) + + ) diff --git a/collects/zodiac/pattern.ss b/collects/zodiac/pattern.ss new file mode 100644 index 00000000..683bf728 --- /dev/null +++ b/collects/zodiac/pattern.ss @@ -0,0 +1,151 @@ +; $Id: pattern.ss,v 1.5 1998/05/08 22:15:22 mflatt Exp $ + +; Uses of memq are okay, since they look up pattern var in kwd list + +; Use of equal? WILL FAIL! + +(unit/sig zodiac:pattern^ + (import zodiac:misc^ zodiac:sexp^ + (z : zodiac:reader-structs^) zodiac:scheme-core^) + + (define (syntax-andmap pred l) + (andmap pred (expose-list l))) + + (define (syntax-ormap pred l) + (ormap pred (expose-list l))) + + ; ---------------------------------------------------------------------- + + (define make-match&env + (lambda (p k) ; pattern x kwd + (letrec + ((m&e + (lambda (p) + (cond + ((ellipsis? p) + (let ((p-head (car p))) + (let ((nestings (get-ellipsis-nestings p-head k))) + (let ((match-head (m&e p-head))) + (lambda (e esc env) + (if (z:list? e) + (list (cons nestings + (map (lambda (e) (match-head e esc env)) + (expose-list e)))) + (esc #f))))))) + ((pair? p) + (let ((match-head (m&e (car p))) + (match-tail (m&e (cdr p)))) + (lambda (e esc env) + (if (or (and (z:list? e) + (not (syntax-null? e))) + (z:improper-list? e)) + (append (match-head (syntax-car e) esc env) + (match-tail (syntax-cdr e) esc env)) + (esc #f))))) + ((null? p) + (lambda (e esc env) + (if (syntax-null? e) '() (esc #f)))) + ((symbol? p) + (if (memq p k) + (lambda (e esc env) + (if (z:symbol? e) + (if (lexically-resolved? e env) + (esc #f) + (if (name-eq? p (z:read-object e)) + '() + (esc #f))) + (esc #f))) + (lambda (e esc env) + (list (cons p e))))) + (else + (lambda (e esc env) + (if (equal? p e) '() (esc #f)))))))) + (m&e p)))) + + (define match-against + (lambda (matcher e env) + (let/ec esc + (matcher e esc env)))) + + (define penv-merge append) + + (define extend-penv + (lambda (name output env) + (cons (cons name output) env))) + + ; ---------------------------------------------------------------------- + + (define pexpand + (lambda (p r k) ; pattern x p-env x kwd + (letrec + ((expander + (lambda (p r) + (cond + ((ellipsis? p) + (append + (let* ((p-head (car p)) + (nestings (get-ellipsis-nestings p-head k)) + (rr (ellipsis-sub-envs nestings r))) + (map (lambda (r1) + (expander p-head (append r1 r))) + rr)) + (expander (cddr p) r))) + ((pair? p) + (cons (expander (car p) r) + (expander (cdr p) r))) + ((symbol? p) + (if (memq p k) p + (let ((x (assq p r))) + (if x (cdr x) p)))) + (else p))))) + (expander p r)))) + +;;; returns a list that nests a pattern variable as deeply as it +;;; is ellipsed + (define get-ellipsis-nestings + (lambda (p k) + (let sub ((p p)) + (cond ((ellipsis? p) (list (sub (car p)))) + ((pair? p) (append (sub (car p)) (sub (cdr p)))) + ((symbol? p) (if (memq p k) '() (list p))) + (else '()))))) + +;;; finds the subenvironments in r corresponding to the ellipsed +;;; variables in nestings + (define ellipsis-sub-envs + (lambda (nestings r) + (ormap (lambda (c) + (if (contained-in? nestings (car c)) (cdr c) #f)) + r))) + +;;; checks if nestings v and y have an intersection + (define contained-in? + (lambda (v y) + (if (or (symbol? v) (symbol? y)) (eq? v y) + (ormap (lambda (v_i) + (ormap (lambda (y_j) + (contained-in? v_i y_j)) + y)) + v)))) + +;;; tests if x is an ellipsing pattern, i.e., of the form +;;; (blah ... . blah2) + (define ellipsis? + (lambda (x) + (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))) + + ; ---------------------------------------------------------------------- + + (define match-and-rewrite + (case-lambda + ((expr rewriter out kwd env) + (let ((p-env (match-against rewriter expr env))) + (and p-env + (pexpand out p-env kwd)))) + ((expr rewriter out kwd succeed fail env) + (let ((p-env (match-against rewriter expr env))) + (if p-env + (succeed (pexpand out p-env kwd)) + (fail)))))) + + ) diff --git a/collects/zodiac/quasi.ss b/collects/zodiac/quasi.ss new file mode 100644 index 00000000..76eaefa6 --- /dev/null +++ b/collects/zodiac/quasi.ss @@ -0,0 +1,121 @@ +; $Id: quasi.ss,v 1.9 1999/02/04 14:32:53 mflatt Exp $ + +; Fix the null? in qq-normalize. + +(define qq-normalize + (lambda (new old) + (if (eq? new old) + (if (and (z:list? new) (zero? (z:sequence-length new))) + 'null + (list '#%quote new)) + new))) + +(define qq-process + (lambda (e source env attributes vocab) + (expand-expr + (structurize-syntax e source) + env attributes vocab))) + +(define quasiquote-micro + (let* ((kwd '()) + (in-pattern '(_ template)) + (m&e (pat:make-match&env in-pattern kwd)) + (qq-pattern-1 '(unquote body)) + (qq-pattern-2 '(unquote x ...)) + (qq-pattern-3 '(quasiquote x ...)) + (qq-pattern-4 '(unquote-splicing x ...)) + (qq-pattern-5 '((unquote-splicing body) . rest)) + (qq-pattern-6 '((unquote-splicing x ...) . y)) + (qq-m&e-1 (pat:make-match&env qq-pattern-1 '(unquote))) + (qq-m&e-2 (pat:make-match&env qq-pattern-2 '(unquote))) + (qq-m&e-3 (pat:make-match&env qq-pattern-3 '(quasiquote))) + (qq-m&e-4 (pat:make-match&env qq-pattern-4 '(unquote-splicing))) + (qq-m&e-5 (pat:make-match&env qq-pattern-5 '(unquote-splicing))) + (qq-m&e-6 (pat:make-match&env qq-pattern-6 '(unquote-splicing)))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((template (pat:pexpand 'template p-env kwd))) + (qq-process + (qq-normalize + (let qq ((x template) + (level 0)) + (let ((qq-list (lambda (x level) + (let* ((old-first (syntax-car x)) + (old-rest (syntax-cdr x)) + (first (qq old-first level)) + (rest (qq old-rest level))) + (if (and (eq? first old-first) + (eq? rest old-rest)) + x + (list '#%cons + (qq-normalize first old-first) + (qq-normalize rest old-rest))))))) + (cond + ((and (or (z:list? x) (z:improper-list? x)) + (not (zero? (z:sequence-length x)))) + (cond + ((pat:match-against qq-m&e-1 x env) + => + (lambda (p-env) + (let ((body (pat:pexpand 'body p-env kwd))) + (if (zero? level) + body + (qq-list x (sub1 level)))))) + ((pat:match-against qq-m&e-2 x env) + (static-error x + "unquote takes exactly one expression")) + ((pat:match-against qq-m&e-3 x env) + (qq-list x (add1 level))) + ((pat:match-against qq-m&e-4 x env) + (static-error x + "invalid context for unquote-splicing inside quasiquote")) + ((pat:match-against qq-m&e-5 x env) + => + (lambda (p-env) + (let* ((body (pat:pexpand 'body p-env kwd)) + (rest (pat:pexpand 'rest p-env kwd)) + (q-rest (qq rest level))) + (if (zero? level) + (list '#%append body + (qq-normalize q-rest rest)) + (let ((q-body (qq body (sub1 level)))) + (if (and (eq? q-rest rest) + (eq? q-body body)) + x + (list '#%cons + (list '#%cons + (list '#%quote 'unquote-splicing) + (list '#%cons + (qq-normalize q-body body) + '())) + (qq-normalize q-rest rest)))))))) + ((pat:match-against qq-m&e-6 x env) + (static-error x + "unquote-splicing takes exactly one expression")) + (else + (qq-list x level)))) + ((z:vector? x) + (let* ((v (structurize-syntax (z:read-object x) x)) + (qv (qq v level))) + (if (eq? v qv) + x + (list '#%list->vector qv)))) + ((z:box? x) + (let* ((b (z:read-object x)) + (qb (qq b level))) + (if (eq? b qb) + x + (list '#%box qb)))) + (else + x)))) + template) + expr env attributes vocab)))) + (else + (static-error expr "Malformed quasiquote")))))) + +(add-primitivized-micro-form 'quasiquote intermediate-vocabulary quasiquote-micro) +(add-primitivized-micro-form 'quasiquote scheme-vocabulary quasiquote-micro) + diff --git a/collects/zodiac/reader.ss b/collects/zodiac/reader.ss new file mode 100644 index 00000000..31eaf5d6 --- /dev/null +++ b/collects/zodiac/reader.ss @@ -0,0 +1,382 @@ +;; +;; zodiac:reader-code@ +;; $Id: reader.ss,v 1.6 1999/02/04 14:32:54 mflatt Exp $ +;; +;; Zodiac Reader July 96 +;; mwk, plt group, Rice university. +;; +;; The Reader returns one of three struct types: +;; +;; scalar (symbol, number, string, boolean, char) +;; sequence (list, vector, improper-list) +;; eof +;; +;; In case of error, we invoke static-error (or internal-error) +;; with args: zodiac-obj fmt-string . args +;; + +(unit/sig zodiac:reader-code^ + + (import + zodiac:structures^ + zodiac:scanner-structs^ + (zodiac : zodiac:reader-structs^) + zodiac:scanner-parameters^ + (report : zodiac:interface^) + zodiac:scanner-code^) + + ;; rename some things for now. will clean this up. + + (define paren-relation scan:paren-relation) + (define def-init-loc default-initial-location) + (define def-first-col scan:def-first-col) + + + (define default-vector-object + (lambda (start finish) + (zodiac:make-number + (make-origin 'reader 'vector) + start finish 0))) + + (define my-make-list + (lambda (len elt) + (let loop ([n 0] [l null]) + (if (= n len) l + (loop (+ n 1) (cons elt l)))))) + + (define paren-rel paren-relation) + + ;; Need to subdivide z:token with vector and sized-vector. + ;; Then object only has the paren, and size is separate. + + (define match? + (lambda (t1 t2) + (let ([c1 (token-object t1)] + [c2 (token-object t2)]) + (member (list (if (char? c1) c1 (cadr c1)) + c2) + paren-rel)))) + + (define z:endseq? + (lambda (obj) + (and (token? obj) + (eq? (token-type obj) 'endseq)))) + + (define read-origin + (lambda (how) + (make-origin 'reader how))) + + (define z:r-s-e (lambda x (apply report:static-error x))) + (define z:int-error (lambda x (apply report:internal-error x))) + + ;; pack-quote into zodiac structure. + ;; ,@ --> ( unquote-splicing ) + ;; 12 3 4 1 1 2 3 4 4 + + (define pack-quote + (lambda (type token obj) + (let ([one (zodiac-start token)] + [two (zodiac-finish token)] + [four (zodiac-finish obj)]) + (zodiac:make-list + (read-origin type) one four + (list + (zodiac:make-symbol + (read-origin type) one two + type type '(-1)) + obj) + 2 '())))) + + ;; pack-box into zodiac structure. + ;; #& --> (z:box origin start finish ) + ;; 12 3 4 1 4 + + (define pack-box + (lambda (box obj) + (let ([one (zodiac-start box)] + [four (zodiac-finish obj)]) + (zodiac:make-box (read-origin 'box) one four obj)))) + + ;; pack-seqn combines pack-list, -vector + + (define pack-seqn + (lambda (z:maker) + (lambda (open-token close-token head len) + (z:maker + (zodiac-origin open-token) + (zodiac-start open-token) + (zodiac-finish close-token) + head + len)))) + + (define pack-list (pack-seqn (lambda (orig open close head len) + (zodiac:make-list orig open close + head len '())))) + (define pack-vector (pack-seqn zodiac:make-vector)) + + (define allow-improper-lists (make-parameter #t)) + (define allow-reader-quasiquote (make-parameter #t)) + + (define (dot-err s) + (if (allow-improper-lists) + s + "misuse of `.' (improper lists are not allowed)")) + + (define pack-imp-list + (lambda (open-token close-token head len dot) + (let ([obj (zodiac:make-improper-list + (zodiac-origin open-token) + (zodiac-start open-token) + (zodiac-finish close-token) + head len dot '())]) + (if (allow-improper-lists) + obj + (z:r-s-e obj (dot-err "")))))) + + ;; convert (a . (b . ())) ==> (a b) if parameter set + ;; and obj after dot is list or imp-list. + ;; REPLACE #f in cond with (not compact-imp-list-parameter). + + (define compact-imp-list + (lambda (open-token close-token head len dot before-dot after-dot) + (cond + [#f (pack-imp-list open-token close-token head len dot)] + [(zodiac:list? after-dot) + (set-cdr! before-dot (zodiac:read-object after-dot)) + (pack-list + open-token + close-token + head + (+ len (zodiac:sequence-length after-dot) -1))] + [(zodiac:improper-list? after-dot) + (set-cdr! before-dot (zodiac:read-object after-dot)) + (pack-imp-list + open-token + close-token + head + (+ len (zodiac:sequence-length after-dot) -1) + (zodiac:improper-list-period after-dot))] + [else (pack-imp-list open-token close-token head len dot)]))) + + + (define read + (opt-lambda + ([port (current-input-port)] + [init-loc def-init-loc] + [skip-script #t] + [first-col def-first-col]) + + (let* + ([get-token (scan port init-loc skip-script first-col)]) + + ;; read-obj returns one of: + ;; z:read zodiac object (scalar or sequence) + ;; z:token (type 'endseq) for close paren + ;; z:period + ;; z:eof + + (letrec + ([read-obj + (lambda () + (let ([token (get-token)]) + (cond + [(zodiac:scalar? token) token] + [(token? token) + (let ([type (token-type token)]) + (cond + [(eq? type 'endseq) token] + [(eq? type 'list) + (read-seqn type token pack-list)] + [(eq? type 'vector) + (read-seqn type token pack-vector)] + [(eq? type 'sized-vector) + (read-seqn type token finish-vector)] + [(or (eq? type 'quote) + (eq? type 'quasiquote) + (eq? type 'unquote) + (eq? type 'unquote-splicing)) + (unless (or (eq? type 'quote) + (allow-reader-quasiquote)) + (z:r-s-e token + (format "illegal use of \"~a\"" + (case type + [(quasiquote) "`"] + [(unquote) ","] + [else ",@"])))) + (read-quote type token)] + [(eq? type 'period) + (make-period (zodiac-start token))] + [(eq? type 'box) (read-box token)] + [(or (eq? type 'circular-obj) + (eq? type 'circular-ref)) + (z:r-s-e token + "circular objects are not implemented")] + [else + (z:int-error token + "unknown scanner token type: ~s" type)]))] + [(eof? token) token] + [else + (z:int-error token "unknown scanner object")])))] + + + ;; read-seqn combines read-list, -vector, -imp-list + ;; type = 'list, 'vector, 'improper-list + ;; token = z:token for (, #(, #nn( ;; ))) + ;; end-fcn = fcn to call when get close paren. + ;; sent = sentinel to simplify making list. + ;; p = last item in list, before obj. + + [read-seqn + (lambda (type token end-fcn) + (let ([sent (cons #f null)]) + (let loop ([p sent] [len 0]) + (let ([obj (read-obj)]) + (cond + [(zodiac:read? obj) + (set-cdr! p (cons obj null)) + (loop (cdr p) (+ len 1))] + [(z:endseq? obj) + (if (match? token obj) + (if (eq? type 'sized-vector) + (finish-vector token obj (cdr sent) p len) + (end-fcn token obj (cdr sent) len)) + (z:r-s-e obj + "close paren does not match open paren"))] + [(period? obj) + (if (eq? type 'list) + (if (= len 0) + (z:r-s-e obj + (dot-err "can't put `.' as first item in list")) + (finish-imp-list token obj (cdr sent) p len)) + (z:r-s-e obj (dot-err "can't use `.' inside vector")))] + [(eof? obj) + (z:r-s-e token "missing close paren")] + [else + (z:int-error obj "unknown reader object")])))))] + + + ;; read-improper-list + ;; exactly one object after dot, then close paren. + ;; p = item before dot. + ;; obj = item after dot (or else error). + ;; obj2 = close paren (or else error). + + [finish-imp-list + (lambda (token dot head p len) + (unless (allow-improper-lists) + (z:r-s-e dot (dot-err ""))) + (let ([obj (read-obj)]) + (cond + [(zodiac:read? obj) + (let ([obj2 (read-obj)]) + (cond + [(z:endseq? obj2) + (if (match? token obj2) + (begin + (set-cdr! p (cons obj null)) + (compact-imp-list token obj2 head (+ len 1) dot p obj)) + (z:r-s-e obj2 + "close paren does not match open paren"))] + [(zodiac:read? obj2) + (z:r-s-e obj2 "too many elements after `.'")] + [(period? obj2) + (z:r-s-e obj2 "can't have two `.'s in a list")] + [(eof? obj2) + (z:r-s-e obj2 "missing close paren")] + [else + (z:int-error obj2 "Unknown reader object")]))] + [(period? obj) + (z:r-s-e obj "can't have two `.'s in a list")] + [(z:endseq? obj) + (z:r-s-e obj "must put one object after `.' in list")] + [(eof? obj) + (z:r-s-e token "missing close paren")] + [else + (z:int-error obj "unknown reader object")])))] + + + ;; finish sized-vectors + ;; compare size with actual number of elements, + ;; and pad or complain as necessary. + ;; object in open-token = (size char) + + [finish-vector + (lambda (open-token close-token head tail len) + (let ([size (car (token-object open-token))]) + (cond + [(= len size) + (pack-vector open-token close-token head len)] + [(= len 0) + (let ([obj (default-vector-object + (zodiac-finish open-token) + (zodiac-finish close-token))]) + (pack-vector open-token close-token + (my-make-list size obj) size))] + [(< len size) + (let* ([last-obj (car tail)] + [p (my-make-list (- size len) last-obj)]) + (set-cdr! tail p) + (pack-vector open-token close-token head size))] + [else + (z:r-s-e open-token + "too many elements in vector constant")])))] + + + ;; read-quote ' --> (quote ) + ;; can only quote reader-objs, not dot, close paren, eof. + ;; quote-type is the symbol quote, unquote, ... (kludge!) + + [read-quote + (lambda (quote-type quote-token) + (let ([obj (read-obj)]) + (if (zodiac:read? obj) + (pack-quote quote-type quote-token obj) + (box/quote-error quote-type quote-token obj))))] + + ;; read-box #& --> (box (quote )) + ;; can only box reader-objs, not dot, close paren, eof. + + [read-box + (lambda (box-token) + (let ([obj (read-obj)]) + (if (zodiac:read? obj) + (pack-box box-token obj) + (box/quote-error 'box box-token obj))))] + + ;; Can't put dot, close paren, eof after box or quote. + ;; type = symbol box, quote, unquote, ... + ;; token = box or quote z:token. + ;; obj = bad object after box/quote. + + [box/quote-error + (lambda (type token obj) + (cond + [(eof? obj) + (z:r-s-e token "missing object after ~a" type)] + [(period? obj) + (z:r-s-e obj "can't put `.' after ~a" type)] + [(z:endseq? obj) + (z:r-s-e obj "can't put close paren after ~a" type)] + [else + (z:int-error obj "unknown reader object")]))] + + ;; read-top-level returns the next scheme object and + ;; complains if dot or close paren is outside a list. + ;; close paren is in z:token with type 'endseq. + + [read-top-level + (lambda () + (let ([obj (read-obj)]) + (cond + [(or (zodiac:read? obj) (eof? obj)) obj] + [(period? obj) + (z:r-s-e obj (dot-err "can't use `.' outside list"))] + [(z:endseq? obj) + (z:r-s-e obj "too many close parens")] + [else + (z:int-error obj "Unknown reader object")])))] + ) + read-top-level)))) + + ) + diff --git a/collects/zodiac/readstr.ss b/collects/zodiac/readstr.ss new file mode 100644 index 00000000..95854435 --- /dev/null +++ b/collects/zodiac/readstr.ss @@ -0,0 +1,44 @@ +;; +;; zodiac:reader-structs@ +;; $Id$ +;; +;; Reader's subtree of the hierarchy. +;; +;; zodiac (origin start finish) +;; read (object) +;; scalar +;; symbol (orig-name marks) +;; number +;; string +;; boolean +;; char +;; box +;; type-symbol +;; external +;; sequence (length) +;; list (marks) +;; vector +;; improper-list (period marks) +;; + +(unit/sig zodiac:reader-structs^ + (import zodiac:structures^) + + (define-struct (read struct:zodiac) (object)) + + (define-struct (scalar struct:read) ()) + (define-struct (symbol struct:scalar) (orig-name marks)) + (define-struct (number struct:scalar) ()) + (define-struct (string struct:scalar) ()) + (define-struct (boolean struct:scalar) ()) + (define-struct (char struct:scalar) ()) + (define-struct (box struct:scalar) ()) + (define-struct (type-symbol struct:scalar) ()) + (define-struct (external struct:scalar) ()) + + (define-struct (sequence struct:read) (length)) + (define-struct (list struct:sequence) (marks)) + (define-struct (vector struct:sequence) ()) + (define-struct (improper-list struct:sequence) (period marks)) + ) + diff --git a/collects/zodiac/scanner.ss b/collects/zodiac/scanner.ss new file mode 100644 index 00000000..094a8dec --- /dev/null +++ b/collects/zodiac/scanner.ss @@ -0,0 +1,747 @@ +;; +;; zodiac:scanner-code@ +;; $Id: scanner.ss,v 1.13 1999/10/26 18:47:02 shriram Exp $ +;; +;; Zodiac Scanner July 96. +;; mwk, plt group, Rice university. +;; +;; The Scanner returns one of three struct types: +;; +;; scalar (symbol, number, string, boolean, char) +;; token (anything else) +;; eof +;; +;; In case of error, we invoke static-error (or internal-error) +;; with args: token (type 'error) message (string). +;; + +;; +;; Imports: make- constructors and parameters. +;; Exports: scan. +;; + +(unit/sig zodiac:scanner-code^ + (import zodiac:structures^ + zodiac:scanner-structs^ + (zodiac : zodiac:reader-structs^) + zodiac:scanner-parameters^ + (report : zodiac:interface^)) + + ;; + ;; Insert elements into table of ascii chars (plus eof). + ;; Indices can be either chars or ints. + ;; Elts can be either single char/int or list of char/int. + ;; + + (define fill + (letrec ([loop + (lambda (table value char-list) + (if (null? char-list) 'done + (let* ([elt (car char-list)] + [num (if (integer? elt) elt (char->integer elt))]) + (vector-set! table num value) + (loop table value (cdr char-list)))))]) + (case-lambda + [(table value) + (vector-fill! table value)] + [(table value elts) + (if (list? elts) + (loop table value elts) + (loop table value (list elts)))]))) + + + + ;; Internal definitions for the scanner. + + (define z:void (void)) + (define z:location make-location) + + (define z:origin make-origin) + (define source (lambda () (z:origin 'source 'source))) + + (define z:scalar + (lambda (maker) + (lambda (obj st fin) + (maker (source) st fin obj)))) + + ;;;;; Moved from here + + (define z:token + (lambda (tag obj st fin) + (make-token (source) st fin obj tag))) + + (define z:eof (lambda (loc) (make-eof loc))) + + + ;; Codes for the tokens returned by the scanner. + ;; This is the "type" field in token. + ;; (it's safe to change these here, if needed.) + + (define open-tag 'list) + (define close-tag 'endseq) + (define dot-tag 'period) + (define quote-tag 'quote) + (define quasi-tag 'quasiquote) + (define unquote-tag 'unquote) + (define splicing-tag 'unquote-splicing) + (define string-tag 'string) + (define box-tag 'box) + (define boolean-tag 'boolean) + (define char-tag 'char) + (define circ-obj-tag 'circular-obj) + (define circ-ref-tag 'circular-ref) + (define vector-tag 'vector) + (define size-vec-tag 'sized-vector) + (define number-tag 'number) + (define symbol-tag 'symbol) + (define eof-tag 'eof) + (define error-tag 'error) + (define snip-tag 'snip) + + ;; Other codes for char classes. + + (define delim-tag 'delim) + (define space-tag 'space) + (define tab-tag 'tab) + (define newline-tag 'newline) + (define letter-tag 'letter) + (define octal-tag 'octal) + (define digit-tag 'digit) + + ;; The scanner's alphabet. + + (define dot-char #\. ) + (define dot-int (char->integer dot-char)) + (define quote-char #\' ) + (define quote-int (char->integer quote-char)) + (define quasi-char #\` ) + (define quasi-int (char->integer quasi-char)) + (define unquote-char #\, ) + (define unquote-int (char->integer unquote-char)) + (define comment-char #\; ) + (define comment-int (char->integer comment-char)) + (define string-char #\" ) + (define string-int (char->integer string-char)) + (define hash-char #\# ) + (define hash-int (char->integer hash-char)) + (define box-char #\& ) + (define bslash-char #\\ ) + (define bslash-int (char->integer bslash-char)) + (define stick-char #\| ) + (define stick-int (char->integer stick-char)) + (define bang-char #\! ) + (define zero-int (char->integer #\0)) + (define space-int (char->integer #\space)) + (define rangle-int (char->integer #\> )) + (define langle-int (char->integer #\< )) + + (define splicing-int (char->integer #\@ )) + (define eq-sign-int (char->integer #\= )) + (define eof-int 256) + (define snip-int 257) + (define ascii-size 258) + + (define open-list (map car scan:paren-relation)) + (define close-list (map cadr scan:paren-relation)) + + (define delim-list (cons eof-int (cons snip-int scan:delim-list))) + + ;;;;; Moved to here + + (define z:symbol (z:scalar (lambda (so st fi obj) + (zodiac:make-symbol so st fi obj obj '())))) + (define z:number (z:scalar zodiac:make-number)) + (define z:string (z:scalar zodiac:make-string)) + (define z:boolean (z:scalar zodiac:make-boolean)) + (define z:char (z:scalar zodiac:make-char)) + (define z:snip (z:scalar zodiac:make-external)) + (define z:type-sym (z:scalar zodiac:make-type-symbol)) + + ;;;;;;;;;;;;;;;; + + ;; letters and octals are used in #\space and #\012. + ;; digits are used in #3(. + ;; (nothing to do with the chars allowed in symbols.) + + (define letter-list + ((lambda (l) (append (map char-upcase l) l)) + (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))) + + (define digit-list (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (define octal-list (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) + + ;; Ambig = chars that can begin symbols or numbers. + ;; Dot and hash are also ambiguous, but in different ways. + + (define ambig-list (cons #\+ (cons #\- digit-list))) + + ;; Chars that come after #. + + (define prim-char #\% ) + (define prim-int (char->integer prim-char)) + (define boolean-list (list #\t #\f #\T #\F)) + (define hash-num-list + (list #\i #\e #\b #\o #\d #\x #\I #\E #\B #\O #\D #\X)) + + (define special-char-list + (map + (lambda (l) + (let ([str (car l)] [elt (cadr l)]) + (list (reverse (string->list str)) + (if (char? elt) elt + (integer->char elt))))) + scan:special-char-list)) + + ;; Number of columns that tab rounds up to. + + (define tab-mult 8) + + (define text->string + (lambda (text) (string->immutable-string (list->string (reverse text))))) + + (define text->number + (lambda (text) (string->number (text->string text)))) + + ;; Convert symbols to single case (if case-sensitive? = #f), + ;; so *make sure* all calls to z:symbol come through here. + + (define text->symbol + (lambda (text) + (let ([obj (if (read-case-sensitive) + text + (map char-downcase text))]) + (string->symbol (text->string obj))))) + + (define text->char + (lambda (text) + (let ([low-case (map char-downcase text)]) + (let loop ([l special-char-list]) + (cond + [(null? l) #f] + [(equal? low-case (caar l)) (cadar l)] + [else (loop (cdr l))]))))) + + (define char->digit (lambda (c) (- (char->integer c) zero-int))) + + + ;; + ;; The Scanner. Optional args (in order): + ;; port = input port to read from. + ;; init-loc = location of 1st (next) char from port. + ;; skip-script = #t if skip #!... at start of file. + ;; first-col = number (usually 1) of 1st column of each line. + ;; + ;; Basic Idea: States in DFA are implemented as procedures. + ;; Calling a procedure means you're in that state (history). + ;; + ;; Main Invariant: + ;; char = "current" char + ;; (line, col, offset) = loc of (current) char + ;; start-loc = global + ;; + + (define scan + (opt-lambda + ([port (current-input-port)] + [init-loc default-initial-location] + [skip-script? #t] + [first-col scan:def-first-col]) + + + ;; The Scanner's State. + ;; char = the "current" character. + ;; int = ascii code for char, or else 256 for eof. + ;; (line, col, offset) = (right) location of current char. + ;; (prev-line, prev-col) = (right) location of previous char. + ;; file = copied from location of init-loc. + + (let* + ([char #\a] ;; Dummy values, int must != newline. + [int 65] + [line (location-line init-loc)] + [col (- (location-column init-loc) 1)] + [offset (- (location-offset init-loc) 1)] + [file (location-file init-loc)] + [prev-line -99] + [prev-col -99] + [start-loc 'error] + [first-offset (location-offset init-loc)] + + [hash? (lambda () (= int hash-int))] + [bslash? (lambda () (= int bslash-int))] + [dquote? (lambda () (= int string-int))] + [eq-sign? (lambda () (= int eq-sign-int))] + [splicing? (lambda () (= int splicing-int))] + [stick? (lambda () (= int stick-int))] + [prim? (lambda () (= int prim-int))] + [eof? (lambda () (= int eof-int))] + [snip? (lambda () (= int snip-int))] + + [main-table (make-vector ascii-size (lambda () #f))] + [hash-table (make-vector ascii-size (lambda () #f))] + [delim-table (make-vector ascii-size #f)] + [char-table (make-vector ascii-size #f)] + + [delim? (lambda () (vector-ref delim-table int))] + [tab? (lambda () (eq? (vector-ref delim-table int) tab-tag))] + [newline? (lambda () (eq? (vector-ref delim-table int) newline-tag))] + [open? (lambda () (eq? (vector-ref delim-table int) open-tag))] + + [space? (lambda () (= int space-int))] + [rangle? (lambda () (= int rangle-int))] + [type-sym-delim? + (lambda () + (cond [(space?) #f] + [(rangle?) #t] + [else (delim?)]))] + + [letter? (lambda () (eq? (vector-ref char-table int) letter-tag))] + [octal? (lambda () (eq? (vector-ref char-table int) octal-tag))] + [digit? + (lambda () + (let ([tag (vector-ref char-table int)]) + (or (eq? tag octal-tag) (eq? tag digit-tag))))] + [fetch-char + (if (procedure? port) + port + (lambda () (read-char port)))] + [hash-char-list (list hash-char)]) + + (letrec + + ;; For now, a naive treatment of location. + ;; We always use the *right* side of a char, so: + ;; affects the following char, + ;; affects itself. + + ([get-char + (lambda () + (set! prev-line line) + (set! prev-col col) + (if (newline?) + (begin (set! line (+ line 1)) + (set! col first-col)) + (set! col (+ col 1))) + (set! char (fetch-char)) + (set! int + (cond [(char? char) (char->integer char)] + [(eof-object? char) eof-int] + [else snip-int])) + (if (tab?) + (set! col (* tab-mult (ceiling (/ col tab-mult))))) + (set! offset (+ offset 1)))] + + [this-loc + (lambda () + (z:location line col offset file))] + + [prev-loc + (lambda () + (z:location prev-line prev-col (- offset 1) file))] + + [start-here + (lambda () + (set! start-loc (this-loc)))] + + [z:error + (case-lambda + [(str) + (report:static-error + (z:token error-tag z:void start-loc (prev-loc)) + str)] + [(str text) + (report:static-error + (z:token error-tag z:void start-loc (prev-loc)) + (format str (text->string text)))])] + + [z:eof-error + (lambda (str) + (report:static-error + (z:token error-tag z:void start-loc (prev-loc)) + (format "unexpected end of file inside ~a" str)))] + + ;; + ;; States in the scanner. + ;; Inv: When a state is called, (char, int) is the + ;; 1st char of that token. + ;; get-token = the thunk returned to the reader. + ;; + + [get-token + (lambda () + (start-here) + ((vector-ref main-table int)))] + + [scan-wspace + (lambda () + (get-char) + (get-token))] + + [scan-open + (lambda () + (let ([c char]) + (get-char) + (z:token open-tag c start-loc start-loc)))] + + [scan-close + (lambda () + (let ([c char]) + (get-char) + (z:token close-tag c start-loc start-loc)))] + + ;; Should we check for case-sensitive? here? + ;; You *really* don't want a letter being a delim! + + [scan-delim-sym + (lambda () + (let ([sym (text->symbol (list char))]) + (get-char) + (z:symbol sym start-loc start-loc)))] + + [scan-quote + (lambda () + (get-char) + (z:token quote-tag z:void start-loc start-loc))] + + [scan-quasi + (lambda () + (get-char) + (z:token quasi-tag z:void start-loc start-loc))] + + [scan-unquote + (lambda () + (get-char) + (if (or (eof?) (not (splicing?))) + (z:token unquote-tag z:void start-loc start-loc) + (let ([end-loc (this-loc)]) + (get-char) + (z:token splicing-tag z:void start-loc end-loc))))] + + [scan-comment + (lambda () + (cond + [(newline?) (begin (get-char) (get-token))] + [(eof?) (get-token)] + [else (begin (get-char) (scan-comment))]))] + + [scan-string + (lambda () + (let loop ([l null]) + (get-char) + (cond + [(eof?) (z:error "missing close quote in string")] + [(dquote?) + (let ([end-loc (this-loc)]) + (get-char) + (z:string (text->string l) start-loc end-loc))] + [(bslash?) + (begin + (get-char) + (cond + [(eof?) (z:error "missing close quote in string")] + [(snip?) (get-char) + (z:error "objects in string must be chars")] + [else (loop (cons char l))]))] + [(snip?) (get-char) + (z:error "objects in string must be chars")] + [else (loop (cons char l))])))] + + [scan-dot + (lambda () + (get-char) + (if (delim?) + (z:token dot-tag z:void start-loc start-loc) + (sym-or-num (list dot-char))))] + + [scan-hash + (lambda () + (get-char) + ((vector-ref hash-table int)))] + + [scan-box + (lambda () + (get-char) + (z:token box-tag z:void start-loc (prev-loc)))] + + [scan-boolean + (lambda () + (let ([val (char-ci=? char #\t)]) + (get-char) + (z:boolean val start-loc (prev-loc))))] + + [scan-char + (lambda () + (get-char) ; skip the \ char. + (cond + [(eof?) (z:error "missing character after #\\")] + [(snip?) (get-char) + (z:error "must put character after #\\")] + [(letter?) + (let loop ([l (list char)]) + (get-char) + (if (letter?) + (loop (cons char l)) + (if (null? (cdr l)) + (z:char (car l) start-loc (prev-loc)) + (let ([ch (text->char l)]) + (if ch + (z:char ch start-loc (prev-loc)) + (z:error "`~a' is not a valid character" + (append l (list bslash-char hash-char))))))))] + [(octal?) + (let ([c1 char] [d1 (char->digit char)]) + (get-char) + (if (octal?) + (let ([c2 char] [d2 (char->digit char)]) + (get-char) + (if (octal?) + (let ([c3 char] [d3 (char->digit char)]) + (get-char) + (let ([num (+ (* 64 d1) (* 8 d2) d3)]) + (if (<= 0 num 255) + (z:char (integer->char num) + start-loc (prev-loc)) + (z:error "`#\\~a' is not a valid octal character" + (list c3 c2 c1))))) + (z:char (integer->char (+ (* 8 d1) d2)) + start-loc (prev-loc)))) + (z:char c1 start-loc (prev-loc))))] + [else + (let ([c char]) + (get-char) + (z:char c start-loc (prev-loc)))]))] + + [scan-vector + (lambda () + (let ([c char]) + (get-char) + (z:token vector-tag c start-loc (prev-loc))))] + + [scan-hash-digit + (lambda () + (let loop ([l (list char)]) + (get-char) + (cond + [(digit?) (loop (cons char l))] + [(eof?) (z:eof-error "# syntax")] + [(open?) + (let ([c char] + [num (text->number l)]) + (get-char) + ; The vector-constant-size test is now to let mzscheme + ; try the malloc and see if it succeeds or raises exn. + (if (with-handlers + (((lambda (x) #t) (lambda (x) #f))) + (make-vector num 0) + #t) + (z:token size-vec-tag (list num c) + start-loc (prev-loc)) + (z:error "vector constant size too large")))] + [(hash?) + (let ([num (text->number l)]) + (get-char) + (z:token circ-ref-tag num start-loc (prev-loc)))] + [(eq-sign?) + (let ([num (text->number l)]) + (get-char) + (z:token circ-obj-tag num start-loc (prev-loc)))] + [(prim?) + (let ([text (append l (list hash-char))]) + (symbol-only text))] + [(snip?) (get-char) + (z:error "invalid # syntax")] + [else + (let ([c char]) + (get-char) + (z:error "invalid # syntax"))])))] + + [scan-hash-stick + (lambda () + (let loop ([nest 1]) + (get-char) + (cond + [(= nest 0) (get-token)] + [(eof?) (z:eof-error "#| comment")] + [(hash?) + (begin + (get-char) + (cond + [(eof?) (get-token)] + [(stick?) (loop (+ nest 1))] + [else (loop nest)]))] + [(stick?) + (begin + (get-char) + (cond + [(eof?) (get-token)] + [(hash?) (loop (- nest 1))] + [else (loop nest)]))] + [else (loop nest)])))] + + [scan-primitive + (lambda () (symbol-only hash-char-list))] + + [scan-hash-other + (lambda () + (let ([c char]) + (get-char) + (z:error "invalid # syntax")))] + + [scan-hash-eof + (lambda () (z:eof-error "# syntax"))] + + [scan-to-delim + (lambda (delim? text esc) + (cond + [(delim?) (values text esc)] + [(bslash?) + (begin + (get-char) + (cond + [(eof?) (z:error "missing character inside escape")] + [(snip?) (get-char) + (z:error "invalid object inside escape")] + [else (let ([c char]) + (get-char) + (scan-to-delim delim? (cons c text) #t))]))] + [(stick?) + (let loop ([l text]) + (get-char) + (cond + [(eof?) (z:error "missing close stick")] + [(snip?) (get-char) + (z:error "invalid object inside stick")] + [(stick?) + (begin + (get-char) + (scan-to-delim delim? l #t))] + [else (loop (cons char l))]))] + [else + (let ([c char]) + (get-char) + (scan-to-delim delim? (cons c text) esc))]))] + + [scan-sym-num (lambda () (sym-or-num null))] + [scan-symbol (lambda () (symbol-only null))] + [scan-number + (lambda () (number-only hash-char-list))] + + [sym-or-num + (lambda (text) + (let-values ([(text used-stick?) + (scan-to-delim delim? text #f)]) + (if used-stick? + (z:symbol (text->symbol text) + start-loc (prev-loc)) + (with-handlers + ([exn:read? + (lambda (x) (z:error "`~a' is not a valid number" + text))]) + (let* + ([str (text->string text)] + [num (read (open-input-string str))]) + (if (number? num) + (z:number (if (and (inexact? num) + (disallow-untagged-inexact-numbers)) + (z:error (format "`~~a' is not a valid number; try ~a" + (read (open-input-string (string-append "#e" str)))) + text) + num) + start-loc (prev-loc)) + (z:symbol (text->symbol text) + start-loc (prev-loc))))))))] + + [symbol-only + (lambda (text) + (let-values ([(text foo) (scan-to-delim delim? text #t)]) + (z:symbol (text->symbol text) + start-loc (prev-loc))))] + + [number-only + (lambda (text) + (let-values ([(text foo) (scan-to-delim delim? text #f)]) + (with-handlers + ([(lambda (x) #t) + (lambda (x) (z:error "`~a' starts out like a number, but isn't one" text))]) + (let* ([str (text->string text)] + [num (read (open-input-string str))]) + (if (number? num) + (z:number num start-loc (prev-loc)) + (z:error "`~a' starts out like a number, but isn't one" text))))))] + + [scan-eof + (lambda () (z:eof (this-loc)))] + + [scan-snip + (lambda () + (let ([obj char]) + (get-char) + (z:snip obj start-loc start-loc)))] + + ;; #! is treated as a comment if first two bytes of file. + [scan-hash-script + (lambda () + (if (and skip-script? + (= offset (add1 first-offset))) + (begin (skip-hash-script) + (get-token)) + (scan-hash-other)))] + + [skip-hash-script + (lambda () + (get-char) + (cond + [(eof?) 'return] + [(newline?) (get-char)] + [(bslash?) + (get-char) + (if (eof?) 'return (skip-hash-script))] + [else (skip-hash-script)]))] + ) + + (fill main-table scan-symbol) + (fill main-table scan-wspace scan:whitespace-list) + (fill main-table scan-sym-num ambig-list) + (fill main-table scan-dot dot-char) + (fill main-table scan-open open-list) + (fill main-table scan-close close-list) + (fill main-table scan-delim-sym scan:self-delim-symbols) + (fill main-table scan-quote quote-char) + (fill main-table scan-quasi quasi-char) + (fill main-table scan-unquote unquote-char) + (fill main-table scan-comment comment-char) + (fill main-table scan-string string-char) + (fill main-table scan-hash hash-char) + (fill main-table scan-eof eof-int) + (fill main-table scan-snip snip-int) + + (fill hash-table scan-hash-other) + (fill hash-table scan-box box-char) + (fill hash-table scan-boolean boolean-list) + (fill hash-table scan-char bslash-char) + (fill hash-table scan-number hash-num-list) + (fill hash-table scan-vector open-list) + (fill hash-table scan-hash-digit digit-list) + (fill hash-table scan-hash-stick stick-char) + (fill hash-table scan-primitive prim-char) + (fill hash-table scan-hash-eof eof-int) + (fill hash-table scan-hash-script bang-char) + + (fill delim-table #f) + (fill delim-table delim-tag delim-list) + (fill delim-table space-tag scan:whitespace-list) + (fill delim-table tab-tag scan:tab-list) + (fill delim-table newline-tag scan:newline-list) + (fill delim-table open-tag open-list) + (fill delim-table eof-tag eof-int) + (fill delim-table snip-tag snip-int) + + (fill char-table #f) + (fill char-table letter-tag letter-list) + (fill char-table digit-tag digit-list) + (fill char-table octal-tag octal-list) + + (get-char) + get-token))))) + diff --git a/collects/zodiac/scanparm.ss b/collects/zodiac/scanparm.ss new file mode 100644 index 00000000..266bb6da --- /dev/null +++ b/collects/zodiac/scanparm.ss @@ -0,0 +1,81 @@ +;; +;; zodiac:scanner-parameters@ +;; $Id: scanparm.ss,v 1.5 1997/12/03 19:20:21 robby Exp $ +;; +;; Scanner/Reader Parameters. +;; +;; The scan values (outside make-scanner) mostly can +;; be reset at will. But don't use letters, digits, #, etc. +;; The parameters inside make-scanner should not be reset. +;; +;; The char lists can be either chars or ints. +;; + +(unit/sig zodiac:scanner-parameters^ + (import zodiac:structures^) + + (define disallow-untagged-inexact-numbers (make-parameter #f)) + + ;; Only #\space and #\newline are always builtin, + ;; so we specify the rest with ascii codes. + + (define space #\space) + (define nul 0) + (define backsp 8) + (define tab 9) + (define newline 10) + (define vtab 11) + (define page 12) + (define return 13) + (define rubout 127) + + (define scan:paren-relation + (let ((base '((#\( #\))))) + (let ((w/-brackets (if (read-square-bracket-as-paren) + (cons '(#\[ #\]) base) + base))) + (let ((w/-braces (if (read-curly-brace-as-paren) + (cons '(#\{ #\}) w/-brackets) + w/-brackets))) + w/-braces)))) + + (define scan:self-delim-symbols + (let ((base '())) + (let ((w/-brackets (if (read-square-bracket-as-paren) + base + (append '(#\[ #\]) base)))) + (let ((w/-braces (if (read-curly-brace-as-paren) + w/-brackets + (append '(#\{ #\}) w/-brackets)))) + w/-braces)))) + + (define scan:newline-list (list newline return)) + (define scan:tab-list (list tab)) + (define scan:whitespace-list + (list space tab newline vtab page return)) + + (define scan:delim-list + (append scan:whitespace-list + (map car scan:paren-relation) + (map cadr scan:paren-relation) + scan:self-delim-symbols + (list #\; #\" #\, #\' #\` ))) + + (define scan:special-char-list + `(("space" ,space) + ("newline" ,newline) + ("linefeed" ,newline) + ("nul" ,nul) + ("null" ,nul) + ("backspace" ,backsp) + ("tab" ,tab) + ("vtab" ,vtab) + ("page" ,page) + ("return" ,return) + ("rubout" ,rubout))) + + (define default-initial-location (make-location 1 1 0 'nofile)) + (define scan:def-first-col 1) + (define scan:def-vect-val 0) + ) + diff --git a/collects/zodiac/scanstr.ss b/collects/zodiac/scanstr.ss new file mode 100644 index 00000000..74111490 --- /dev/null +++ b/collects/zodiac/scanstr.ss @@ -0,0 +1,18 @@ +;; +;; zodiac:scanner-structs@ +;; $Id$ +;; +;; Scanner's subtree of the hierarchy. +;; +;; zodiac (origin start finish) +;; scanned +;; token (object type) +;; + +(unit/sig zodiac:scanner-structs^ + (import zodiac:structures^) + + (define-struct (scanned struct:zodiac) ()) + (define-struct (token struct:scanned) (object type)) + ) + diff --git a/collects/zodiac/scm-core.ss b/collects/zodiac/scm-core.ss new file mode 100644 index 00000000..84bb6a25 --- /dev/null +++ b/collects/zodiac/scm-core.ss @@ -0,0 +1,896 @@ +; $Id: scm-core.ss,v 1.57 2000/03/24 14:50:29 clements Exp $ + +(unit/sig zodiac:scheme-core^ + (import zodiac:structures^ zodiac:misc^ zodiac:sexp^ + (z : zodiac:reader-structs^) zodiac:back-protocol^ + zodiac:expander^ zodiac:interface^ + (pat : zodiac:pattern^)) + + (define-struct (parsed struct:zodiac) (back)) + (define-struct (varref struct:parsed) (var)) + (define-struct (top-level-varref struct:varref) ()) + (define-struct (top-level-varref/bind struct:top-level-varref) (slot)) + (define-struct (top-level-varref/bind/unit struct:top-level-varref/bind) (unit?)) + (define-struct (bound-varref struct:varref) (binding)) + (define-struct (lexical-varref struct:bound-varref) ()) + (define-struct (lambda-varref struct:lexical-varref) ()) + (define-struct (app struct:parsed) (fun args)) + (define-struct (binding struct:parsed) (var orig-name)) + (define-struct (lexical-binding struct:binding) ()) + (define-struct (lambda-binding struct:lexical-binding) ()) + (define-struct (form struct:parsed) ()) + + ; ---------------------------------------------------------------------- + + (define name-eq? eq?) + + (define marks-equal? equal?) + + ; ---------------------------------------------------------------------- + + (define generate-name + (lambda (var) + (string->symbol + (string-append + (symbol->string (gensym)) ":" + (symbol->string (z:symbol-orig-name var)))))) + + (define create-binding+marks + (opt-lambda (constructor (nom-de-plume generate-name)) + (opt-lambda (v (s v)) + (cons + (constructor (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) + (nom-de-plume v) + (z:symbol-orig-name s)) + (z:symbol-marks v))))) + + (define create-lexical-binding+marks + (create-binding+marks make-lexical-binding)) + + (define create-lambda-binding+marks + (create-binding+marks make-lambda-binding)) + + (define create-top-level-varref + (lambda (v s) + (make-top-level-varref (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) v))) + + (define create-top-level-varref/bind + (lambda (v b s) + (make-top-level-varref/bind (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) v b))) + + (define create-top-level-varref/bind/unit + (lambda (v b s) + (make-top-level-varref/bind/unit (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) v b + (let ([l (unbox b)]) + (if (null? l) + #f + (top-level-varref/bind/unit-unit? (car l))))))) + + (define create-bound-varref + (lambda (constructor) + (opt-lambda (v (s v)) + (constructor (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) (binding-var v) + v)))) + + (define create-lexical-varref + (create-bound-varref make-lexical-varref)) + + (define create-lambda-varref + (create-bound-varref make-lambda-varref)) + + (define create-app + (lambda (fun args source) + (make-app (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) fun args))) + + ; ---------------------------------------------------------------------- + + (define p->r-table + '()) + + (define extend-parsed->raw + (lambda (predicate handler) + (set! p->r-table + (cons (cons predicate handler) + p->r-table)))) + + (define parsed->raw + (opt-lambda (expr (handler #f)) + (let loop ((table p->r-table)) + (if (null? table) + (internal-error expr "Invalid object for parsed->raw") + (let ((first (car table))) + (if ((car first) expr) + ((cdr first) expr (or handler parsed->raw)) + (loop (cdr table)))))))) + + (extend-parsed->raw varref? + (lambda (expr p->r) (varref-var expr))) + (extend-parsed->raw binding? + (lambda (expr p->r) (binding-var expr))) + + (extend-parsed->raw app? + (lambda (expr p->r) + (cons (p->r (app-fun expr)) + (map p->r (app-args expr))))) + + ; -------------------------------------------------------------------- + + (define add-primitivized-micro-form + (lambda (name vocab rewriter) + (unless (symbol? name) + (internal-error name "Must be symbol in add-primitivized-micro-form")) + (add-micro-form (list name (symbol-append "#%" name)) vocab rewriter))) + + (define add-primitivized-macro-form + (lambda (name vocab rewriter) + (unless (symbol? name) + (internal-error name "Must be symbol in add-primitivized-macro-form")) + (add-macro-form (list name (symbol-append "#%" name)) vocab rewriter))) + + ; -------------------------------------------------------------------- + + (define common-vocabulary + (create-vocabulary 'common-vocabulary + #f)) + + (define beginner-vocabulary + (create-vocabulary 'beginner-vocabulary + common-vocabulary)) + + (define intermediate-vocabulary + (create-vocabulary 'intermediate-vocabulary + beginner-vocabulary)) + + (define advanced-vocabulary + (create-vocabulary 'advanced-vocabulary + intermediate-vocabulary)) + + (define full-vocabulary + (create-vocabulary 'full-vocabulary + advanced-vocabulary)) + + (define scheme-vocabulary + (create-vocabulary 'scheme-vocabulary + common-vocabulary)) + + (define (check-for-signature-name expr attributes) + (let ([sig-space (get-attribute attributes 'sig-space)]) + (when sig-space + (unless (get-attribute attributes 'delay-sig-name-check?) + (when (hash-table-get sig-space (z:symbol-orig-name expr) (lambda () #f)) + (static-error + expr + "Invalid use of signature name ~s" (z:symbol-orig-name expr))))))) + + (define ensure-not-macro/micro + (lambda (expr env vocab attributes) + (let ((r (resolve expr env vocab))) + (if (or (macro-resolution? r) (micro-resolution? r)) + (static-error + expr + "Invalid use of keyword ~s" (z:symbol-orig-name expr)) + r)))) + + (define process-top-level-resolution + (lambda (expr attributes) + (let ((id (z:read-object expr))) + (let ((top-level-space (get-attribute attributes 'top-levels))) + (if top-level-space + (let ((ref + (create-top-level-varref/bind/unit + id + (hash-table-get top-level-space id + (lambda () + (let ((b (box '()))) + (hash-table-put! top-level-space id b) + b))) + expr))) + (let ((b (top-level-varref/bind-slot ref))) + (set-box! b (cons ref (unbox b)))) + ref) + (create-top-level-varref id expr)))))) + + (add-sym-micro common-vocabulary + (lambda (expr env attributes vocab) + (let ((r (ensure-not-macro/micro expr env vocab attributes))) + (cond + ((lambda-binding? r) + (create-lambda-varref r expr)) + ((lexical-binding? r) + (create-lexical-varref r expr)) + ((top-level-resolution? r) + (check-for-signature-name expr attributes) + (process-top-level-resolution expr attributes)) + (else + (internal-error expr "Invalid resolution in core: ~s" r)))))) + + (define (make-list-micro null-ok? lexvar-ok? expr-ok?) + (lambda (expr env attributes vocab) + (let ((contents (expose-list expr))) + (if (null? contents) + (if null-ok? + (expand-expr (structurize-syntax `(quote ,expr) expr) + env attributes vocab) + (static-error expr "Empty combination is a syntax error")) + (as-nested + attributes + (lambda () + (let ((bodies + (map + (lambda (e) + (expand-expr e env attributes vocab)) + contents))) + (when (or (and (not lexvar-ok?) + (not (top-level-varref? (car bodies)))) + (and (not expr-ok?) + (not (varref? (car bodies))))) + (static-error expr + "First term after parenthesis is illegal in an application")) + (create-app (car bodies) (cdr bodies) expr)))))))) + + (add-list-micro beginner-vocabulary (make-list-micro #f #f #f)) + (add-list-micro intermediate-vocabulary (make-list-micro #f #t #f)) + (add-list-micro advanced-vocabulary (make-list-micro #f #t #t)) + (add-list-micro scheme-vocabulary (make-list-micro #t #t #t)) + + (define lexically-resolved? + (lambda (expr env) + (let ((name (z:read-object expr)) (marks (z:symbol-marks expr))) + (let ((res (resolve-in-env name marks env))) + (and res (binding? res)))))) + + (define in-lexically-extended-env + (lambda (env vars handler) + (let ((new-vars+marks + (map create-lexical-binding+marks + vars))) + (let ((new-vars (map car new-vars+marks))) + (extend-env new-vars+marks env) + (let ((result (handler new-vars env))) + (retract-env new-vars env) + result))))) + + ; ---------------------------------------------------------------------- + + (define set-top-level-status + (opt-lambda (attributes (value #f)) + (put-attribute attributes 'at-scheme-top-level? value))) + + (define get-top-level-status + (lambda (attributes) + (get-attribute attributes 'at-scheme-top-level? + (lambda () #t)))) + + (define at-top-level? get-top-level-status) + + + (define set-internal-define-status + (opt-lambda (attributes (value #f)) + (put-attribute attributes 'at-internal-define-level? value))) + + (define get-internal-define-status + (lambda (attributes) + (get-attribute attributes 'at-internal-define-level? + (lambda () #f)))) + + (define at-internal-define? get-internal-define-status) + + (define (as-nested attributes f) + (let ([top? (get-top-level-status attributes)] + [internal? (get-internal-define-status attributes)]) + (if (or top? internal?) + (begin + (set-top-level-status attributes #f) + (set-internal-define-status attributes #f) + (begin0 + (f) + (set-top-level-status attributes top?) + (set-internal-define-status attributes internal?))) + (f)))) + + ; -------------------------------------------------------------------- + + (define previous-attribute (make-attributes)) + + (define mred-signature #f) + + (define (get-mred-signature attributes) + (unless mred-signature + (let ([v (create-vocabulary 'mred-vocabulary + scheme-vocabulary)] + [e (with-input-from-file + (build-path (collection-path "mred") "sig.ss") + read)] + [loc (make-location 0 0 0 "inlined")]) + (scheme-expand (structurize-syntax e (make-zodiac #f loc loc)) + attributes + v) + (let ([sig-space (get-attribute attributes 'sig-space void)]) + (set! mred-signature (hash-table-get sig-space 'mred^ void))))) + mred-signature) + + (define (reset-previous-attribute top? mred?) + (set! previous-attribute (make-attributes)) + (when top? + (put-attribute previous-attribute 'top-levels (make-hash-table))) + (when mred? + (let ([sig (get-mred-signature previous-attribute)] + [ss (make-hash-table)]) + (put-attribute previous-attribute 'sig-space ss) + (hash-table-put! ss 'mred^ sig)))) + + (define (reset-internal-attributes attr) + (set-top-level-status attr #t) + (set-internal-define-status attr #f) + (put-attribute attr 'delay-sig-name-check? #f) + (for-each (lambda (r) (r attr)) (attributes-resetters))) + + (define elaboration-evaluator + (make-parameter + (lambda (expr parsed->raw phase) + (eval (parsed->raw expr))))) + + (define user-macro-body-evaluator + (make-parameter + (lambda (x . args) + (eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args)))))) + + (define scheme-expand + (opt-lambda (expr [attr 'previous] [vocab #f]) + (let ((attr (cond + ((eq? attr 'previous) previous-attribute) + ((not attr) (make-attributes)) + (else attr)))) + (reset-internal-attributes attr) + (expand expr + attr + (or vocab scheme-vocabulary) + (elaboration-evaluator) + (user-macro-body-evaluator))))) + + (define scheme-expand-program + (opt-lambda (exprs [attr 'previous] [vocab #f]) + (let ((attr (cond + ((eq? attr 'previous) previous-attribute) + ((not attr) (make-attributes)) + (else attr)))) + (reset-internal-attributes attr) + (expand-program exprs + attr + (or vocab scheme-vocabulary) + (elaboration-evaluator) + (user-macro-body-evaluator))))) + + ; ---------------------------------------------------------------------- + + (define valid-syntactic-id? + (lambda (id) + (or (z:symbol? id) + (static-error id "~s is not an identifier" (sexp->raw id))))) + + (define valid-syntactic-id/s? + (lambda (ids) + (cond + ((null? ids) '()) + ((pair? ids) + (let ((first (car ids)) (rest (cdr ids))) + (if (valid-syntactic-id? first) + (cons (z:read-object first) (valid-syntactic-id/s? rest)) + (static-error first "~e is not an identifier" + (sexp->raw first))))) + (else (internal-error ids "Illegal to check validity of id/s"))))) + + (define distinct-valid-syntactic-id/s? + (lambda (given-ids) + (let ((input-ids (syntactic-id/s->ids given-ids))) + (let loop ((ids (valid-syntactic-id/s? input-ids)) (index 0)) + (or (null? ids) + (if (symbol? (car ids)) + (if (memq (car ids) (cdr ids)) + (static-error (list-ref input-ids index) + "Identifier ~s repeated" (car ids)) + (loop (cdr ids) (add1 index))) + (let ((erroneous (list-ref input-ids index))) + (static-error erroneous "~e is not an identifier" + (sexp->raw erroneous))))))))) + + (define syntactic-id/s->ids + (lambda (ids) + (cond + ((or (z:list? ids) (z:improper-list? ids)) + (expose-list ids)) + ((z:symbol? ids) (list ids)) + ((pair? ids) ids) + ((null? ids) ids) + (else (static-error ids "~e is not an identifier" + (sexp->raw ids)))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define valid-id? + (lambda (id) + (or (binding? id) + (static-error id "Invalid identifier")))) + + (define valid-id/s? + (lambda (ids) + (cond + ((null? ids) '()) + ((pair? ids) + (let ((first (car ids)) (rest (cdr ids))) + (if (valid-id? first) + (cons (binding-orig-name first) (valid-id/s? rest)) + (static-error first "Invalid identifier")))) + (else (internal-error ids "Illegal to check validity of id/s"))))) + + (define distinct-valid-id/s? + (lambda (ids) + (let ((input-ids (id/s->ids ids))) + (let loop ((ids (valid-id/s? input-ids)) (index 0)) + (or (null? ids) + (if (memq (car ids) (cdr ids)) + (let ((v (list-ref input-ids index))) + (static-error v + "Repeated identifier ~e" + (car ids))) + (loop (cdr ids) (add1 index)))))))) + + (define id/s->ids + (lambda (ids) + (cond + ((or (z:list? ids) (z:improper-list? ids)) + (expose-list ids)) + ((z:symbol? ids) (list ids)) + ((pair? ids) ids) + ((null? ids) ids) + (else (static-error ids "Invalid identifier"))))) + + + ; ---------------------------------------------------------------------- + + (define optarglist-pattern 'vars) + + (define-struct optarglist-entry (var+marks)) + (define-struct (initialized-optarglist-entry struct:optarglist-entry) + (expr)) + + (define-struct optarglist (vars)) + (define-struct (sym-optarglist struct:optarglist) ()) + (define-struct (list-optarglist struct:optarglist) ()) + (define-struct (ilist-optarglist struct:optarglist) ()) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define optarglist-decl-entry-parser-vocab + (create-vocabulary 'optarglist-decl-entry-parser-vocab #f + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry")) + + (add-sym-micro optarglist-decl-entry-parser-vocab + (lambda (expr env attributes vocab) + (let ((status-holder (get-attribute attributes 'optarglist-status))) + (case (unbox status-holder) + ((proper improper) (void)) + ((proper/defaults) + (static-error expr + "Appears after initial value specifications")) + ((improper/defaults) + (set-box! status-holder 'improper/done)) + ((improper/done) + (static-error expr + "Appears past catch-all argument")) + (else (internal-error (unbox status-holder) + "Invalid in optarglist-decl-entry-parser-vocab sym")))) + (make-optarglist-entry + (create-lexical-binding+marks expr)))) + + (add-list-micro optarglist-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern '(var val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((status-holder (get-attribute attributes 'optarglist-status))) + (case (unbox status-holder) + ((proper) (set-box! status-holder 'proper/defaults)) + ((improper) (set-box! status-holder 'improper/defaults)) + ((proper/defaults improper/defaults) (void)) + ((improper/done) (static-error expr + "Invalid default value specification")) + (else (internal-error (unbox status-holder) + "Invalid in optarglist-decl-entry-parser-vocab list")))) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (val (pat:pexpand 'val p-env kwd))) + (valid-syntactic-id? var) + (make-initialized-optarglist-entry + (create-lexical-binding+marks var) + val)))) + (else + (static-error expr "Invalid init-var declaration")))))) + + (define optarglist-decls-vocab + (create-vocabulary 'optarglist-decls-vocab #f + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry")) + + (add-sym-micro optarglist-decls-vocab + (lambda (expr env attributes vocab) + (make-sym-optarglist + (list + (make-optarglist-entry + (create-lexical-binding+marks expr)))))) + + (add-list-micro optarglist-decls-vocab + (lambda (expr env attributes vocab) + (let ((expr (expose-list expr)) + (new-attr (put-attribute attributes 'optarglist-status + (box 'proper)))) + (make-list-optarglist + (map (lambda (decl) + (expand-expr decl env new-attr + optarglist-decl-entry-parser-vocab)) + expr))))) + + (add-ilist-micro optarglist-decls-vocab + (lambda (expr env attributes vocab) + (let ((expr-list (expose-list expr)) + (new-attr (put-attribute attributes 'optarglist-status + (box 'improper)))) + (let ((result + (map (lambda (decl) + (expand-expr decl env new-attr + optarglist-decl-entry-parser-vocab)) + expr-list))) + (let loop ((result result) (exprs expr-list)) + (if (null? (cdr result)) + (when (initialized-optarglist-entry? (car result)) + (static-error (car exprs) + "Last argument must not have an initial value")) + (loop (cdr result) (cdr exprs)))) + (make-ilist-optarglist result))))) + + (define make-optargument-list + (lambda (optarglist env attributes vocab) + (let ((result + (map + (lambda (e) + (extend-env (list (optarglist-entry-var+marks e)) env) + (if (initialized-optarglist-entry? e) + (cons + (car (optarglist-entry-var+marks e)) + (expand-expr + (initialized-optarglist-entry-expr + e) + env attributes vocab)) + (car (optarglist-entry-var+marks e)))) + (optarglist-vars optarglist)))) + (cond + ((sym-optarglist? optarglist) + (make-sym-optarglist result)) + ((list-optarglist? optarglist) + (make-list-optarglist result)) + ((ilist-optarglist? optarglist) + (make-ilist-optarglist result)) + (else + (internal-error optarglist + "Invalid in make-optargument-list")))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (extend-parsed->raw optarglist? + (lambda (expr p->r) + (let ((process-args + (lambda (element) + (if (pair? element) + (list (p->r (car element)) (p->r (cdr element))) + (p->r element))))) + (cond + ((sym-optarglist? expr) + (process-args (car (optarglist-vars expr)))) + ((list-optarglist? expr) + (map process-args (optarglist-vars expr))) + ((ilist-optarglist? expr) + (let loop ((vars (map process-args (optarglist-vars expr)))) + (cond + ((null? (cddr vars)) + (cons (car vars) (cadr vars))) + (else + (cons (car vars) (loop (cdr vars))))))) + (else + (internal-error expr "p->r: not an optarglist")))))) + + ; ---------------------------------------------------------------------- + + (define paroptarglist-pattern 'vars) + + (define-struct paroptarglist-entry (var+marks)) + (define-struct (initialized-paroptarglist-entry struct:paroptarglist-entry) + (expr)) + + (define-struct paroptarglist (vars)) + (define-struct (sym-paroptarglist struct:paroptarglist) ()) + (define-struct (list-paroptarglist struct:paroptarglist) ()) + (define-struct (ilist-paroptarglist struct:paroptarglist) ()) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define paroptarglist-decl-entry-parser-vocab + (create-vocabulary 'paroptarglist-decl-entry-parser-vocab #f + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry")) + + (add-sym-micro paroptarglist-decl-entry-parser-vocab + (lambda (expr env attributes vocab) + (let ((status-holder (get-attribute attributes 'paroptarglist-status))) + (case (unbox status-holder) + ((proper improper) (void)) + ((proper/defaults) + (static-error expr + "Appears after initial value specifications")) + ((improper/defaults) + (set-box! status-holder 'improper/done)) + ((improper/done) + (static-error expr + "Appears past catch-all argument")) + (else (internal-error (unbox status-holder) + "Invalid in paroptarglist-decl-entry-parser-vocab sym")))) + (make-paroptarglist-entry + (create-lexical-binding+marks expr)))) + + (add-list-micro paroptarglist-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern '(var val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((status-holder (get-attribute attributes 'paroptarglist-status))) + (case (unbox status-holder) + ((proper) (set-box! status-holder 'proper/defaults)) + ((improper) (set-box! status-holder 'improper/defaults)) + ((proper/defaults improper/defaults) (void)) + ((improper/done) (static-error expr + "Invalid default value specification")) + (else (internal-error (unbox status-holder) + "Invalid in paroptarglist-decl-entry-parser-vocab list")))) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (val (pat:pexpand 'val p-env kwd))) + (valid-syntactic-id? var) + (make-initialized-paroptarglist-entry + (create-lexical-binding+marks var) + val)))) + (else + (static-error expr "Invalid init-var declaration")))))) + + (define paroptarglist-decls-vocab + (create-vocabulary 'paroptarglist-decls-vocab #f + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry")) + + (add-sym-micro paroptarglist-decls-vocab + (lambda (expr env attributes vocab) + (make-sym-paroptarglist + (list + (make-paroptarglist-entry + (create-lexical-binding+marks expr)))))) + + (add-list-micro paroptarglist-decls-vocab + (lambda (expr env attributes vocab) + (let ((expr (expose-list expr)) + (new-attr (put-attribute attributes 'paroptarglist-status + (box 'proper)))) + (make-list-paroptarglist + (map (lambda (decl) + (expand-expr decl env new-attr + paroptarglist-decl-entry-parser-vocab)) + expr))))) + + (add-ilist-micro paroptarglist-decls-vocab + (lambda (expr env attributes vocab) + (let ((expr-list (expose-list expr)) + (new-attr (put-attribute attributes 'paroptarglist-status + (box 'improper)))) + (let ((result + (map (lambda (decl) + (expand-expr decl env new-attr + paroptarglist-decl-entry-parser-vocab)) + expr-list))) + (let loop ((result result) (exprs expr-list)) + (if (null? (cdr result)) + (when (initialized-paroptarglist-entry? (car result)) + (static-error (car exprs) + "Last argument must not have an initial value")) + (loop (cdr result) (cdr exprs)))) + (make-ilist-paroptarglist result))))) + + (define make-paroptargument-list + (lambda (paroptarglist env attributes vocab) + (extend-env + (map paroptarglist-entry-var+marks + (paroptarglist-vars paroptarglist)) + env) + (let ((result + (map + (lambda (e) + (if (initialized-paroptarglist-entry? e) + (cons + (car (paroptarglist-entry-var+marks e)) + (expand-expr + (initialized-paroptarglist-entry-expr + e) + env attributes vocab)) + (car (paroptarglist-entry-var+marks e)))) + (paroptarglist-vars paroptarglist)))) + (cond + ((sym-paroptarglist? paroptarglist) + (make-sym-paroptarglist result)) + ((list-paroptarglist? paroptarglist) + (make-list-paroptarglist result)) + ((ilist-paroptarglist? paroptarglist) + (make-ilist-paroptarglist result)) + (else + (internal-error paroptarglist + "Invalid in make-paroptargument-list")))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (extend-parsed->raw paroptarglist? + (lambda (expr p->r) + (let ((process-args + (lambda (element) + (if (pair? element) + (list (p->r (car element)) (p->r (cdr element))) + (p->r element))))) + (cond + ((sym-paroptarglist? expr) + (process-args (car (paroptarglist-vars expr)))) + ((list-paroptarglist? expr) + (map process-args (paroptarglist-vars expr))) + ((ilist-paroptarglist? expr) + (let loop ((vars (map process-args (paroptarglist-vars expr)))) + (cond + ((null? (cddr vars)) + (cons (car vars) (cadr vars))) + (else + (cons (car vars) (loop (cdr vars))))))) + (else + (internal-error expr "p->r: not an paroptarglist")))))) + + ; ---------------------------------------------------------------------- + + (define arglist-pattern '(args)) + + (define-struct arglist (vars)) + (define-struct (sym-arglist struct:arglist) ()) + (define-struct (list-arglist struct:arglist) ()) + (define-struct (ilist-arglist struct:arglist) ()) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define (make-arglist-decls-vocab) + (create-vocabulary 'arglist-decls-vocab #f + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry" + "Invalid argument list entry")) + + ; note: the only difference between the lambda-<> vocabs and the <> vocabs + ; is that the lambda-<> vocabs use create-lambda-binding+marks instead + ; of create-lexical-bindings+marks + + (define full-arglist-decls-vocab (make-arglist-decls-vocab)) + (define proper-arglist-decls-vocab (make-arglist-decls-vocab)) + (define nonempty-arglist-decls-vocab (make-arglist-decls-vocab)) + (define lambda-full-arglist-decls-vocab (make-arglist-decls-vocab)) + (define lambda-proper-arglist-decls-vocab (make-arglist-decls-vocab)) + (define lambda-nonempty-arglist-decls-vocab (make-arglist-decls-vocab)) + + (define (setup-arglist-vocabs binding-constructor + full-vocab + proper-vocab + nonempty-vocab) + (add-sym-micro full-vocab + (lambda (expr env attributes vocab) + (make-sym-arglist + (list + (binding-constructor expr))))) + + (let ([m (lambda (expr env attributes vocab) + (static-error expr "Invalid argument list syntax"))]) + (add-sym-micro proper-vocab m) + (add-sym-micro nonempty-vocab m)) + + (let ([make-arg-list-micro + (lambda (null-ok?) + (lambda (expr env attributes vocab) + (let ((contents (expose-list expr))) + (when (and (not null-ok?) + (null? contents)) + (static-error expr "All procedures must take at least one argument")) + (make-list-arglist + (map binding-constructor contents)))))]) + (add-list-micro nonempty-vocab (make-arg-list-micro #f)) + (add-list-micro proper-vocab (make-arg-list-micro #t)) + (add-list-micro full-vocab (make-arg-list-micro #t))) + + (let ([m (lambda (expr env attributes vocab) + (static-error expr "Invalid argument list syntax"))]) + (add-ilist-micro proper-vocab m) + (add-ilist-micro nonempty-vocab m)) + + (add-ilist-micro full-vocab + (lambda (expr env attributes vocab) + (make-ilist-arglist + (map binding-constructor (expose-list expr)))))) + + (setup-arglist-vocabs create-lexical-binding+marks + full-arglist-decls-vocab + proper-arglist-decls-vocab + nonempty-arglist-decls-vocab) + + (setup-arglist-vocabs create-lambda-binding+marks + lambda-full-arglist-decls-vocab + lambda-proper-arglist-decls-vocab + lambda-nonempty-arglist-decls-vocab) + + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define make-argument-list + (lambda (arglist) + (cond + ((sym-arglist? arglist) + (make-sym-arglist + (map car (arglist-vars arglist)))) + ((list-arglist? arglist) + (make-list-arglist + (map car (arglist-vars arglist)))) + ((ilist-arglist? arglist) + (make-ilist-arglist + (map car (arglist-vars arglist)))) + (else + (internal-error arglist "Invalid in make-argument-list"))))) + + (extend-parsed->raw arglist? + (lambda (expr p->r) + (cond + ((sym-arglist? expr) + (p->r (car (arglist-vars expr)))) + ((list-arglist? expr) + (map p->r (arglist-vars expr))) + ((ilist-arglist? expr) + (let loop ((vars (map p->r (arglist-vars expr)))) + (cond + ((null? (cddr vars)) + (cons (car vars) (cadr vars))) + (else + (cons (car vars) (loop (cdr vars))))))) + (else + (internal-error expr "p->r: not an arglist"))))) + + ) diff --git a/collects/zodiac/scm-hanc.ss b/collects/zodiac/scm-hanc.ss new file mode 100644 index 00000000..f71cc282 --- /dev/null +++ b/collects/zodiac/scm-hanc.ss @@ -0,0 +1,2126 @@ +; $Id: scm-hanc.ss,v 1.63 1999/05/21 12:53:26 mflatt Exp $ + +(define-struct signature-element (source)) +(define-struct (name-element struct:signature-element) (name)) +(define-struct (unit-element struct:signature-element) (id signature)) + +(define immediate-signature-name '||) + +(define cu/s-this-link-attr 'cu/s-this-link-name) + +(define-struct signature (name elements exploded)) + +; Cheap trick: instead of fixing the vocabs to ignore the +; environment (if possible) , we just drop the environment. +(define (sig-env e) + (make-empty-environment)) + +(define check-unique-cu/s-exports + (lambda (in:exports sign:exports) + (let loop ((in:all in:exports) + (sign:all sign:exports) + (in:names null) + (sign:names null) + (in:rest null) + (sign:rest null)) + (if (or (null? sign:all) (null? in:all)) + (begin + (let loop ((in in:rest) + (signs (map car sign:rest))) + (unless (null? in) + (if (memq (car signs) (cdr signs)) + (static-error (car in) + "Name \"~s\" is exported twice" + (car signs)) + (loop (cdr in) (cdr signs))))) + (let loop ((in in:names) + (signs sign:names)) + (unless (null? in) + (if (memq (car signs) (cdr signs)) + (static-error (car in) + "Name \"~s\" is exported twice" + (car signs)) + (loop (cdr in) (cdr signs)))))) + (let ((in (car in:all)) (sign (car sign:all))) + (if (or (symbol? sign) (z:symbol? sign)) + (loop (cdr in:all) (cdr sign:all) + (cons in in:names) + (cons (if (symbol? sign) + sign + (z:read-object sign)) + sign:names) + in:rest sign:rest) + (loop (cdr in:all) (cdr sign:all) + in:names sign:names + (cons in in:rest) + (cons sign sign:rest)))))))) + +; This is based on code lifted from Matthew's implementation (note the +; use of brackets (-:). + +(define verify-duplicates-&-sort-signature-elements + (lambda (elements) + (let loop ((seen '()) (rest elements)) + (unless (null? rest) + (let ((first (car rest))) + (let ((first-name + (cond + ((name-element? first) + (name-element-name first)) + ((unit-element? first) + (unit-element-id first)) + (else + (internal-error first "Invalid unit element"))))) + (when (memq first-name seen) + (static-error (signature-element-source first) + "Duplicate signature entry: ~s" first-name)) + (loop (cons first-name seen) (cdr rest)))))) + (letrec + ((split + (lambda (l f s) + (cond + [(null? l) (values f s)] + [(null? (cdr l)) (values (cons (car l) f) s)] + [else (split (cddr l) (cons (car l) f) + (cons (cadr l) s))]))) + (merge + (lambda (f s) + (cond + [(null? f) s] + [(null? s) f] + [(less-than? (car s) (car f)) + (cons (car s) (merge f (cdr s)))] + [else + (cons (car f) (merge (cdr f) s))]))) + (less-than? + (lambda (a b) + (if (name-element? a) + (if (name-element? b) + (symbol-less-than? (name-element-name a) + (name-element-name b)) + #t) + (if (name-element? b) + #f + (symbol-less-than? (unit-element-id a) + (unit-element-id b)))))) + (symbol-less-than? + (lambda (a b) + (stringstring a) (symbol->string b))))) + (let loop ([elements elements]) + (cond + [(null? elements) null] + [(null? (cdr elements)) elements] + [else (let-values ([(f s) (split elements null null)]) + (merge (loop f) (loop s)))]))))) + +(define explode-signature-elements + (lambda (elements) + (map (lambda (elt) + (cond + ((name-element? elt) + (name-element-name elt)) + ((unit-element? elt) + (cons (unit-element-id elt) + (signature-exploded (unit-element-signature elt)))) + (else + (internal-error elt "Invalid signature element")))) + elements))) + +(define sig-list->sig-vector + (lambda (l) + (list->vector + (map + (lambda (e) + (if (or (z:symbol? e) (symbol? e)) + e + (named-sig-list->named-sig-vector e))) + l)))) + +(define named-sig-list->named-sig-vector + (lambda (l) + (cons (car l) + (sig-list->sig-vector (cdr l))))) + +(define create-signature + (opt-lambda (elements (name immediate-signature-name)) + (let ((sorted-elements + (verify-duplicates-&-sort-signature-elements elements))) + (make-signature name sorted-elements + (explode-signature-elements sorted-elements))))) + +(define add-signature + (lambda (name attributes elements) + (let ((sig-space (get-attribute attributes 'sig-space + (lambda () + (let ((ss (make-hash-table))) + (put-attribute attributes 'sig-space ss) + ss))))) + (hash-table-put! sig-space (z:read-object name) + (create-signature elements (z:read-object name)))))) + +(define push-signature + (lambda (name attributes elements) + (let ((sig-space (get-attribute attributes 'sig-space + (lambda () + (let ((ss (make-hash-table))) + (put-attribute attributes 'sig-space ss) + ss))))) + (begin0 + (hash-table-get sig-space (z:read-object name) + (lambda () #f)) + (hash-table-put! sig-space (z:read-object name) + (create-signature elements (z:read-object name))))))) + +(define pop-signature + (lambda (name attributes old-value) + (let ((sig-space (get-attribute attributes 'sig-space + (lambda () + (let ((ss (make-hash-table))) + (put-attribute attributes 'sig-space ss) + ss))))) + (hash-table-remove! sig-space (z:read-object name)) + (when old-value + (hash-table-put! sig-space (z:read-object name) + old-value))))) + +(define lookup-signature + (lambda (name attributes) + (let ((sig-space (get-attribute attributes 'sig-space))) + (if sig-space + (let ((entry + (hash-table-get sig-space (z:read-object name) + (lambda () + (static-error name "Unbound signature name: ~s" + (z:read-object name)))))) + entry) + (static-error name "Unbound signature name: ~s" + (z:read-object name)))))) + +(define extract-sub-unit-signature + (lambda (signature indices) + (if (null? indices) + signature + (let* ((first (car indices)) + (raw-first (z:read-object first))) + (let loop ((elements (signature-elements signature))) + (if (null? elements) + (static-error first "No such sub-unit in signature") + (if (unit-element? (car elements)) + (if (eq? raw-first (unit-element-id (car elements))) + (extract-sub-unit-signature + (unit-element-signature (car elements)) + (cdr indices)) + (loop (cdr elements))) + (loop (cdr elements))))))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define cu/s-attr 'compound-unit/sig-table) + +(define-struct tag-table-entry (signature)) +(define-struct (tag-table-import-entry struct:tag-table-entry) ()) +(define-struct (tag-table-link-entry struct:tag-table-entry) ()) + +(define extract-cu/s-tag-table + (lambda (attributes) + (car + (get-attribute attributes cu/s-attr + (lambda () + (internal-error attributes + "Unable to find compound-unit/sig attribute")))))) + +(define cu/s-tag-table-put + (lambda (maker) + (lambda (table tag sig env attributes) + (hash-table-put! table (z:read-object tag) + (maker (expand-expr sig env attributes sig-vocab)))))) + +(define cu/s-tag-table-put/import + (cu/s-tag-table-put make-tag-table-import-entry)) + +(define cu/s-tag-table-put/link + (cu/s-tag-table-put make-tag-table-link-entry)) + +(define cu/s-tag-table-lookup + (opt-lambda (table tag (not-found (lambda () #f))) + (hash-table-get table (z:read-object tag) not-found))) + +(define cu/s-tag-table-lookup/static-error + (lambda (table tag) + (cu/s-tag-table-lookup table tag + (lambda () + (static-error tag "Unbound tag"))))) + +(define cu/s-tag-table-lookup/internal-error + (lambda (table tag) + (cu/s-tag-table-lookup table tag + (lambda () + (internal-error tag "Should have been bound"))))) + +; -------------------------------------------------------------------- + +(define sig-vocab + (create-vocabulary 'sig-vocab #f + "Invalid signature expression" + "Invalid signature expression" + "Invalid signature expression" + "Invalid signature expression")) + +(add-sym-micro sig-vocab + (lambda (expr env attributes vocab) + (lookup-signature expr attributes))) + +(add-list-micro sig-vocab + (lambda (expr env attributes vocab) + (let ((contents (expose-list expr))) + (create-signature + (apply append + (map (lambda (e) + (expand-expr e env attributes sig-element-vocab)) + contents)))))) + +; -------------------------------------------------------------------- + +(define sig-element-vocab + (create-vocabulary 'sig-element-vocab #f + "Invalid signature element" + "Invalid signature element" + "Invalid signature element" + "Invalid signature element")) + +(add-sym-micro sig-element-vocab + (lambda (expr env attributes vocab) + (list (make-name-element expr (z:read-object expr))))) + +(add-micro-form 'struct sig-element-vocab + (let* ((kwd '(struct)) + (in-pattern '(struct base (field ...) omit ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((base (pat:pexpand 'base p-env kwd)) + (fields (pat:pexpand '(field ...) p-env kwd)) + (in:omits (pat:pexpand '(omit ...) p-env kwd))) + (valid-syntactic-id? base) + (valid-syntactic-id/s? fields) + (let ((omit-names + (map (lambda (o) + (expand-expr o env attributes + signature-struct-omission-checker-vocab)) + in:omits))) + (let ((generated-names + (map z:read-object + (generate-struct-names base fields expr + (memq '-selectors omit-names) + (memq '-setters omit-names))))) + (let loop ((omits omit-names)) + (unless (null? omits) + (let ((first (car omits))) + (when (z:symbol? first) + (unless (memq (z:read-object first) generated-names) + (static-error first + "Name not generated; illegal to omit"))) + (loop (cdr omits))))) + (let ((real-omits + (let loop ((omits omit-names)) + (if (null? omits) '() + (if (symbol? (car omits)) + (loop (cdr omits)) + (cons (z:read-object (car omits)) + (loop (cdr omits)))))))) + (let loop ((names generated-names)) + (if (null? names) '() + (if (memq (car names) real-omits) + (loop (cdr names)) + (cons (make-name-element expr (car names)) + (loop (cdr names)))))))))))) + (else + (static-error expr "Malformed struct clause")))))) + +(define signature-struct-omission-checker-vocab + (create-vocabulary 'signature-struct-omission-checker-vocab #f + "Invalid signature structure omission declaration" + "Invalid signature structure omission declaration" + "Invalid signature structure omission declaration" + "Invalid signature structure omission declaration")) + +(add-sym-micro signature-struct-omission-checker-vocab + (lambda (expr env attributes vocab) + (let ((raw-expr (z:read-object expr))) + (unless (memq raw-expr '(-selectors -setters)) + (static-error expr "Invalid omission specifier")) + raw-expr))) + +(add-micro-form '- signature-struct-omission-checker-vocab + (let* ((kwd '(-)) + (in-pattern '(- var)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd))) + (valid-syntactic-id? var) + (structurize-syntax (z:read-object var) expr)))) + (else + (static-error expr "Malformed omission specifier")))))) + +(add-micro-form 'open sig-element-vocab + (let* ((kwd '(open)) + (in-pattern '(open sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? sig) + (signature-elements + (expand-expr sig env attributes sig-vocab))))) + (else + (static-error expr "Malformed open clause")))))) + +(add-micro-form 'unit sig-element-vocab + (let* ((kwd '(unit :)) + (in-pattern '(unit id : sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((id (pat:pexpand 'id p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? id) + (list (make-unit-element expr (z:read-object id) + (expand-expr sig env attributes sig-vocab)))))) + (else + (static-error expr "Malformed unit clause")))))) + +; -------------------------------------------------------------------- + +(define u/s-prim-imports-vocab + (create-vocabulary 'u/s-prim-imports-vocab #f + "Invalid imports declaration" + "Invalid imports declaration" + "Invalid imports declaration" + "Invalid imports declaration")) + +(add-sym-micro u/s-prim-imports-vocab + (lambda (expr env attributes vocab) + (convert-to-prim-format + (signature-elements + (lookup-signature expr attributes))))) + +(add-list-micro u/s-prim-imports-vocab + (let* ((kwd '(:)) + (in-pattern-1 '(id : sig)) + (in-pattern-2 '(id : any ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((id (pat:pexpand 'id p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? id) + (convert-to-prim-format + (signature-elements + (expand-expr sig env attributes sig-vocab)) + (z:read-object id))))) + ((pat:match-against m&e-2 expr env) + (static-error expr "Ambiguous : in signature")) + (else + (convert-to-prim-format + (signature-elements + (expand-expr expr env attributes sig-vocab)))))))) + +(define convert-to-prim-format + (opt-lambda (sig-elements (prefix #f)) + (convert-to-prim-format-helper sig-elements + (cond + ((symbol? prefix) + (let ((s (symbol->string prefix))) + (if (string=? "" s) + s + (string-append s ":")))) + ((string? prefix) + prefix) + (else + ""))))) + +(define convert-to-prim-format-helper + (lambda (sig-elements prefix-string) + (apply append + (map (lambda (elt) + (cond + ((name-element? elt) + (list + (string->symbol + (string-append prefix-string + (symbol->string (name-element-name elt)))))) + ((unit-element? elt) + (let ((new-prefix + (string-append prefix-string + (symbol->string (unit-element-id elt)) + ":"))) + (convert-to-prim-format-helper + (signature-elements + (unit-element-signature elt)) + new-prefix))) + (else + (internal-error elt "Illegal signature element")))) + sig-elements)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define u/s-sign-imports-vocab + (create-vocabulary 'u/s-sign-imports-vocab #f + "Invalid signature imports declaration" + "Invalid signature imports declaration" + "Invalid signature imports declaration" + "Invalid signature imports declaration")) + +(add-sym-micro u/s-sign-imports-vocab + (lambda (expr env attributes vocab) + (cons (z:read-object expr) + (signature-exploded + (lookup-signature expr attributes))))) + +(add-list-micro u/s-sign-imports-vocab + (let* ((kwd '(:)) + (in-pattern-1 '(id : sig)) + (in-pattern-2 '(id : any ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((id (pat:pexpand 'id p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? id) + (cons (z:read-object id) + (signature-exploded + (expand-expr sig env attributes sig-vocab)))))) + ((pat:match-against m&e-2 expr env) + (static-error expr "Ambiguous : in signature")) + (else + (cons immediate-signature-name + (explode-signature-elements + (signature-elements + (expand-expr expr env attributes sig-vocab))))))))) + +; -------------------------------------------------------------------- + +(define create-prim-exports + (lambda (export-sig renames source env attributes) + (let ((sig-names (signature-elements + (expand-expr export-sig env attributes sig-vocab)))) + (let ((table (make-hash-table))) + (for-each (lambda (z-rename) + (let ((rename-couple (expose-list z-rename))) + (hash-table-put! table + (z:read-object (cadr rename-couple)) + (z:read-object (car rename-couple))))) + renames) + (let loop ((sig-names sig-names)) + (if (null? sig-names) + '() + (let ((first (car sig-names))) + (when (unit-element? first) + (static-error source "Unit exports not allowed")) + (let ((name (name-element-name first))) + (cons + (let ((entry (hash-table-get table name (lambda () #f)))) + (if entry + (list entry name) + (list name name))) + (loop (cdr sig-names))))))))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define u/s-sign-exports-vocab + (create-vocabulary 'u/s-sign-exports-vocab #f + "Invalid signature exports declaration" + "Invalid signature exports declaration" + "Invalid signature exports declaration" + "Invalid signature exports declaration")) + +(add-sym-micro u/s-sign-exports-vocab + (lambda (expr env attributes vocab) + (signature-exploded + (lookup-signature expr attributes)))) + +(add-list-micro u/s-sign-exports-vocab + (let* ((kwd '(:)) + (in-pattern-1 '(id : sig)) + (in-pattern-2 '(id : any ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((id (pat:pexpand 'id p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? id) + (signature-exploded + (expand-expr sig env attributes sig-vocab))))) + ((pat:match-against m&e-2 expr env) + (static-error expr "Ambiguous : in signature")) + (else + (explode-signature-elements + (signature-elements + (expand-expr expr env attributes sig-vocab)))))))) + +; -------------------------------------------------------------------- + +(define signature->symbols-micro + (let* ((kwd '()) + (in-pattern '(_ name)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((name (pat:pexpand 'name p-env kwd))) + (valid-syntactic-id? name) + (let ((elements + (sig-list->sig-vector + (signature-exploded + (lookup-signature name attributes))))) + (expand-expr + (structurize-syntax `(,'quote ,elements) expr '(-1)) + env attributes vocab))))) + (else + (static-error expr "Malformed signature->symbols")))))) + +(add-primitivized-micro-form 'signature->symbols full-vocabulary signature->symbols-micro) +(add-on-demand-form 'micro 'signature->symbols common-vocabulary signature->symbols-micro) + +(define define-signature-micro + (let* ((kwd '()) + (in-pattern '(_ name sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((name (pat:pexpand 'name p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? name) + (unless (get-top-level-status attributes) + (static-error expr "Only supported at top-level")) + (let ((elements + (signature-elements + (expand-expr sig env attributes sig-vocab)))) + (add-signature name attributes elements)) + (expand-expr + (structurize-syntax '(#%void) expr '(-1) + #f (z:make-origin 'micro expr)) + env attributes vocab)))) + (else + (static-error expr "Malformed define-signature")))))) + +(add-primitivized-micro-form 'define-signature full-vocabulary define-signature-micro) +(add-primitivized-micro-form 'define-signature scheme-vocabulary define-signature-micro) + +(define let-signature-micro + ;; >> Broken by current embedded define hacks! << + ;; e.g., (let ([a 7]) 5 (let-signature a () a)) + (let* ((kwd '()) + (in-pattern '(_ name sig b0 b1 ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((name (pat:pexpand 'name p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd)) + (body (pat:pexpand '(begin b0 b1 ...) p-env kwd))) + (valid-syntactic-id? name) + (let* ((elements + (signature-elements + (expand-expr sig env attributes sig-vocab))) + (old-value (push-signature name attributes elements))) + (dynamic-wind + void + (lambda () + ; Yuck - if name is in the environment, we shadow it + ; by retracting the env: + (let ([new-env + (let loop ([env env]) + (if (lexically-resolved? name env) + (let ([env (copy-env env)] + [var (let ((name (z:read-object name)) + (marks (z:symbol-marks name))) + (resolve-in-env name marks env))]) + (retract-env (list var) env) + (loop env)) + env))]) + (let ([r (expand-expr + (structurize-syntax body expr) + new-env attributes vocab)]) + r))) + (lambda () + (pop-signature name attributes old-value))))))) + (else + (static-error expr "Malformed let-signature")))))) + +(add-primitivized-micro-form 'let-signature full-vocabulary let-signature-micro) +(add-primitivized-micro-form 'let-signature scheme-vocabulary let-signature-micro) + +(define u/s-expand-includes-vocab + (create-vocabulary 'u/s-expand-includes-vocab)) + +(add-primitivized-micro-form 'include u/s-expand-includes-vocab + (let* ((kwd '()) + (in-pattern '(_ filename)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd))) + (unless (z:string? filename) + (static-error filename "File name must be a string")) + (let ((raw-filename (z:read-object filename))) + (let-values (((base name dir?) (split-path raw-filename))) + (when dir? + (static-error filename "Cannot include a directory")) + (let* ((original-directory (current-load-relative-directory)) + (p (with-handlers + ((exn:i/o:filesystem? + (lambda (exn) + (static-error filename + "Unable to open file ~s: ~a" raw-filename exn)))) + (open-input-file + (if (and original-directory + (not (complete-path? raw-filename))) + (path->complete-path raw-filename + original-directory) + raw-filename))))) + (parameterize ([current-load-relative-directory + (if (string? base) + (if (complete-path? base) + base + (path->complete-path base + (or original-directory + (current-directory)))) + (or original-directory + (current-directory)))]) + (dynamic-wind + void + (lambda () + (let ([exprs + (let ((reader (z:read p + (z:make-location + (z:location-line + z:default-initial-location) + (z:location-column + z:default-initial-location) + (z:location-offset + z:default-initial-location) + (build-path + (current-load-relative-directory) + name))))) + (let loop () + (let ((input (reader))) + (if (z:eof? input) + '() + (cons input + (loop))))))]) + (expand-expr (structurize-syntax + (cons 'begin exprs) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes + vocab))) + (lambda () + (close-input-port p)))))))))) + (else + (static-error expr "Malformed include")))))) + +(define unit/sig-micro + (let* ((kwd-1 '(import rename)) + (in-pattern-1 '(_ signature + (import imports ...) + (rename renames ...) + clauses ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) + (kwd-2 '(import)) + (in-pattern-2 '(_ signature + (import imports ...) + clauses ...)) + (out-pattern-2 '(unit/sig signature + (import imports ...) + (rename) + clauses ...)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd-2))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let* ((in:signature (pat:pexpand 'signature p-env kwd-1)) + (in:imports (pat:pexpand '(imports ...) p-env kwd-1)) + (in:renames (pat:pexpand '(renames ...) p-env kwd-1)) + (in:clauses (pat:pexpand '(clauses ...) p-env kwd-1)) + (sigenv (sig-env env))) + (let* ((prim-unit:imports (apply append + (map (lambda (import) + (expand-expr import sigenv + attributes + u/s-prim-imports-vocab)) + in:imports))) + (prim-unit:exports (create-prim-exports in:signature + in:renames expr env attributes)) + (prim-unit:clauses in:clauses) + (sign-unit:imports (map (lambda (import) + (expand-expr import sigenv + attributes + u/s-sign-imports-vocab)) + in:imports)) + (sign-unit:exports (expand-expr in:signature sigenv + attributes u/s-sign-exports-vocab))) + (expand-expr + ;; We don't use '(-1) as the third argument to + ;; structurize-syntax since the + ;; prim-unit:{imports,exports} are raw sexp's + ;; which get undesirably marked in the process, + ;; leading to imports not matching against uses in + ;; the body. This should be remedied by making + ;; these values structurized, so that the + ;; remainder can also be structurized with + ;; impunity and '(-1) can be used. + (structurize-syntax + `(#%make-unit-with-signature + (#%unit + (import ,@prim-unit:imports) + (export ,@prim-unit:exports) + ,@prim-unit:clauses) + (quote ,(map named-sig-list->named-sig-vector sign-unit:imports)) + (quote ,(sig-list->sig-vector sign-unit:exports))) + expr '() + #f + (z:make-origin 'micro expr)) + env attributes (append-vocabulary vocab + u/s-expand-includes-vocab + 'include-within-unit)))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (expand-expr + (structurize-syntax + (pat:pexpand out-pattern-2 p-env kwd-2) + expr + '() + #f + (z:make-origin 'micro expr)) + env attributes vocab))) + (else + (static-error expr "Malformed unit/sig")))))) + + +(add-primitivized-micro-form 'unit/sig full-vocabulary unit/sig-micro) +(add-primitivized-micro-form 'unit/sig scheme-vocabulary unit/sig-micro) + +; -------------------------------------------------------------------- + +(define cu/s-imports-record-tag-sigs-vocab + (create-vocabulary 'cu/s-imports-record-tag-sigs-vocab #f + "Invalid import clause" + "Invalid import clause" + "Invalid import clause" + "Invalid import clause")) + +(add-list-micro cu/s-imports-record-tag-sigs-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (let ((table (extract-cu/s-tag-table attributes))) + (when (cu/s-tag-table-lookup table tag) + (static-error tag + "Duplicate tag definition")) + (cu/s-tag-table-put/import table tag sig env attributes))))) + (else + (static-error expr "Malformed compound-unit/sig import clause")))))) + +(define cu/s-sign-imports-vocab + (create-vocabulary 'cu/s-sign-imports-vocab #f + "Invalid import clause" + "Invalid import clause" + "Invalid import clause" + "Invalid import clause")) + +(add-list-micro cu/s-sign-imports-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + (let ((table (extract-cu/s-tag-table attributes))) + (cons (z:read-object tag) + (signature-exploded + (tag-table-entry-signature + (cu/s-tag-table-lookup/internal-error table tag)))))))) + (else + (static-error expr "Malformed compound-unit/sig import clause")))))) + +(define cu/s-link-imports-vocab + (create-vocabulary 'cu/s-link-imports-vocab #f + "Invalid link imports declaration" + "Invalid link imports declaration" + "Invalid link imports declaration" + "Invalid link imports declaration")) + +(add-list-micro cu/s-link-imports-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + (let ((table (extract-cu/s-tag-table attributes))) + (convert-to-prim-format + (signature-elements + (tag-table-entry-signature + (cu/s-tag-table-lookup/internal-error table tag))) + (z:read-object tag)))))) + (else + (static-error expr "Malformed compound-unit/sig import clause")))))) + +; -------------------------------------------------------------------- + +(define cu/s-link-record-tag-sigs-vocab + (create-vocabulary 'cu/s-link-record-tag-sigs-vocab #f + "Invalid link clause" + "Invalid link clause" + "Invalid link clause" + "Invalid link clause")) + +(add-list-micro cu/s-link-record-tag-sigs-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig misc)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (let ((table (extract-cu/s-tag-table attributes))) + (when (cu/s-tag-table-lookup table tag) + (static-error tag + "Duplicate tag definition")) + (cu/s-tag-table-put/link table tag sig env attributes))))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +(define cu/s-link-exports-vocab + (create-vocabulary 'cu/s-link-exports-vocab #f + "Invalid link export declaration" + "Invalid link export declaration" + "Invalid link export declaration" + "Invalid link export declaration")) + +(add-list-micro cu/s-link-exports-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig misc)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + (let ((table (extract-cu/s-tag-table attributes))) + (signature-exploded + (tag-table-entry-signature + (cu/s-tag-table-lookup/internal-error table tag))))))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +(define cu/s-link-tags-vocab + (create-vocabulary 'cu/s-link-tags-vocab #f + "Invalid link tag declaration" + "Invalid link tag declaration" + "Invalid link tag declaration" + "Invalid link tag declaration")) + +(add-list-micro cu/s-link-tags-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig misc)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + tag))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +(define cu/s-link-exprs-vocab + (create-vocabulary 'cu/s-link-exprs-vocab #f + "Invalid link expression" + "Invalid link expression" + "Invalid link expression" + "Invalid link expression")) + +(add-list-micro cu/s-link-exprs-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig (expr path ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((expr (pat:pexpand 'expr p-env kwd))) + expr))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +(define cu/s-link-linking-sigs-vocab + (create-vocabulary 'cu/s-link-linking-sigs-vocab #f + "Invalid link clause" + "Invalid link clause" + "Invalid link clause" + "Invalid link clause")) + +(add-list-micro cu/s-link-linking-sigs-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig (expr path ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (path-elts (pat:pexpand '(path ...) p-env kwd))) + (map (lambda (p) + (put-attribute attributes cu/s-this-link-attr + (z:read-object tag)) + (expand-expr p env attributes + cu/s-unit-path-linkage-vocab)) + path-elts)))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +(define cu/s-check-self-import + (lambda (tag attributes) + (when #f ; we allow self-import, now + (when (eq? (z:read-object tag) + (get-attribute attributes cu/s-this-link-attr + (lambda () (internal-error tag "No this-link attribute")))) + (static-error tag "Self import of tag ~s" (z:read-object tag)))))) + +(define cu/s-link-prim-unit-names-vocab + (create-vocabulary 'cu/s-link-prim-unit-names-vocab #f + "Invalid link clause" + "Invalid link clause" + "Invalid link clause" + "Invalid link clause")) + +(add-list-micro cu/s-link-prim-unit-names-vocab + (let* ((kwd '(:)) + (in-pattern '(tag : sig (expr path ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (path-elts (pat:pexpand '(path ...) p-env kwd))) + (apply append + (map (lambda (p) + (expand-expr p env attributes + cu/s-unit-path-prim-links-vocab)) + path-elts))))) + (else + (static-error expr "Malformed compound-unit/sig link clause")))))) + +; -------------------------------------------------------------------- + +(define cu/s-unit-path-extract-final-sig-vocab + (create-vocabulary 'cu/s-unit-path-extract-final-sig-vocab)) + +(add-sym-micro cu/s-unit-path-extract-final-sig-vocab + (lambda (expr env attributes vocab) + (let ((sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) + expr)))) + sig))) + +(add-list-micro cu/s-unit-path-extract-final-sig-vocab + (let* ((kwd '(:)) + (in-pattern-1 '((tag id ...) : sig)) + (in-pattern-2 '(tag : sig)) + (in-pattern-3 '(tag id ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (map valid-syntactic-id? ids) + (let ((initial-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag)))) + (let ((final-sig + (extract-sub-unit-signature initial-sig ids)) + (small-sig + (expand-expr sig env attributes sig-vocab))) + (with-handlers + ((exn:unit? + (lambda (exn) + (static-error expr + (exn-message exn))))) + (verify-signature-match 'compound-unit/sig + #f + (format "signature ~s" (signature-name small-sig)) + (sig-list->sig-vector (signature-exploded small-sig)) + (format "signature ~s" (signature-name final-sig)) + (sig-list->sig-vector (signature-exploded final-sig)))) + small-sig))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (let ((big-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag))) + (small-sig + (expand-expr sig env attributes sig-vocab))) + (with-handlers + ((exn:unit? + (lambda (exn) + (static-error expr + (exn-message exn))))) + (verify-signature-match 'compound-unit/sig + #f + (format "signature ~s" (signature-name small-sig)) + (sig-list->sig-vector (signature-exploded small-sig)) + (format "signature ~s" (signature-name big-sig)) + (sig-list->sig-vector (signature-exploded big-sig))) + small-sig))))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (valid-syntactic-id? tag) + (map valid-syntactic-id? ids) + (let ((initial-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag)))) + (let ((final-sig + (extract-sub-unit-signature initial-sig ids))) + final-sig))))) + (else + (static-error expr "Malformed unit path element")))))) + +(define cu/s-unit-path-linkage-vocab + (create-vocabulary 'cu/s-unit-path-linkage-vocab #f + "Invalid linkage" + "Invalid linkage" + "Invalid linkage" + "Invalid linkage")) + +(add-sym-micro cu/s-unit-path-linkage-vocab + (lambda (expr env attributes vocab) + (cu/s-check-self-import expr attributes) + (let ((sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) + expr)))) + (cons (z:read-object expr) + (signature-exploded sig))))) + +(add-list-micro cu/s-unit-path-linkage-vocab + (let* ((kwd '(:)) + (in-pattern-1 '((tag id ...) : sig)) + (in-pattern-2 '(tag : sig)) + (in-pattern-3 '(tag id ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (cu/s-check-self-import tag attributes) + (map valid-syntactic-id? ids) + (let ((initial-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag)))) + (let ((final-sig + (extract-sub-unit-signature initial-sig ids)) + (small-sig + (expand-expr sig env attributes sig-vocab))) + (with-handlers + ((exn:unit? + (lambda (exn) + (static-error expr + (exn-message exn))))) + (verify-signature-match 'compound-unit/sig + #f + (format "signature ~s" (signature-name small-sig)) + (sig-list->sig-vector (signature-exploded small-sig)) + (format "signature ~s" (signature-name final-sig)) + (sig-list->sig-vector (signature-exploded final-sig))) + (cons (z:read-object tag) + (signature-exploded small-sig)))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? tag) + (cu/s-check-self-import tag attributes) + (let ((big-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag))) + (small-sig + (expand-expr sig env attributes sig-vocab))) + (with-handlers + ((exn:unit? + (lambda (exn) + (static-error expr + (exn-message exn))))) + (verify-signature-match 'compound-unit/sig + #f + (format "signature ~s" (signature-name small-sig)) + (sig-list->sig-vector (signature-exploded small-sig)) + (format "signature ~s" (signature-name big-sig)) + (sig-list->sig-vector (signature-exploded big-sig))) + (cons (z:read-object tag) + (signature-exploded small-sig))))))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (valid-syntactic-id? tag) + (cu/s-check-self-import tag attributes) + (map valid-syntactic-id? ids) + (let ((initial-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag)))) + (let ((final-sig + (extract-sub-unit-signature initial-sig ids))) + (cons (z:read-object tag) + (signature-exploded final-sig))))))) + (else + (static-error expr "Malformed unit path element")))))) + +(define cu/s-unit-path-prim-links-vocab + (create-vocabulary 'cu/s-unit-path-prim-links-vocab #f + "Invalid linkage" + "Invalid linkage" + "Invalid linkage" + "Invalid linkage")) + +(add-sym-micro cu/s-unit-path-prim-links-vocab + (lambda (expr env attributes vocab) + (let ((tag-table-entry + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) + expr))) + (let ((sig (tag-table-entry-signature tag-table-entry))) + (cond + ((tag-table-import-entry? tag-table-entry) + (cu/s-build-link-names sig + (string-append + (cu/s-build-link-prefix (list expr)) + ":"))) + ((tag-table-link-entry? tag-table-entry) + (list + (cons (z:read-object expr) + (cu/s-build-link-names sig)))) + (else + (internal-error tag-table-entry "Illegal tag-table entry"))))))) + +(add-list-micro cu/s-unit-path-prim-links-vocab + (let* ((kwd '(:)) + (in-pattern-1 '((tag id ...) : sig)) + (in-pattern-2 '(tag : sig)) + (in-pattern-3 '(tag id ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (let ((small-sig + (expand-expr sig env attributes sig-vocab))) + (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error + (extract-cu/s-tag-table attributes) + tag))) + (cond + ((tag-table-import-entry? tag-table-entry) + (cu/s-build-link-names small-sig + (string-append + (cu/s-build-link-prefix ids tag) + ":"))) + ((tag-table-link-entry? tag-table-entry) + (list + (cons (z:read-object tag) + (cu/s-build-link-names small-sig + (cu/s-build-link-prefix ids))))) + (else + (internal-error tag-table-entry + "Illegal tag-table entry")))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (let ((small-sig + (expand-expr sig env attributes sig-vocab))) + (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error + (extract-cu/s-tag-table attributes) + tag))) + (cond + ((tag-table-import-entry? tag-table-entry) + (cu/s-build-link-names small-sig + (string-append + (cu/s-build-link-prefix (list tag)) + ":"))) + ((tag-table-link-entry? tag-table-entry) + (list + (cons (z:read-object tag) + (cu/s-build-link-names small-sig)))) + (else + (internal-error tag-table-entry + "Illegal tag-table entry")))))))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (let ((initial-sig + (tag-table-entry-signature + (cu/s-tag-table-lookup/static-error + (extract-cu/s-tag-table attributes) tag)))) + (let ((final-sig + (extract-sub-unit-signature initial-sig ids))) + (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error + (extract-cu/s-tag-table attributes) + tag))) + (cond + ((tag-table-import-entry? tag-table-entry) + (cu/s-build-link-names final-sig + (string-append + (cu/s-build-link-prefix ids tag) + ":"))) + ((tag-table-link-entry? tag-table-entry) + (list + (cons (z:read-object tag) + (cu/s-build-link-names final-sig + (string-append + (cu/s-build-link-prefix ids) + ":"))))) + (else + (internal-error tag-table-entry + "Illegal tag-table entry"))))))))) + (else + (static-error expr "Malformed unit path element")))))) + +(define cu/s-unit-path-tag+build-prefix-vocab + (create-vocabulary 'cu/s-unit-path-tag+build-prefix-vocab)) + +; Returns a pair of values: +; - Prefix tag of unit-path as Scheme symbol +; - String representing unit-path with ":" interspersed + +(add-sym-micro cu/s-unit-path-tag+build-prefix-vocab + (lambda (expr env attributes vocab) + (cons (z:read-object expr) + ""))) + +(add-list-micro cu/s-unit-path-tag+build-prefix-vocab + (let* ((kwd '(:)) + (in-pattern-1 '((tag id ...) : sig)) + (in-pattern-2 '(tag : sig)) + (in-pattern-3 '(tag id ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (cons (z:read-object tag) + (apply symbol-append + (let loop ((ids ids)) + (if (null? ids) '("") + (if (null? (cdr ids)) + (list (z:read-object (car ids))) + (cons (z:read-object (car ids)) + (cons ":" + (loop (cdr ids)))))))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + (cons (z:read-object tag) + "")))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (cons (z:read-object tag) + (apply symbol-append + (let loop ((ids ids)) + (if (null? ids) '("") + (if (null? (cdr ids)) + (list (z:read-object (car ids))) + (cons (z:read-object (car ids)) + (cons ":" + (loop (cdr ids)))))))))))) + (else + (static-error expr "Malformed unit path element")))))) + +(define cu/s-unit-path-tag-vocab + (create-vocabulary 'cu/s-unit-path-tag-vocab)) + +; Returns prefix tag of unit-path as Scheme symbol + +(add-sym-micro cu/s-unit-path-tag-vocab + (lambda (expr env attributes vocab) + (z:read-object expr))) + +(add-list-micro cu/s-unit-path-tag-vocab + (let* ((kwd '(:)) + (in-pattern-1 '((tag id ...) : sig)) + (in-pattern-2 '(tag : sig)) + (in-pattern-3 '(tag id ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd)) + (sig (pat:pexpand 'sig p-env kwd))) + (cons (z:read-object tag) + (apply symbol-append + (let loop ((ids ids)) + (if (null? ids) '("") + (if (null? (cdr ids)) + (list (z:read-object (car ids))) + (cons (z:read-object (car ids)) + (cons ":" + (loop (cdr ids)))))))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd))) + (z:read-object tag)))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (z:read-object tag)))) + (else + (static-error expr "Malformed unit path element")))))) + +(define cu/s-build-link-names + (opt-lambda (signature (prefix-string "")) + (convert-to-prim-format-helper (signature-elements signature) + prefix-string))) + +(define cu/s-build-link-prefix + (opt-lambda (ids (tag #f)) + (if (null? ids) + "" + (apply string-append + (let ((result (let loop ((str-ids (map symbol->string + (map z:read-object ids)))) + (if (null? (cdr str-ids)) + (list (car str-ids)) + (cons (car str-ids) + (cons ":" + (loop (cdr str-ids)))))))) + (if tag + (cons (symbol->string (z:read-object tag)) + (cons ":" + result)) + result)))))) + +; -------------------------------------------------------------------- + +(define-struct cu/s-export ()) +(define-struct (cu/s-var-export struct:cu/s-export) (var external)) +(define-struct (cu/s-unit-export struct:cu/s-export) (sig name)) +(define-struct (cu/s-open-export struct:cu/s-export) (sig)) + +(define cu/s-verify-variable-in-path + (lambda (path variable env attributes) + (let ((tag-table (extract-cu/s-tag-table attributes))) + (let ((final-sig (expand-expr path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (cu/s-verify-variable-in-sig + (signature-exploded final-sig) + variable))))) + +(define cu/s-verify-variable-in-sig + (lambda (sig variable) + (let ((raw-var (z:read-object variable))) + (let loop ((elements (signature-elements sig))) + (if (null? elements) + (static-error variable "No such identifier in signature") + (or (and (name-element? (car elements)) + (eq? raw-var (name-element-name (car elements)))) + (loop (cdr elements)))))))) + +(define cu/s-prim-export-vocab + (create-vocabulary 'cu/s-prim-export-vocab #f + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration")) + +; Returns a fully-formed export element of the form +; (tag (internal-name external-name)) +; where each is a symbol or a z:symbol + +(define prefix-w/-: + (lambda (prefix name) + (cond + ((symbol? prefix) + (if (string=? "" (symbol->string prefix)) + name + (symbol-append prefix ":" name))) + ((string? prefix) + (if (string=? "" prefix) + name + (symbol-append prefix ":" name))) + (else + (internal-error 'prefix-w/-: "Got ~s as prefix" prefix))))) + +(add-micro-form 'var cu/s-prim-export-vocab + (let* ((kwd '(var)) + (in-pattern-1 '(var (unit-path variable))) + (in-pattern-2 '(var (unit-path variable) external-variable)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd))) + (valid-syntactic-id? variable) + (let ((tag+prefix + (expand-expr unit-path env attributes + cu/s-unit-path-tag+build-prefix-vocab))) + (cons (car tag+prefix) + (list (list (prefix-w/-: (cdr tag+prefix) + (z:read-object variable)) + variable))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd)) + (external (pat:pexpand 'external-variable p-env kwd))) + (valid-syntactic-id? variable) + (valid-syntactic-id? external) + (let ((tag+prefix + (expand-expr unit-path env attributes + cu/s-unit-path-tag+build-prefix-vocab))) + (cons (car tag+prefix) + (list (list (prefix-w/-: (cdr tag+prefix) + (z:read-object variable)) + external))))))) + (else + (static-error expr "Malformed var export")))))) + +(add-micro-form 'open cu/s-prim-export-vocab + (let* ((kwd '(open)) + (in-pattern '(open unit-path)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) + (let ((tag+prefix + (expand-expr unit-path env attributes + cu/s-unit-path-tag+build-prefix-vocab)) + (final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (cons (car tag+prefix) + (map list + (convert-to-prim-format + (signature-elements final-sig) + (cdr tag+prefix)) + (convert-to-prim-format + (signature-elements final-sig)))))))) + (else + (static-error expr "Malformed open export")))))) + +(add-micro-form 'unit cu/s-prim-export-vocab + (let* ((kwd '(unit)) + (in-pattern-1 '(unit unit-path)) + (in-pattern-2 '(unit unit-path variable)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) + (let ((tag+prefix + (expand-expr unit-path env attributes + cu/s-unit-path-tag+build-prefix-vocab)) + (final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (cons (car tag+prefix) + (map list + (convert-to-prim-format (signature-elements final-sig) + (cdr tag+prefix)) + (convert-to-prim-format (signature-elements final-sig) + (car tag+prefix)))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd))) + (valid-syntactic-id? variable) + (let ((tag+prefix + (expand-expr unit-path env attributes + cu/s-unit-path-tag+build-prefix-vocab)) + (final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (cons (car tag+prefix) + (map list + (convert-to-prim-format (signature-elements final-sig) + (cdr tag+prefix)) + (convert-to-prim-format (signature-elements final-sig) + (z:read-object variable)))))))) + (else + (static-error expr "Malformed unit export")))))) + +(define cu/s-export-sign-vocab + (create-vocabulary 'cu/s-export-sign-vocab)) + +(add-micro-form 'var cu/s-export-sign-vocab + (let* ((kwd '(var)) + (in-pattern-1 '(var (unit-path variable))) + (in-pattern-2 '(var (unit-path variable) external-variable)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd))) + (list variable)))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd)) + (external (pat:pexpand 'external-variable p-env kwd))) + (list external)))) + (else + (static-error expr "Malformed var export")))))) + +(add-micro-form 'open cu/s-export-sign-vocab + (let* ((kwd '(open)) + (in-pattern '(open unit-path)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) + (let ((final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (signature-exploded final-sig))))) + (else + (static-error expr "Malformed open export")))))) + +(add-micro-form 'unit cu/s-export-sign-vocab + (let* ((kwd '(unit)) + (in-pattern-1 '(unit unit-path)) + (in-pattern-2 '(unit unit-path variable)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) + (let ((tag + (expand-expr unit-path env attributes + cu/s-unit-path-tag-vocab)) + (final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (list (cons tag + (signature-exploded final-sig))))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) + (variable (pat:pexpand 'variable p-env kwd))) + (let ((tag + (expand-expr unit-path env attributes + cu/s-unit-path-tag-vocab)) + (final-sig + (expand-expr unit-path env attributes + cu/s-unit-path-extract-final-sig-vocab))) + (list (cons (z:read-object variable) + (signature-exploded final-sig))))))) + (else + (static-error expr "Malformed unit export")))))) + +; -------------------------------------------------------------------- + +(define record-tag-signatures + (lambda (imports links env attributes) + (map (lambda (i) + (expand-expr i env attributes cu/s-imports-record-tag-sigs-vocab)) + imports) + (map (lambda (l) + (expand-expr l env attributes cu/s-link-record-tag-sigs-vocab)) + links))) + +(define compound-unit/sig-micro + (let* ((kwd '(import link export)) + (in-pattern '(_ + (import imports ...) + (link links ...) + (export exports ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (put-attribute attributes cu/s-attr + (cons (make-hash-table) + (get-attribute attributes cu/s-attr + (lambda () '())))) + (let* ((in:imports (pat:pexpand '(imports ...) p-env kwd)) + (in:links (pat:pexpand '(links ...) p-env kwd)) + (in:exports (pat:pexpand '(exports ...) p-env kwd)) + (sigenv (sig-env env))) + (record-tag-signatures in:imports in:links sigenv attributes) + ;; linkage = given to verify-linkage-signature-match + ;; prim = goes into underlying compound-unit + ;; sign = given to make-unit-with-signature + (let* ((linkage:tags (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-tags-vocab)) + in:links)) + (linkage:unit-vars linkage:tags) + (linkage:unit-exprs (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-exprs-vocab)) + in:links)) + (linkage:link-exports + (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-exports-vocab)) + in:links)) + (linkage:link-imports + (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-linking-sigs-vocab)) + in:links)) + (prim:imports (apply append + (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-imports-vocab)) + in:imports))) + (prim:links (map (lambda (l) + (expand-expr l sigenv attributes + cu/s-link-prim-unit-names-vocab)) + in:links)) + (prim:exports (map (lambda (e) + (expand-expr e sigenv attributes + cu/s-prim-export-vocab)) + in:exports)) + (sign:imports (map (lambda (i) + (expand-expr i sigenv attributes + cu/s-sign-imports-vocab)) + in:imports)) + (sign:exports (apply append + (map (lambda (e) + (expand-expr e sigenv attributes + cu/s-export-sign-vocab)) + in:exports)))) + (check-unique-cu/s-exports in:exports sign:exports) + (let ((output + `(let ,(map list linkage:unit-vars linkage:unit-exprs) + (#%verify-linkage-signature-match + 'compound-unit/sig + ',linkage:tags + (#%list ,@linkage:unit-vars) + ',(map sig-list->sig-vector linkage:link-exports) + ',(map (lambda (l) + (map named-sig-list->named-sig-vector l)) + linkage:link-imports)) + (#%make-unit-with-signature + (compound-unit + (import ,@prim:imports) + (link ,@(map (lambda (tag body) + `(,tag + ((#%unit-with-signature-unit + ,tag) + ,@body))) + linkage:tags prim:links)) + (export ,@prim:exports)) + ',(map named-sig-list->named-sig-vector sign:imports) + ',(sig-list->sig-vector sign:exports))))) + (expand-expr + (structurize-syntax + output + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr "Malformed compound-unit/sig")))))) + +(add-primitivized-micro-form 'compound-unit/sig full-vocabulary compound-unit/sig-micro) +(add-primitivized-micro-form 'compound-unit/sig scheme-vocabulary compound-unit/sig-micro) + + +; -------------------------------------------------------------------- + +(define iu/s-linkage-vocab + (create-vocabulary 'iu/s-linkage-vocab #f + "Invalid linkage declaration" + "Invalid linkage declaration" + "Invalid linkage declaration" + "Invalid linkage declaration")) + +(add-sym-micro iu/s-linkage-vocab + (lambda (expr env attributes vocab) + (cons expr + (signature-exploded (expand-expr expr env attributes sig-vocab))))) + +(add-list-micro iu/s-linkage-vocab + (let* ((kwd '(:)) + (in-pattern-1 '(id : sig)) + (in-pattern-2 '(id : any ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((in:id (pat:pexpand 'id p-env kwd)) + (in:sig (pat:pexpand 'sig p-env kwd))) + (valid-syntactic-id? in:id) + (cons (z:read-object in:id) + (signature-exploded + (expand-expr in:sig env attributes sig-vocab)))))) + ((pat:match-against m&e-2 expr env) + (static-error expr "Ambiguous : in signature")) + (else + (cons immediate-signature-name + (signature-exploded + (expand-expr expr env attributes sig-vocab)))))))) + +(define iu/s-imports-vocab + (create-vocabulary 'iu/s-imports-vocab #f + "Invalid import declaration" + "Invalid import declaration" + "Invalid import declaration" + "Invalid import declaration")) + +(add-sym-micro iu/s-imports-vocab + (lambda (expr env attributes vocab) + (convert-to-prim-format + (signature-elements (expand-expr expr env attributes sig-vocab))))) + +(add-list-micro iu/s-imports-vocab + (let* ((kwd '(:)) + (in-pattern-1 '(id : sig)) + (in-pattern-2 '(id : any ...)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((in:id (pat:pexpand 'id p-env kwd)) + (in:sig (pat:pexpand 'sig p-env kwd))) + (convert-to-prim-format + (signature-elements + (expand-expr in:sig env attributes sig-vocab)) + (z:read-object in:id))))) + ((pat:match-against m&e-2 expr env) + (static-error expr "Ambiguous : in signature")) + (else + (convert-to-prim-format + (signature-elements + (expand-expr expr env attributes sig-vocab)))))))) + + +(define do-invoke-unit/sig-micro + (lambda (in:expr in:linkage expr env attributes vocab) + (let* ((sigenv (sig-env env)) + (proc:linkage (map (lambda (l) + (expand-expr l sigenv attributes + iu/s-linkage-vocab)) + in:linkage)) + (proc:imports (apply append + (map (lambda (l) + (expand-expr l sigenv attributes + iu/s-imports-vocab)) + in:linkage)))) + (expand-expr + (structurize-syntax + `(let ((unit ,in:expr)) + (#%verify-linkage-signature-match + 'invoke-unit/sig + '(invoke) + (#%list unit) + '(#()) + '(,(map named-sig-list->named-sig-vector proc:linkage))) + (#%invoke-unit + (#%unit-with-signature-unit unit) + ;; Structurize proc:imports without marks to allow capture + ,@(map (lambda (x) (structurize-syntax x expr '())) + proc:imports))) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))) + +(define invoke-unit/sig-micro + (let* ((kwd '()) + (in-pattern '(_ expr linkage ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((in:expr (pat:pexpand 'expr p-env kwd)) + (in:linkage (pat:pexpand '(linkage ...) p-env kwd))) + (do-invoke-unit/sig-micro + in:expr in:linkage + expr env attributes vocab)))) + (else + (static-error expr "Malformed invoke-unit/sig")))))) + +(add-primitivized-micro-form 'invoke-unit/sig full-vocabulary invoke-unit/sig-micro) +(add-primitivized-micro-form 'invoke-unit/sig scheme-vocabulary invoke-unit/sig-micro) + +(define unit->unit/sig-micro + (let* ((kwd '()) + (in-pattern '(_ expr (in-sig ...) out-sig)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((in-expr (pat:pexpand 'expr p-env kwd)) + (in-sigs (pat:pexpand '(in-sig ...) p-env kwd)) + (out-sig (pat:pexpand 'out-sig p-env kwd)) + (sigenv (sig-env env))) + (expand-expr + (structurize-syntax + `(#%make-unit-with-signature + ,in-expr + ',(map + named-sig-list->named-sig-vector + (map (lambda (s) + (let ((proc:s + (expand-expr s sigenv attributes + sig-vocab))) + (cons (signature-name proc:s) + (signature-exploded proc:s)))) + in-sigs)) + ',(sig-list->sig-vector + (let ((proc:s + (expand-expr out-sig sigenv attributes sig-vocab))) + (signature-exploded proc:s)))) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))) + (else + (static-error expr "Malformed unit->unit/sig")))))) + +(add-primitivized-micro-form 'unit->unit/sig full-vocabulary unit->unit/sig-micro) +(add-primitivized-micro-form 'unit->unit/sig scheme-vocabulary unit->unit/sig-micro) + +(define do-define-invoke-micro + (lambda (global? in:expr in:export in:imports prefix expr env attributes vocab) + (let* ((sigenv (sig-env env)) + (proc:linkage (map (lambda (l) + (expand-expr l sigenv attributes + iu/s-linkage-vocab)) + in:imports)) + (proc:ex-linkage (expand-expr in:export sigenv attributes + u/s-sign-exports-vocab)) + (proc:imports (apply append + (map (lambda (l) + (expand-expr l sigenv attributes + iu/s-imports-vocab)) + in:imports))) + (proc:exports (expand-expr in:export sigenv attributes + iu/s-imports-vocab))) + (expand-expr + (structurize-syntax + `(,(if global? + 'global-define-values/invoke-unit + 'define-values/invoke-unit) + ,(map (lambda (x) (structurize-syntax x expr '())) + proc:exports) + (let ((unit ,in:expr)) + (#%verify-linkage-signature-match + 'invoke-unit/sig + '(invoke) + (#%list unit) + '(,(sig-list->sig-vector proc:ex-linkage)) + '(,(map named-sig-list->named-sig-vector proc:linkage))) + (#%unit/sig->unit unit)) + ,prefix + ;; Structurize proc:imports without marks to allow capture + ,@(map (lambda (x) (structurize-syntax x expr '())) + proc:imports)) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))) + +(define (make-define-values/invoke-unit/sig-micro global?) + (let* ((kwd '()) + (in-pattern '(_ export expr)) + (in-pattern2 '(_ export expr prefix linkage ...)) + (m&e (pat:make-match&env in-pattern kwd)) + (m&e2 (pat:make-match&env in-pattern2 kwd)) + (badsyntax (lambda (expr why) + (static-error expr + (format "Malformed ~adefine-values/invoke-unit/sig~a" + (if global? "global-" "") + why))))) + (lambda (expr env attributes vocab) + (let ([doit (lambda (p-env prefix?) + (let ((in:export (pat:pexpand 'export p-env kwd)) + (in:expr (pat:pexpand 'expr p-env kwd)) + (in:prefix (and prefix? (pat:pexpand 'prefix p-env kwd))) + (in:linkage (if prefix? + (pat:pexpand '(linkage ...) p-env kwd) + null))) + (unless (or (z:symbol? in:prefix) + (and (z:boolean? in:prefix) + (not (z:read-object in:prefix))) + (not in:prefix)) + (badsyntax expr " (bad prefix)")) + (do-define-invoke-micro + global? + in:expr in:export in:linkage in:prefix + expr env attributes vocab)))]) + + (cond + [(pat:match-against m&e expr env) + => (lambda (p-env) + (doit p-env #f))] + [(pat:match-against m&e2 expr env) + => (lambda (p-env) + (doit p-env #t))] + [else + (badsyntax expr "")]))))) + +(add-on-demand-form 'micro 'define-values/invoke-unit/sig common-vocabulary + (make-define-values/invoke-unit/sig-micro #f)) +(add-on-demand-form 'micro 'global-define-values/invoke-unit/sig common-vocabulary + (make-define-values/invoke-unit/sig-micro #t)) diff --git a/collects/zodiac/scm-main.ss b/collects/zodiac/scm-main.ss new file mode 100644 index 00000000..a9ac7202 --- /dev/null +++ b/collects/zodiac/scm-main.ss @@ -0,0 +1,2252 @@ +; $Id: scm-main.ss,v 1.204 2000/03/05 21:15:52 clements Exp $ + +(unit/sig zodiac:scheme-main^ + (import zodiac:misc^ zodiac:structures^ + (z : zodiac:scanner-parameters^) + (z : zodiac:reader-structs^) + (z : zodiac:reader-code^) + zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ + zodiac:back-protocol^ zodiac:expander^ zodiac:interface^) + + ; ---------------------------------------------------------------------- + + (define-struct (if-form struct:form) (test then else)) + (define-struct (set!-form struct:form) (var val)) + (define-struct (define-values-form struct:form) (vars val)) + (define-struct (let-values-form struct:form) (vars vals body)) + (define-struct (letrec-values-form struct:form) (vars vals body)) + (define-struct (quote-form struct:form) (expr)) + (define-struct (begin-form struct:form) (bodies)) + (define-struct (begin0-form struct:form) (bodies)) + (define-struct (case-lambda-form struct:form) (args bodies)) + (define-struct (struct-form struct:form) (type super fields)) + (define-struct (with-continuation-mark-form struct:form) (key val body)) + + ; ---------------------------------------------------------------------- + + (define create-const + (lambda (c s) + (make-quote-form (zodiac-origin s) + (zodiac-start s) (zodiac-finish s) + (make-empty-back-box) c))) + + (define expands<%> (interface () expand)) + + (add-lit-micro + common-vocabulary + (lambda (expr env attributes vocab) + (if (z:external? expr) + (let ([obj (z:read-object expr)]) + (if (is-a? obj expands<%>) + (expand-expr (send obj expand expr) env attributes vocab) + (create-const expr expr))) + (create-const expr expr)))) + + ; ---------------------------------------------------------------------- + + (define create-case-lambda-form + (lambda (args bodies source) + (make-case-lambda-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) args bodies))) + + (define create-if-form + (lambda (test then else source) + (make-if-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) test then else))) + + (define create-begin-form + (lambda (bodies source) + (make-begin-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) bodies))) + + (define create-begin0-form + (lambda (bodies source) + (make-begin0-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) bodies))) + + (define create-quote-form + (lambda (expr source) + (make-quote-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) expr))) + + (define create-set!-form + (lambda (var val source) + (make-set!-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) var val))) + + (define create-define-values-form + (lambda (vars val source) + (make-define-values-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) vars val))) + + (define create-let-values-form + (lambda (vars vals body source) + (make-let-values-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) vars vals body))) + + (define create-letrec-values-form + (lambda (vars vals body source) + (make-letrec-values-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) vars vals body))) + + (define create-struct-form + (lambda (type super fields source) + (make-struct-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) type super fields))) + + (define create-with-continuation-mark-form + (lambda (key val body source) + (make-with-continuation-mark-form (zodiac-origin source) + (zodiac-start source) (zodiac-finish source) + (make-empty-back-box) key val body))) + + ; ---------------------------------------------------------------------- + + (extend-parsed->raw if-form? + (lambda (expr p->r) + `(if ,(p->r (if-form-test expr)) + ,(p->r (if-form-then expr)) + ,(p->r (if-form-else expr))))) + + (extend-parsed->raw set!-form? + (lambda (expr p->r) + `(set! ,(p->r (set!-form-var expr)) + ,(p->r (set!-form-val expr))))) + + (extend-parsed->raw define-values-form? + (lambda (expr p->r) + `(define-values ,(map p->r (define-values-form-vars expr)) + ,(p->r (define-values-form-val expr))))) + + (extend-parsed->raw let-values-form? + (lambda (expr p->r) + `(let-values + ,(map (lambda (vars val) + (list (map p->r vars) (p->r val))) + (let-values-form-vars expr) (let-values-form-vals expr)) + ,(p->r (let-values-form-body expr))))) + + (extend-parsed->raw letrec-values-form? + (lambda (expr p->r) + `(letrec-values + ,(map (lambda (vars val) + (list (map p->r vars) (p->r val))) + (letrec-values-form-vars expr) (letrec-values-form-vals expr)) + ,(p->r (letrec-values-form-body expr))))) + + (extend-parsed->raw quote-form? + (lambda (expr p->r) + `(quote ,(sexp->raw (quote-form-expr expr))))) + + (extend-parsed->raw begin-form? + (lambda (expr p->r) + `(begin ,@(map p->r (begin-form-bodies expr))))) + + (extend-parsed->raw begin0-form? + (lambda (expr p->r) + `(begin0 ,@(map p->r (begin0-form-bodies expr))))) + + (extend-parsed->raw case-lambda-form? + (lambda (expr p->r) + `(case-lambda + ,@(map (lambda (arg body) + `(,(p->r arg) ,(p->r body))) + (case-lambda-form-args expr) + (case-lambda-form-bodies expr))))) + + (extend-parsed->raw struct-form? + (lambda (expr p->r) + `(struct + ,(if (struct-form-super expr) + (list (sexp->raw (struct-form-type expr)) + (p->r (struct-form-super expr))) + (sexp->raw (struct-form-type expr))) + ,(map sexp->raw (struct-form-fields expr))))) + + (extend-parsed->raw with-continuation-mark-form? + (lambda (expr p->r) + `(with-continuation-mark + ,(p->r (with-continuation-mark-form-key expr)) + ,(p->r (with-continuation-mark-form-val expr)) + ,(p->r (with-continuation-mark-form-body expr))))) + + ; ---------------------------------------------------------------------- + + (define (get-expr-pattern begin?) + (if begin? + (if (eq? begin? 'optional) + '(expr ...) + '(expr0 expr ...)) + '(expr))) + + (define parse-expr + (lambda (who expr bodies env attributes vocab source) + ;; Do internal definition parsing + (let*-values + (((internal-define-vocab) + (append-vocabulary internal-define-vocab-delta + vocab 'internal-define-vocab)) + ((definitions parsed-first-term rest-terms bindings) + (let loop ((seen null) (rest bodies) (prev #f) (bindings null) (vars-seen null)) + (if (null? rest) + (static-error prev + (if (null? seen) + (static-error expr (format "Malformed ~a" who)) + (if (null? (cdr seen)) + "Internal definition not followed by expression" + "Internal definitions not followed by expression"))) + (let ((first (car rest))) + (let* ((internal? (get-internal-define-status attributes)) + (_ (set-internal-define-status attributes #t)) + (e-first (expand-expr first env + attributes + internal-define-vocab)) + (_ (set-internal-define-status attributes internal?))) + (cond + [(internal-definition? e-first) + (let ((def-vars (internal-definition-vars e-first))) + (let* ((new-vars+marks + (map create-lexical-binding+marks + def-vars))) + (for-each + (lambda (v) + (when (memq (z:read-object v) + vars-seen) + (static-error v + "Duplicate internally defined identifier ~a" + (z:read-object v)))) + def-vars) + (extend-env new-vars+marks env) + (loop (cons e-first seen) + (cdr rest) + first + (cons new-vars+marks bindings) + (append vars-seen + (map z:read-object def-vars)))))] + [(internal-begin? e-first) + (loop seen + (append (internal-begin-exprs e-first) (cdr rest)) + first + bindings vars-seen)] + [else + (values (reverse seen) + e-first + (cdr rest) + bindings)]))))))) + (if (null? definitions) + + ;; No internal defines + (if (null? rest-terms) + parsed-first-term + (create-begin-form + (cons parsed-first-term + (map (lambda (e) + (expand-expr e env attributes + vocab)) + rest-terms)) + expr)) + + ;; Found internal defines + (begin0 + (create-letrec-values-form + (reverse (map (lambda (vars+marks) + (map car vars+marks)) + bindings)) + (map (lambda (def) + (expand-expr (internal-definition-val def) + env attributes vocab)) + definitions) + (if (null? rest-terms) + parsed-first-term + (create-begin-form + (cons parsed-first-term + (map (lambda (e) + (expand-expr e env attributes vocab)) + rest-terms)) + expr)) + expr) + (for-each (lambda (new-vars+marks) + (retract-env (map car new-vars+marks) env)) + bindings)))))) + + ; ---------------------------------------------------------------------- + + (define (make-lambda-error-micro who) + (lambda (expr env attributes vocab) + (static-error expr (format "~a allowed only in a definition" who)))) + + (define (make-case-lambda-micro begin? arglist-decls-vocab) + (let* ((kwd `(else)) + (in-pattern `(_ + (args ,@(get-expr-pattern begin?)) + ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((args (pat:pexpand '(args ...) p-env kwd)) + (bodies (pat:pexpand `((,@(get-expr-pattern begin?)) ...) + p-env kwd))) + (let ((arglists+exprs + (map + (lambda (arg body) + (distinct-valid-syntactic-id/s? arg) + (let* ((arglist + (expand-expr arg env attributes + arglist-decls-vocab)) + (arg-vars+marks + (arglist-vars arglist))) + (extend-env arg-vars+marks env) + (begin0 + (cons + (make-argument-list arglist) + (as-nested + attributes + (lambda () + (parse-expr "case-lambda" expr body env attributes vocab expr)))) + (retract-env (map car arg-vars+marks) env)))) + args bodies))) + (create-case-lambda-form + (map car arglists+exprs) + (map cdr arglists+exprs) + expr))))) + (else + (static-error expr "Malformed case-lambda")))))) + + (define beginner+lambda-vocabulary + (create-vocabulary 'beginner+lambda-vocabulary + beginner-vocabulary)) + (set-subexpr-vocab! beginner+lambda-vocabulary beginner-vocabulary) + + (add-primitivized-micro-form + 'case-lambda + beginner+lambda-vocabulary + (make-case-lambda-micro #f lambda-nonempty-arglist-decls-vocab)) + (add-primitivized-micro-form + 'case-lambda + beginner-vocabulary + (make-lambda-error-micro 'case-lambda)) + (add-primitivized-micro-form + 'case-lambda + intermediate-vocabulary + (make-case-lambda-micro #f lambda-nonempty-arglist-decls-vocab)) + (add-primitivized-micro-form + 'case-lambda + advanced-vocabulary + (make-case-lambda-micro #f lambda-full-arglist-decls-vocab)) + (add-primitivized-micro-form + 'case-lambda + scheme-vocabulary + (make-case-lambda-micro #t lambda-full-arglist-decls-vocab)) + + (define (make-lambda-macro begin?) + (let* ((kwd '()) + (in-pattern `(_ args ,@(get-expr-pattern begin?))) + (out-pattern `(case-lambda + (args ,@(get-expr-pattern begin?)))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed lambda"))))) + + (add-primitivized-macro-form + 'lambda + beginner+lambda-vocabulary + (make-lambda-macro #f)) + (add-primitivized-micro-form + 'lambda + beginner-vocabulary + (make-lambda-error-micro 'lambda)) + (add-primitivized-macro-form + 'lambda + intermediate-vocabulary + (make-lambda-macro #f)) + (add-primitivized-macro-form + 'lambda + advanced-vocabulary + (make-lambda-macro #f)) + (add-primitivized-macro-form + 'lambda + scheme-vocabulary + (make-lambda-macro #t)) + + (define-struct internal-definition (vars val)) + (define-struct internal-begin (exprs)) + + (define internal-define-vocab-delta + (create-vocabulary 'internal-define-vocab-delta)) + + (add-primitivized-micro-form 'define-values internal-define-vocab-delta + (let* ((kwd '()) + (in-pattern `(_ (var ...) val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (unless (at-internal-define? attributes) + (static-error expr "Invalid position for internal definition")) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ((vars (pat:pexpand '(var ...) p-env kwd)) + (_ (map valid-syntactic-id? vars)) + (val (pat:pexpand 'val p-env kwd))) + (for-each (lambda (var) + (let ((r (resolve var env vocab))) + (when (or (micro-resolution? r) + (macro-resolution? r)) + (static-error var + "Cannot bind keyword ~s" + (z:symbol-orig-name var))))) + vars) + (make-internal-definition vars val)))) + (else + (static-error expr + "Malformed internal definition")))))) + + (add-primitivized-micro-form 'begin internal-define-vocab-delta + (let* ((kwd '()) + (in-pattern `(_ expr ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (if (at-internal-define? attributes) + + ;; Parse begin in internal define context + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ((exprs (pat:pexpand '(expr ...) p-env kwd))) + (make-internal-begin exprs)))) + (else + (static-error expr + "Malformed internal begin"))) + + ;; Chain to regular begin: + (begin-micro expr env attributes vocab))))) + + (define begin-micro + (let* ((kwd '()) + (in-pattern `(_ b ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ([bodies (pat:pexpand '(b ...) p-env kwd)] + [top? (get-top-level-status attributes)] + [as-nested (if top? (lambda (x y) (y)) as-nested)]) + (if (and (pair? bodies) (null? (cdr bodies))) + (as-nested + attributes + (lambda () + (expand-expr (car bodies) env attributes vocab))) + (if (and (not top?) + (null? bodies)) + (static-error expr "Malformed begin") + (as-nested + attributes + (lambda () + (create-begin-form + (map (lambda (e) + (expand-expr e env attributes vocab)) + bodies) + expr)))))))) + (else + (static-error expr "Malformed begin")))))) + + (add-primitivized-micro-form 'begin advanced-vocabulary begin-micro) + (add-primitivized-micro-form 'begin scheme-vocabulary begin-micro) + + (define begin0-micro + (let* ((kwd '()) + (in-pattern `(_ b0 b ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((bodies (pat:pexpand '(b ...) p-env kwd)) + (body0 (pat:pexpand 'b0 p-env kwd))) + (let ([first (as-nested + attributes + (lambda () (expand-expr body0 env attributes vocab)))]) + (if (null? bodies) + first + (let ([rest (as-nested + attributes + (lambda () + (map + (lambda (expr) + (expand-expr expr env attributes vocab)) + bodies)))]) + (create-begin0-form + (cons first rest) + expr))))))) + (else + (static-error expr "Malformed begin0")))))) + + (add-primitivized-micro-form 'begin0 advanced-vocabulary begin0-micro) + (add-primitivized-micro-form 'begin0 scheme-vocabulary begin0-micro) + + (define (make-if-micro one-arm-ok?) + (let* ((kwd '()) + (in-pattern-1 `(_ test then)) + (in-pattern-2 `(_ test then else)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (unless one-arm-ok? + (static-error expr "If must have an else clause")) + (as-nested + attributes + (lambda () + (set-macro-origin + (expand-expr + (structurize-syntax + (pat:pexpand '(if test then (#%void)) p-env kwd) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab) + (syntax-car expr)))))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (as-nested + attributes + (lambda () + (let* ((test-exp (expand-expr + (pat:pexpand 'test p-env kwd) + env attributes vocab)) + (then-exp (expand-expr + (pat:pexpand 'then p-env kwd) + env attributes vocab)) + (else-exp (expand-expr + (pat:pexpand 'else p-env kwd) + env attributes vocab))) + (create-if-form test-exp then-exp else-exp expr)))))) + (else + (static-error expr "Malformed if")))))) + + (add-primitivized-micro-form 'if beginner-vocabulary (make-if-micro #f)) + (add-primitivized-micro-form 'if advanced-vocabulary (make-if-micro #t)) + (add-primitivized-micro-form 'if scheme-vocabulary (make-if-micro #t)) + + (define with-continuation-mark-micro + (let* ((kwd '()) + (in-pattern `(_ key val body)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (as-nested + attributes + (lambda () + (let* ((key-exp (expand-expr + (pat:pexpand 'key p-env kwd) + env attributes vocab)) + (val-exp (expand-expr + (pat:pexpand 'val p-env kwd) + env attributes vocab)) + (body-exp (expand-expr + (pat:pexpand 'body p-env kwd) + env attributes vocab))) + (create-with-continuation-mark-form key-exp val-exp body-exp expr)))))) + (else + (static-error expr "Malformed with-continuation-mark")))))) + + (add-primitivized-micro-form 'with-continuation-mark scheme-vocabulary with-continuation-mark-micro) + + ; Don't "simplify" this. If replaced with a pattern match, it will + ; die when passed a quote form whose underlying object is an actual + ; Scheme value (as opposed to a struct:read), because the matcher + ; will attempt to extract the source locations of the underlying + ; object, which will fail in this case. + + (define (make-quote-micro non-sym-ok?) + (lambda (expr env attributes vocab) + (if (and (z:list? expr) + (= 2 (z:sequence-length expr))) + (let ((contents (expose-list expr))) + (if (and (z:symbol? (car contents)) + (or (eq? 'quote (z:read-object (car contents))) + (eq? '#%quote (z:read-object (car contents))))) + (if (or non-sym-ok? + (z:symbol? (cadr contents))) + (create-quote-form (cadr contents) expr) + (let*-values ([(v) (sexp->raw (cadr contents))] + [(v prefix) + ;; Strip leading quotes, because user most likely typed ''x + ;; instead of '(quote x) + (let loop ([v v][prefix ""]) + (cond + [(and (pair? v) + (eq? (car v) 'quote) + (pair? (cdr v)) + (null? (cddr v))) + (loop (cadr v) (string-append "'" prefix))] + [else (values v prefix)]))]) + (static-error expr "Misuse of quote: '~a~s is not a symbol" prefix v))) + (static-error expr "Malformed quote"))) + (static-error expr "Malformed quote")))) + + (add-primitivized-micro-form 'quote beginner-vocabulary (make-quote-micro #f)) + (add-primitivized-micro-form 'quote intermediate-vocabulary (make-quote-micro #t)) + (add-primitivized-micro-form 'quote scheme-vocabulary (make-quote-micro #t)) + + ;; This second variable is no longer being used + (define (make-set!-micro dont-mutate-lexical-varrefs?) + (let* ((kwd '()) + (in-pattern `(_ var val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((p-env (pat:match-against m&e expr env))) + (if p-env + (let* ((var-p (pat:pexpand 'var p-env kwd)) + (_ (valid-syntactic-id? var-p)) + (id-expr (expand-expr var-p env attributes + vocab)) + (expr-expr (as-nested + attributes + (lambda () + (expand-expr + (pat:pexpand 'val p-env kwd) + env attributes vocab))))) + (create-set!-form id-expr expr-expr expr)) + (static-error expr "Malformed set!")))))) + + (add-primitivized-micro-form 'set! + advanced-vocabulary + (make-set!-micro #t)) + (add-primitivized-micro-form 'set! + scheme-vocabulary + (make-set!-micro #f)) + + (define set!-values-micro + (let* ((kwd '()) + (in-pattern '(_ (vars ...) val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ((vars (pat:pexpand '(vars ...) p-env kwd)) + (val (pat:pexpand 'val p-env kwd))) + (map valid-syntactic-id? vars) + (let ((new-names (map generate-name vars))) + (expand-expr + (structurize-syntax + `(let-values ((,new-names ,val)) + ,@(map (lambda (var new-name) + `(set! ,var ,new-name)) + vars new-names) + (#%void)) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab))))) + (else + (static-error expr "Malformed set!-values")))))) + + (add-primitivized-micro-form 'set!-values advanced-vocabulary set!-values-micro) + (add-primitivized-micro-form 'set!-values scheme-vocabulary set!-values-micro) + + (define (make-local-extract-vocab) + (create-vocabulary 'local-extract-vocab #f + "Invalid expression for local clause" + "Invalid expression for local clause" + "Invalid expression for local clause" + "Invalid expression for local clause")) + + (define nobegin-local-extract-vocab (make-local-extract-vocab)) + (define full-local-extract-vocab (make-local-extract-vocab)) + + (define (make-local-micro begin? local-extract-vocab) + (let* ((kwd '()) + (in-pattern `(_ (defs ...) ,@(get-expr-pattern begin?))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((p-env (pat:match-against m&e expr env))) + (if p-env + (let ((top-level? (get-top-level-status attributes)) + (internal? (get-internal-define-status attributes))) + (set-top-level-status attributes #t) + (set-internal-define-status attributes #f) + (let* + ((defs (pat:pexpand '(defs ...) p-env kwd)) + (vars+exprs + (map + (lambda (e) + (let ((out + (expand-expr e env + attributes + local-extract-vocab))) + out)) + defs))) + (set-top-level-status attributes) + (begin0 + (set-macro-origin + (expand-expr + (structurize-syntax + `(letrec-values + ,(map (lambda (vars+expr) + `(,(car vars+expr) ,(cdr vars+expr))) + vars+exprs) + ,@(pat:pexpand (get-expr-pattern begin?) p-env kwd)) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab) + (syntax-car expr)) + (set-top-level-status attributes top-level?) + (set-internal-define-status attributes internal?)))) + (static-error expr "Malformed local")))))) + + (add-primitivized-micro-form + 'local + intermediate-vocabulary + (make-local-micro #f nobegin-local-extract-vocab)) + (add-on-demand-form + 'micro + 'local + intermediate-vocabulary + (make-local-micro #f nobegin-local-extract-vocab)) + +; (add-primitivized-micro-form +; 'local +; advanced-vocabulary +; (make-local-micro #t full-local-extract-vocab)) +; (add-on-demand-form +; 'micro +; 'local +; advanced-vocabulary +; (make-local-micro #t full-local-extract-vocab)) + + (add-on-demand-form + 'micro + 'local + scheme-vocabulary + (make-local-micro #t full-local-extract-vocab)) + + (define (make-define-forms begin?) + (let* ((kwd '()) + (in-pattern-1 `(_ (fun . args) ,@(get-expr-pattern begin?))) + (out-pattern-1 `(define-values (fun) (lambda args ,@(get-expr-pattern begin?)))) + (in-pattern-2 `(_ var val)) + (out-pattern-2 `(define-values (var) val)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (values + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (static-error expr "Malformed define"))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((fun (pat:pexpand 'fun p-env kwd)) + (expr (pat:pexpand `(lambda args ,@(get-expr-pattern begin?)) + p-env kwd))) + (valid-syntactic-id? fun) + (cons (list fun) expr)))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (val (pat:pexpand 'val p-env kwd))) + (valid-syntactic-id? var) + (cons (list var) val)))) + (else + (static-error expr "Malformed define in local clause"))))))) + + (define-values + (nobegin-define-form nobegin-local-define-form) (make-define-forms #f)) + (define-values + (full-define-form full-local-define-form) (make-define-forms #t)) + + (add-primitivized-macro-form 'define beginner-vocabulary nobegin-define-form) +; (add-primitivized-macro-form 'define advanced-vocabulary full-define-form) + (add-primitivized-macro-form 'define scheme-vocabulary full-define-form) + + (add-primitivized-micro-form 'define + full-local-extract-vocab + full-local-define-form) + (add-primitivized-micro-form 'define + nobegin-local-extract-vocab + nobegin-local-define-form) + + (let* ((kwd '()) + (in-pattern-1 `(_ (var ...) val)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd))) + (let ((define-values-helper + (lambda (internal-ok? handler) + (lambda (expr env attributes vocab) + (unless (at-top-level? attributes) + (static-error expr + (if internal-ok? + "Invalid position for internal definition" + "Invalid definition: must be at the top level"))) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let* ((vars (pat:pexpand '(var ...) + p-env kwd)) + (_ (map valid-syntactic-id? vars)) + (val (pat:pexpand 'val p-env kwd)) + (out (as-nested + attributes + (lambda () + (handler expr env + attributes vocab vars val))))) + out))) + (else (static-error expr + "Malformed define-values"))))))) + (let ([make-dv-micro + (lambda (internal-ok? use-beg-lambda-vocab?) + (define-values-helper + internal-ok? + (lambda (expr env attributes vocab vars val) + (let* ((id-exprs (map (lambda (v) + (expand-expr v env + attributes vocab)) + vars)) + (expr-expr (as-nested + attributes + (lambda () + (expand-expr val env + attributes + (if use-beg-lambda-vocab? + beginner+lambda-vocabulary + vocab)))))) + (create-define-values-form id-exprs + expr-expr expr)))))]) + (add-primitivized-micro-form 'define-values + beginner-vocabulary + (make-dv-micro #f #t)) + (add-primitivized-micro-form 'define-values + intermediate-vocabulary + (make-dv-micro #f #f)) + (add-primitivized-micro-form 'define-values + advanced-vocabulary + (make-dv-micro #f #f)) + (add-primitivized-micro-form 'define-values + scheme-vocabulary + (make-dv-micro #t #f))) + (let ([int-dv-micro (define-values-helper + #t + (lambda (expr env attributes vocab vars val) + (cons vars val)))]) + (add-primitivized-micro-form 'define-values nobegin-local-extract-vocab int-dv-micro) + (add-primitivized-micro-form 'define-values full-local-extract-vocab int-dv-micro)))) + + (define extract-type&super + (let* ((kwd '()) + (ts-pattern '(type super)) + (m&e-ts (pat:make-match&env ts-pattern kwd))) + (lambda (type-spec env allow-supertype?) + (if allow-supertype? + (cond + ((pat:match-against m&e-ts type-spec env) + => + (lambda (tsp-env) + (let* ((type (pat:pexpand 'type tsp-env '())) + (super (pat:pexpand 'super tsp-env '()))) + (and (or (z:symbol? type) + (static-error type "Not an identifier")) + (values type super))))) + ((z:symbol? type-spec) + (values type-spec #f)) + (else + (static-error type-spec "Invalid specification"))) + (begin + (unless (z:symbol? type-spec) + (static-error type-spec "Not an identifier")) + (values type-spec #f)))))) + + (define (make-struct-micro allow-supertype?) + (let* ((kwd '()) + (in-pattern `(_ type-spec (fields ...))) + (m&e-in (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-in expr env) + => + (lambda (p-env) + (let* ((fields (pat:pexpand '(fields ...) p-env kwd)) + (type-spec (pat:pexpand 'type-spec p-env kwd))) + (distinct-valid-syntactic-id/s? fields) + (let-values (((type super) + (extract-type&super type-spec env allow-supertype?))) + (create-struct-form + type + (and super (as-nested attributes (lambda () (expand-expr super env attributes vocab)))) + fields + expr))))) + (else + (static-error expr "Malformed struct")))))) + + (add-primitivized-micro-form 'struct beginner-vocabulary (make-struct-micro #f)) + (add-primitivized-micro-form 'struct advanced-vocabulary (make-struct-micro #t)) + (add-primitivized-micro-form 'struct scheme-vocabulary (make-struct-micro #t)) + + (define generate-struct-names + (opt-lambda (type fields source + (omit-selectors? #f) (omit-setters? #f)) + (let ((name (lambda parts + (structurize-syntax + (apply symbol-append parts) + source)))) + (let ((type (z:read-object type)) + (fields (map z:read-object fields))) + (cons + (name "struct:" type) + (cons + (name "make-" type) + (cons + (name type "?") + (apply append + (map (lambda (field) + (append + (if omit-selectors? + '() + (list (name type "-" field))) + (if omit-setters? + '() + (list (name "set-" type "-" field "!"))))) + fields))))))))) + + (let* ((kwd '()) + (in-pattern '(_ type-spec (fields ...))) + (m&e-in (pat:make-match&env in-pattern kwd))) + (let ((make-ds-micro + (lambda (handler allow-supertype?) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-in expr env) + => + (lambda (p-env) + (let ((fields (pat:pexpand '(fields ...) p-env kwd)) + (type-spec (pat:pexpand 'type-spec p-env kwd))) + (distinct-valid-syntactic-id/s? fields) + (let*-values + (((type super) (extract-type&super type-spec env allow-supertype?)) + ((names) (generate-struct-names type fields expr)) + ((struct-expr) + `(struct ,type-spec ,fields))) + (handler expr env attributes vocab + names struct-expr))))) + (else + (static-error expr "Malformed define-struct"))))))) + (let ([top-level-handler + (lambda (expr env attributes vocab names struct-expr) + (expand-expr + (structurize-syntax + `(define-values ,names ,struct-expr) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab))] + [internal-handler + (lambda (expr env attributes vocab names struct-expr) + (cons names struct-expr))]) + + (add-primitivized-micro-form 'define-struct beginner-vocabulary + (make-ds-micro top-level-handler #f)) + (add-primitivized-micro-form 'define-struct advanced-vocabulary + (make-ds-micro top-level-handler #t)) + (add-primitivized-micro-form 'define-struct scheme-vocabulary + (make-ds-micro top-level-handler #t)) + + (add-primitivized-micro-form 'define-struct nobegin-local-extract-vocab + (make-ds-micro internal-handler #f)) + (add-primitivized-micro-form 'define-struct full-local-extract-vocab + (make-ds-micro internal-handler #t))))) + + (let* ((kwd '()) + (in-pattern '(_ (type-spec fields ...))) + (out-pattern '(define-struct type-spec (fields ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (add-primitivized-macro-form 'define-structure intermediate-vocabulary + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed define-structure")))) + (let ([int-ds-macro (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed define-structure")))]) + (add-primitivized-macro-form 'define-structure nobegin-local-extract-vocab int-ds-macro) + (add-primitivized-macro-form 'define-structure full-local-extract-vocab int-ds-macro))) + + (define (make-let-struct-micro begin? allow-supertype?) + (let* ((kwd '()) + (in-pattern `(_ type-spec (fields ...) ,@(get-expr-pattern begin?))) + (m&e-in (pat:make-match&env in-pattern kwd))) + (let ((ls-core + (lambda (handler) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-in expr env) + => + (lambda (p-env) + (handler expr env attributes vocab p-env))) + (else + (static-error expr "Malformed let-struct"))))))) + (ls-core + (lambda (expr env attributes vocab p-env) + (let* ((fields (pat:pexpand '(fields ...) p-env kwd)) + (type-spec (pat:pexpand 'type-spec p-env kwd)) + (body (pat:pexpand `(,@(get-expr-pattern begin?)) p-env kwd))) + (distinct-valid-syntactic-id/s? fields) + (let-values (((type super) + (extract-type&super type-spec env allow-supertype?))) + (expand-expr + (structurize-syntax + `(let-values + ((,(generate-struct-names type fields expr) + (struct ,type-spec ,fields))) + ,@body) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab)))))))) + + (add-primitivized-micro-form 'let-struct + intermediate-vocabulary + (make-let-struct-micro #f #f)) +; (add-primitivized-micro-form 'let-struct +; advanced-vocabulary +; (make-let-struct-micro #t #t)) + (add-primitivized-micro-form 'let-struct + scheme-vocabulary + (make-let-struct-micro #t #t)) + + ; ---------------------------------------------------------------------- + + ; Sometimes a single source symbol appears twice in an expansion. + ; When that happens, we mark all but the first occurrence as a + ; "duplicate" so that syntax-processing tools can correlate + ; identifiers in elaboated syntax to source syntax. + + (define (dup-symbol s) + (z:make-symbol + (make-origin 'duplicated (zodiac-origin s)) + (zodiac-start s) + (zodiac-finish s) + (z:read-object s) + (z:symbol-orig-name s) + (z:symbol-marks s))) + + (define (make-let-macro begin? named?) + ;; >> Broken by current embedded define hacks! << + ;; e.g., (let ([a 7]) (let-macro a void (a)) + (let* ((kwd '()) + + (in-pattern-1 `(_ fun ((v e) ...) ,@(get-expr-pattern begin?))) + (out-pattern-1 `((letrec ((fun (lambda (v ...) ,@(get-expr-pattern begin?)))) + fun-copy) ; fun-copy is fun with a different source + e ...)) + + (in-pattern-2 `(_ ((v e) ...) ,@(get-expr-pattern begin?))) + (out-pattern-2 `(let-values (((v) e) ...) ,@(get-expr-pattern begin?))) + + (m&e-1 (and named? (pat:make-match&env in-pattern-1 kwd))) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env) + (let ((p-env (and named? (pat:match-against m&e-1 expr env)))) + (if (and p-env (z:symbol? (pat:pexpand 'fun p-env kwd))) + (let* ([fun (pat:pexpand 'fun p-env kwd)] + [fun-copy (dup-symbol fun)]) + (pat:pexpand out-pattern-1 + (pat:extend-penv 'fun-copy fun-copy p-env) + kwd)) + (or (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (static-error expr "Malformed let"))))))) + + (add-primitivized-macro-form 'let + intermediate-vocabulary + (make-let-macro #f #f)) +; (add-primitivized-macro-form 'let +; advanced-vocabulary +; (make-let-macro #t #t)) + (add-primitivized-macro-form 'let scheme-vocabulary (make-let-macro #t #t)) + + ; Turtle Macros for Robby + (let ([add-patterned-macro + (lambda (formname in-pattern out-pattern) + (add-macro-form + formname + intermediate-vocabulary + (let* ((kwd (list formname)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr + (format "Malformed ~a" formname)))))))]) + (add-patterned-macro 'tprompt + '(tprompt E ...) + '(tpromptfn (lambda () E ...))) + (add-patterned-macro 'split + '(split E ...) + '(splitfn (lambda () E ...))) + (add-patterned-macro 'split* + '(split* E ...) + '(split*fn (list (lambda () E) ...)))) + + (define (make-let*-macro begin?) + (let* ((kwd '()) + (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) + (out-pattern-1 `(let-values () ,@(get-expr-pattern begin?))) + (in-pattern-2 `(_ ((v0 e0) (v1 e1) ...) ,@(get-expr-pattern begin?))) + (out-pattern-2 `(let ((v0 e0)) (let* ((v1 e1) ...) ,@(get-expr-pattern begin?)))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (static-error expr "Malformed let*"))))) + + (add-primitivized-macro-form 'let* + intermediate-vocabulary + (make-let*-macro #f)) +; (add-primitivized-macro-form 'let* +; advanced-vocabulary +; (make-let*-macro #t)) + (add-primitivized-macro-form 'let* + scheme-vocabulary + (make-let*-macro #t)) + + (define delay-macro + (let* ((kwd '()) + (in-pattern '(_ expr)) + (out-pattern '(#%make-promise (lambda () expr))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed delay"))))) + + (add-primitivized-macro-form 'delay advanced-vocabulary delay-macro) + (add-primitivized-macro-form 'delay scheme-vocabulary delay-macro) + + (define time-macro + (let* ((kwd '()) + (in-pattern '(_ e0 e1 ...)) + (out-pattern '(let-values (((v cpu user gc) + (#%time-apply (lambda (dont-care) + e0 + e1 ...) + (#%cons (#%quote dont-care) #%null)))) + (#%begin + (#%printf + "cpu time: ~s real time: ~s gc time: ~s~n" + cpu user gc) + (#%apply #%values v)))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed time"))))) + + (add-primitivized-macro-form 'time intermediate-vocabulary time-macro) + (add-primitivized-macro-form 'time scheme-vocabulary time-macro) + + (define break-list + (lambda (elements counter) + (let loop ((rev-head '()) (tail elements) (counter counter)) + (if (null? counter) + (values (reverse rev-head) tail) + (loop (cons (car tail) rev-head) (cdr tail) (cdr counter)))))) + + (define (make-let-values-micro begin?) + (let* ((kwd '()) + (in-pattern `(_ (((v ...) e) ...) ,@(get-expr-pattern begin?))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((vars (pat:pexpand '((v ...) ...) p-env kwd)) + (vals (pat:pexpand '(e ...) p-env kwd)) + (body (pat:pexpand `(,@(get-expr-pattern begin?)) + p-env kwd))) + (as-nested + attributes + (lambda () + (let* ((all-vars (apply append vars)) + (_ (distinct-valid-syntactic-id/s? all-vars)) + (expanded-vals + (map (lambda (e) + (expand-expr e env attributes vocab)) + vals)) + (new-vars+marks + (map create-lexical-binding+marks all-vars)) + (new-vars + (map car new-vars+marks)) + (_ + (extend-env new-vars+marks env))) + (begin0 + (create-let-values-form + (let loop ((var-lists vars) + (new-vars new-vars)) + (if (null? var-lists) + '() + (let-values (((head tail) + (break-list new-vars + (car var-lists)))) + (cons head + (loop (cdr var-lists) tail))))) + expanded-vals + (parse-expr "let-values" expr body env + attributes vocab expr) + expr) + (retract-env new-vars env)))))))) + (else + (static-error expr "Malformed let-values")))))) + + (add-primitivized-micro-form 'let-values + intermediate-vocabulary + (make-let-values-micro #f)) +; (add-primitivized-micro-form 'let-values +; advanced-vocabulary +; (make-let-values-micro #t)) + (add-primitivized-micro-form 'let-values + scheme-vocabulary + (make-let-values-micro #t)) + + (define (make-let*-values-micro begin?) + (let* ((kwd '()) + (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) + (out-pattern-1 `(let-values () ,@(get-expr-pattern begin?))) + (in-pattern-2 `(_ ((v0 e0) (v1 e1) ...) + ,@(get-expr-pattern begin?))) + (out-pattern-2 `(let-values ((v0 e0)) + (let*-values ((v1 e1) ...) + ,@(get-expr-pattern begin?)))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (static-error expr "Malformed let*-values"))))) + + (add-primitivized-macro-form 'let*-values + intermediate-vocabulary + (make-let*-values-micro #f)) +; (add-primitivized-macro-form 'let*-values +; advanced-vocabulary +; (make-let*-values-micro #t)) + (add-primitivized-macro-form 'let*-values + scheme-vocabulary + (make-let*-values-micro #t)) + + (define (make-letrec-values-micro begin?) + (let* ((kwd '()) + (in-pattern `(_ (((v ...) e) ...) ,@(get-expr-pattern begin?))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((vars (pat:pexpand '((v ...) ...) p-env kwd)) + (vals (pat:pexpand '(e ...) p-env kwd)) + (body (pat:pexpand `(,@(get-expr-pattern begin?)) + p-env kwd))) + (let* + ((all-vars (apply append vars)) + (_ (distinct-valid-syntactic-id/s? all-vars)) + (new-vars+marks + (map create-lexical-binding+marks all-vars)) + (new-vars + (map car new-vars+marks)) + (_ + (extend-env new-vars+marks env)) + (expanded-vals + (as-nested + attributes + (lambda () + (map (lambda (e) + (expand-expr e env attributes vocab)) + vals)))) + (result + (create-letrec-values-form + (let loop ((var-lists vars) + (new-vars new-vars)) + (if (null? var-lists) + '() + (let-values (((head tail) + (break-list new-vars + (car var-lists)))) + (cons head + (loop (cdr var-lists) tail))))) + expanded-vals + (as-nested + attributes + (lambda () + (parse-expr "letrec-values" expr body env attributes vocab expr))) + expr)) + (_ (retract-env new-vars env))) + result)))) + (else + (static-error expr "Malformed letrec-values")))))) + + (add-primitivized-micro-form 'letrec-values + intermediate-vocabulary + (make-letrec-values-micro #f)) +; (add-primitivized-micro-form 'letrec-values +; advanced-vocabulary +; (make-letrec-values-micro #t)) + (add-primitivized-micro-form 'letrec-values + scheme-vocabulary + (make-letrec-values-micro #t)) + + (define (make-letrec-macro begin?) + (let* ((kwd '()) + (in-pattern `(_ ((v e) ...) ,@(get-expr-pattern begin?))) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern `(letrec-values (((v) e) ...) ,@(get-expr-pattern begin?)))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed letrec"))))) + + (add-primitivized-macro-form 'letrec + intermediate-vocabulary + (make-letrec-macro #f)) +; (add-primitivized-macro-form 'letrec +; advanced-vocabulary +; (make-letrec-macro #t)) + (add-primitivized-macro-form 'letrec + scheme-vocabulary + (make-letrec-macro #t)) + + (define (make-or-macro boolean-result? one-or-zero-ok?) + (let* ((kwd '()) + (in-pattern-1 '(_)) + (out-pattern-1 '#f) + (in-pattern-2 '(_ e)) + (out-pattern-2 (if (not boolean-result?) + 'e + '(if e #t #f))) + (in-pattern-3 '(_ e0 e1)) + (out-pattern-3 (if (not boolean-result?) + '(let ((t e0)) (if t t e1)) + '(if e0 #t (if e1 #t #f)))) + (in-pattern-4 '(_ e0 e1 ...)) + (out-pattern-4 (if (not boolean-result?) + '(let ((t e0)) (if t t (or e1 ...))) + '(if e0 #t (or e1 ...)))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd)) + (m&e-4 (pat:make-match&env in-pattern-4 kwd))) + (lambda (expr env) + (let ((p-env (and one-or-zero-ok? + (pat:match-against m&e-1 expr env)))) + (if p-env + (pat:pexpand out-pattern-1 p-env kwd) + (or (and one-or-zero-ok? + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env)) + (and (not one-or-zero-ok?) + (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) + (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) + (static-error expr "Malformed or"))))))) + + (add-primitivized-macro-form 'or beginner-vocabulary (make-or-macro #t #f)) + (add-primitivized-macro-form 'or advanced-vocabulary (make-or-macro #f #f)) + (add-primitivized-macro-form 'or scheme-vocabulary (make-or-macro #f #t)) + + (add-primitivized-macro-form + 'nor + beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ e0 e1 ...)) + (out-pattern '(#%not (or e0 e1 ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed nor"))))) + + (define (make-and-macro boolean-result? one-or-zero-ok?) + (let* ((kwd '()) + (in-pattern-1 '(_)) + (out-pattern-1 '#t) + (in-pattern-2 '(_ e)) + (out-pattern-2 'e) + (in-pattern-3 '(_ e0 e1)) + (out-pattern-3 (if (not boolean-result?) + '(if e0 e1 #f) + '(if e0 (if e1 #t #f) #f))) + (in-pattern-4 '(_ e0 e1 ...)) + (out-pattern-4 '(if e0 (and e1 ...) #f)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd)) + (m&e-4 (pat:make-match&env in-pattern-4 kwd))) + (lambda (expr env) + (or (and one-or-zero-ok? + (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env)) + (and one-or-zero-ok? + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env)) + (and (not one-or-zero-ok?) + (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) + (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) + (static-error expr "Malformed and"))))) + + (add-primitivized-macro-form 'and beginner-vocabulary (make-and-macro #t #f)) + (add-primitivized-macro-form 'and advanced-vocabulary (make-and-macro #f #f)) + (add-primitivized-macro-form 'and scheme-vocabulary (make-and-macro #f #t)) + + (add-primitivized-macro-form + 'nand + beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ e0 e1 ...)) + (out-pattern '(#%not (and e0 e1 ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed nand"))))) + + (define recur-macro + (let* ((kwd '()) + (in-pattern '(_ fun ((v e) ...) b ...)) + (out-pattern '(let fun ((v e) ...) b ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed recur"))))) + + (add-primitivized-macro-form 'recur advanced-vocabulary recur-macro) + (add-on-demand-form 'macro 'recur common-vocabulary recur-macro) + + (define rec-macro + (let* ((kwd '()) + (in-pattern '(_ looper body)) + (out-pattern '(letrec ((looper body)) looper-copy)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (let ((p-env (pat:match-against m&e expr env))) + (or (and p-env + (let ([looper (pat:pexpand 'looper p-env kwd)]) + (and (valid-syntactic-id? looper) + (pat:pexpand + out-pattern + (pat:extend-penv 'looper-copy + (dup-symbol looper) + p-env) + kwd)))) + (static-error expr "Malformed rec")))))) + + (add-primitivized-macro-form 'rec advanced-vocabulary rec-macro) + (add-on-demand-form 'macro 'rec common-vocabulary rec-macro) + + (define-struct cond-clause (text question answer else? =>? or?)) + + (define (make-cond-clause-vocab) + (let([qa-error-msg "Clause is not in question-answer format"]) + (create-vocabulary 'cond-clause-vocab #f + qa-error-msg ; symbol + qa-error-msg ; literal + qa-error-msg ; list + qa-error-msg))) ; ilist + + (define nobegin-cond-clause-vocab (make-cond-clause-vocab)) + (define full-cond-clause-vocab (make-cond-clause-vocab)) + + (define (make-cond-list-micro begin? answerless?) + (let* ((kwd '(else =>)) + (in-pattern-1 (if (not begin?) + '(else answer) + '(else answer ...))) + (get-pattern-1 (if (not begin?) + 'answer + '(begin answer ...))) + (in-pattern-3 '(question => answer)) + (in-pattern-2 '(question => answer ...)) + (in-pattern-5 (if (not answerless?) + '(question => answer) ; will not match + '(question))) + (in-pattern-4 (if (not begin?) + '(question answer) + '(question answer ...))) + (get-pattern-4 (if (not begin?) + 'answer + '(begin answer ...))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd)) + (m&e-4 (pat:make-match&env in-pattern-4 kwd)) + (m&e-5 (pat:make-match&env in-pattern-5 kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((answer (pat:pexpand get-pattern-1 p-env kwd))) + (make-cond-clause expr #f answer #t #f #f)))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((question (pat:pexpand 'question p-env kwd)) + (answer (pat:pexpand 'answer p-env kwd))) + (make-cond-clause expr question answer #f #t #f)))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (static-error expr "=> not followed by exactly one receiver"))) + ((pat:match-against m&e-5 expr env) + => + (lambda (p-env) + (let ((question (pat:pexpand 'question p-env kwd))) + (make-cond-clause expr question #f #f #f #t)))) + ((pat:match-against m&e-4 expr env) + => + (lambda (p-env) + (let ((question (pat:pexpand 'question p-env kwd)) + (answer (pat:pexpand get-pattern-4 p-env kwd))) + (make-cond-clause expr question answer #f #f #f)))) + (else (static-error expr "Clause is not in question-answer format")))))) + + (add-list-micro nobegin-cond-clause-vocab (make-cond-list-micro #f #f)) + (add-list-micro full-cond-clause-vocab (make-cond-list-micro #t #t)) + + (define (make-cond-micro cond-clause-vocab allow-empty?) + (let* ((kwd '()) + (in-pattern '(_ bodies ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((bodies (pat:pexpand '(bodies ...) p-env kwd))) + (let ((exp-bodies + (as-nested + attributes + (lambda () + (map (lambda (e) + (expand-expr e env attributes + cond-clause-vocab)) + bodies))))) + (let ((had-no-clauses? (null? exp-bodies))) + (expand-expr + (structurize-syntax + (let loop ((exps exp-bodies)) + (if (null? exps) + (if (compile-allow-cond-fallthrough) + '(#%void) + `(#%raise + (#%make-exn:else + ,(if (and had-no-clauses? (not allow-empty?)) + "cond must contain at least one clause" + "no matching cond clause") + (#%current-continuation-marks)))) + (let ((first (car exps)) + (rest (cdr exps))) + (cond + ((cond-clause-=>? first) + `(let ((test ,(cond-clause-question first))) + (if test + (,(cond-clause-answer first) test) + ,(loop rest)))) + ((cond-clause-else? first) + (if (null? rest) + (cond-clause-answer first) + (static-error (cond-clause-text first) + "else allowed only in last position"))) + ((cond-clause-or? first) + `(or ,(cond-clause-question first) + ,(loop rest))) + (else + `(if ,(cond-clause-question first) + ,(cond-clause-answer first) + ,(loop rest))))))) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr "Malformed cond")))))) + + (add-primitivized-micro-form 'cond beginner-vocabulary (make-cond-micro nobegin-cond-clause-vocab #f)) + (add-primitivized-micro-form 'cond scheme-vocabulary (make-cond-micro full-cond-clause-vocab #t)) + + (define case-macro + (let* ((kwd-1 '(else)) + (in-pattern-1 `(_ val (else ,@(get-expr-pattern #t)))) + (out-pattern-1 `(begin val ,@(get-expr-pattern #t))) + (kwd-2 '()) + (in-pattern-2 '(_ val)) + (out-pattern-2-signal-error + `(#%raise (#%make-exn:else + "no matching else clause" + (#%current-continuation-marks)))) + (out-pattern-2-no-error + '(begin val (#%void))) + (in-pattern-3 `(_ val ((keys ...) ,@(get-expr-pattern #t)) rest ...)) + (out-pattern-3 `(let ((tmp val)) + (if (#%memv tmp (quote (keys ...))) + (begin ,@(get-expr-pattern #t)) + (case tmp rest ...)))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd-2)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd-2))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd-1 env) + (if (compile-allow-cond-fallthrough) + (pat:match-and-rewrite expr m&e-2 + out-pattern-2-no-error kwd-2 env) + (pat:match-and-rewrite expr m&e-2 + out-pattern-2-signal-error kwd-2 env)) + (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd-2 env) + (static-error expr "Malformed case"))))) + + (add-primitivized-macro-form 'case advanced-vocabulary case-macro) + (add-primitivized-macro-form 'case scheme-vocabulary case-macro) + + (define evcase-macro + (let* ((kwd-1 '(else)) + (in-pattern-1 `(_ val (else ,@(get-expr-pattern #t)))) + (out-pattern-1 `(begin val ,@(get-expr-pattern #t))) + (kwd-2 '()) + (in-pattern-2 '(_ val)) + (out-pattern-2-signal-error + `(#%raise (#%make-exn:else + "no matching else clause" + (#%current-continuation-marks)))) + (out-pattern-2-no-error + '(begin val (#%void))) + (kwd-3 '(else)) + (in-pattern-3 `(_ val (else ,@(get-expr-pattern #t)) rest)) + (kwd-4 '()) + (in-pattern-4 `(_ val (test-expr ,@(get-expr-pattern #t)) rest ...)) + (out-pattern-4 `(let ((tmp val)) + (if (#%eqv? tmp test-expr) + (begin ,@(get-expr-pattern #t)) + (evcase tmp rest ...)))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd-2)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd-3)) + (m&e-4 (pat:make-match&env in-pattern-4 kwd-4))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd-1 env) + (if (compile-allow-cond-fallthrough) + (pat:match-and-rewrite expr m&e-2 + out-pattern-2-no-error kwd-2 env) + (pat:match-and-rewrite expr m&e-2 + out-pattern-2-signal-error kwd-2 env)) + (let ((penv (pat:match-against m&e-3 expr env))) + (if penv + (static-error expr "else used before last evcase branch") + (or (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd-4 env) + (static-error expr "Malformed evcase")))))))) + + (add-primitivized-macro-form 'evcase advanced-vocabulary evcase-macro) + (add-on-demand-form 'macro 'evcase common-vocabulary evcase-macro) + + (define when-macro + (let* ((kwd '()) + (in-pattern `(_ test ,@(get-expr-pattern #t))) + (out-pattern `(if test (begin ,@(get-expr-pattern #t)) (#%void))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed when"))))) + + + (add-primitivized-macro-form 'when advanced-vocabulary when-macro) + (add-primitivized-macro-form 'when scheme-vocabulary when-macro) + + (define unless-macro + (let* ((kwd '()) + (in-pattern `(_ test ,@(get-expr-pattern #t))) + (out-pattern `(if test (#%void) (begin ,@(get-expr-pattern #t)))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed unless"))))) + + (add-primitivized-macro-form 'unless advanced-vocabulary unless-macro) + (add-primitivized-macro-form 'unless scheme-vocabulary unless-macro) + + (let ((rewriter + (lambda (call/cc the-kwd kwd-text) + (let* ((kwd '()) + (in-pattern `(_ var ,@(get-expr-pattern #t))) + (out-pattern `(,call/cc (lambda (var) ,@(get-expr-pattern #t)))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr + (string-append "Malformed " kwd-text)))))))) + (add-primitivized-macro-form 'let/cc advanced-vocabulary (rewriter '#%call/cc 'let/cc "let/cc")) + (add-primitivized-macro-form 'let/cc scheme-vocabulary (rewriter '#%call/cc 'let/cc "let/cc")) + + (add-primitivized-macro-form 'let/ec advanced-vocabulary (rewriter '#%call/ec 'let/ec "let/ec")) + (add-primitivized-macro-form 'let/ec scheme-vocabulary (rewriter '#%call/ec 'let/ec "let/ec"))) + + (define do-macro + (let* ((in-kwd '()) + (in-pattern `(_ (var-init-step ...) + (test seq ...) + ,@(get-expr-pattern 'optional))) + (out-pattern `(letrec ((loop + (lambda (var ...) + (if test + (begin (#%void) seq ...) + (begin ,@(get-expr-pattern 'optional) + (loop step ...)))))) + (loop init ...))) + (in-m&e (pat:make-match&env in-pattern in-kwd)) + (vis-kwd '()) + (vis-pattern-1 '(var init step)) + (vis-m&e-1 (pat:make-match&env vis-pattern-1 vis-kwd)) + (vis-pattern-2 '(var init)) + (vis-m&e-2 (pat:make-match&env vis-pattern-2 vis-kwd))) + (lambda (expr env) + (cond + ((pat:match-against in-m&e expr env) + => + (lambda (p-env) + (let ((var-init-steps (pat:pexpand '(var-init-step ...) + p-env in-kwd)) + (test (pat:pexpand 'test p-env in-kwd)) + (seqs (pat:pexpand '(seq ...) p-env in-kwd)) + (body (pat:pexpand `(,@(get-expr-pattern 'optional)) + p-env in-kwd))) + (let + ((normalized-var-init-steps + (map + (lambda (vis) + (cond + ((pat:match-against vis-m&e-1 vis vis-kwd) + => + (lambda (p-env) + `(,(pat:pexpand 'var p-env vis-kwd) + ,(pat:pexpand 'init p-env vis-kwd) + ,(pat:pexpand 'step p-env vis-kwd)))) + ((pat:match-against vis-m&e-2 vis vis-kwd) + => + (lambda (p-env) + `(,(pat:pexpand 'var p-env vis-kwd) + ,(pat:pexpand 'init p-env vis-kwd) + ,(pat:pexpand 'var p-env vis-kwd)))) + (else + (static-error vis + "Malformed var-init-step")))) + var-init-steps))) + (let ((vars (map car normalized-var-init-steps)) + (inits (map cadr normalized-var-init-steps)) + (steps (map caddr normalized-var-init-steps))) + (structurize-syntax + `(letrec ((loop + (lambda (,@vars) + (if ,test + (begin (#%void) ,@seqs) + (begin ,@body + (loop ,@steps)))))) + (loop ,@inits)) + expr '(-1) + #f + (make-origin 'macro expr))))))) + (else + (static-error expr "Malformed do")))))) + + (add-primitivized-macro-form 'do advanced-vocabulary do-macro) + (add-primitivized-macro-form 'do scheme-vocabulary do-macro) + + (define fluid-let-macro + (let* ((kwd '()) + (in-pattern `(_ ((var val) ...) ,@(get-expr-pattern #t))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((vars (pat:pexpand '(var ...) p-env kwd)) + (vals (pat:pexpand '(val ...) p-env kwd)) + (body (pat:pexpand (get-expr-pattern #t) p-env kwd))) + (distinct-valid-syntactic-id/s? vars) + (let* ((new-vars (map generate-name vars))) + (expand-expr + (structurize-syntax + (if (null? vars) + `(let-values () ,@body) + `(let ,(map list new-vars vars) + (#%dynamic-wind + (lambda () + ,@(map (lambda (var val) + `(set! ,var ,val)) + vars vals)) + (lambda () + ,@body) + (lambda () + ,@(map (lambda (var tmp) + `(set! ,(dup-symbol var) ,tmp)) + vars new-vars))))) + expr '(-1) + #f + (make-origin 'macro expr)) + env attributes vocab))))) + (else + (static-error expr "Malformed fluid-let")))))) + + (add-primitivized-micro-form 'fluid-let advanced-vocabulary fluid-let-macro) + (add-primitivized-micro-form 'fluid-let scheme-vocabulary fluid-let-macro) + + (define parameterize-micro + (let* ((kwd '()) + (body (get-expr-pattern #t)) + (in-pattern `(_ ((param value) ...) ,@body)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ([p-env (pat:match-against m&e expr env)]) + (if p-env + (let* ((params (pat:pexpand '(param ...) p-env kwd)) + (vals (pat:pexpand '(value ...) p-env kwd)) + (body (pat:pexpand body p-env kwd)) + (pzs (map generate-name params)) + (saves (map generate-name params)) + (swap (generate-name (structurize-syntax 'swap expr '(-1))))) + (expand-expr + (structurize-syntax + (if (null? params) + `(let-values () ,@body) + `(let ,(append + (map list pzs params) + (map list saves vals)) + (let ((,swap (lambda () + ,@(map + (lambda (save pz) + `(let ([x ,save]) + (set! ,save (,pz)) + (,pz x))) + saves pzs)))) + (#%dynamic-wind + ,swap + (#%lambda () ,@body) + ,swap)))) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab)) + (static-error expr "Malformed parameterize")))))) + + (add-primitivized-micro-form 'parameterize advanced-vocabulary parameterize-micro) + (add-primitivized-micro-form 'parameterize scheme-vocabulary parameterize-micro) + + (define (make-with-handlers-macro begin?) + (let* ((kwd '()) + (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) + (out-pattern-1 (if (not begin?) + 'b + `(let-values () ,@(get-expr-pattern begin?)))) + (in-pattern-2 `(_ ((pred handler) ...) ,@(get-expr-pattern begin?))) + (out-pattern-2 + `((#%call/ec + (lambda (k) + (let ((handlers (#%list + (#%cons pred handler) + ...))) + (parameterize + ((#%current-exception-handler + (lambda (e) + (k + (lambda () + (let loop ((handlers handlers)) + (cond + ((#%null? handlers) + (#%raise e)) + (((#%caar handlers) e) + ((#%cdar handlers) e)) + (else + (loop (#%cdr handlers)))))))))) + (#%call-with-values + (lambda () ,@(get-expr-pattern begin?)) + (lambda args + (lambda () (#%apply #%values args)))))))))) + (m&e-1 (pat:make-match&env in-pattern-1 kwd)) + (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (static-error expr "Malformed with-handlers"))))) + + (add-primitivized-macro-form 'with-handlers + advanced-vocabulary + (make-with-handlers-macro #f)) + (add-primitivized-macro-form 'with-handlers + scheme-vocabulary + (make-with-handlers-macro #t)) + + (define (norm-path p) ; normalizes ending slash or not + (and p + (let-values ([(base name dir?) (split-path p)]) + (build-path base name)))) + (define mzlib-directory (with-handlers ([void void]) + (norm-path (collection-path "mzlib")))) + (define (get-on-demand-form name vocab) + (let ([dir (norm-path (current-load-relative-directory))]) + (and (equal? dir mzlib-directory) + (find-on-demand-form name vocab)))) + + (add-primitivized-micro-form 'define-macro common-vocabulary + (let* ((kwd '()) + (in-pattern `(_ macro-name macro-handler)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((macro-name (pat:pexpand 'macro-name p-env kwd)) + (macro-handler (pat:pexpand 'macro-handler p-env kwd))) + (valid-syntactic-id? macro-name) + (unless (get-top-level-status attributes) + (static-error expr "Only supported at top-level")) + (let* ((real-name (sexp->raw macro-name))) + (let ([on-demand (get-on-demand-form real-name vocab)]) + (if on-demand + (case (car on-demand) + [(micro) (add-primitivized-micro-form real-name vocab (cadr on-demand))] + [(macro) (add-primitivized-macro-form real-name vocab (cadr on-demand))]) + (let* ((expanded-handler (as-nested + attributes + (lambda () + (expand-expr macro-handler + env attributes vocab)))) + (real-handler (m3-elaboration-evaluator + expanded-handler + parsed->raw + 'define-macro)) + (cache-table (make-hash-table))) + (unless (procedure? real-handler) + (static-error expr "Expander is not a procedure")) + (add-user-macro-form + real-name vocab + (lambda (m-expr m-env) + (structurize-syntax + (apply m3-macro-body-evaluator real-handler + (cdr (sexp->raw m-expr cache-table))) + m-expr '() cache-table + (make-origin 'macro expr))))))) + (expand-expr (structurize-syntax '(#%void) expr + '() #f (make-origin 'micro expr)) + env attributes vocab))))) + (else + (static-error expr "Malformed define-macro")))))) + + (add-primitivized-micro-form 'let-macro common-vocabulary + (let* ((kwd '()) + (in-pattern `(_ macro-name macro-handler b0 b1 ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((macro-name (pat:pexpand 'macro-name p-env kwd)) + (macro-handler (pat:pexpand 'macro-handler p-env kwd)) + (body (pat:pexpand '(begin b0 b1 ...) p-env kwd))) + (valid-syntactic-id? macro-name) + (let* ((real-name (sexp->raw macro-name)) + (expanded-handler (as-nested + attributes + (lambda () + (expand-expr macro-handler + env attributes vocab)))) + (real-handler (m3-elaboration-evaluator + expanded-handler + parsed->raw + 'let-macro)) + (cache-table (make-hash-table))) + (unless (procedure? real-handler) + (static-error expr "Expander is not a procedure")) + (let ((extended-vocab + (create-vocabulary 'user-macro-extended-vocab + vocab))) + (add-user-macro-form real-name extended-vocab + (lambda (m-expr m-env) + (structurize-syntax + (apply m3-macro-body-evaluator real-handler + (cdr (sexp->raw m-expr cache-table))) + m-expr '() cache-table + (make-origin 'macro expr)))) + (expand-expr + (structurize-syntax body expr + '() + #f (make-origin 'micro expr)) + env attributes extended-vocab)))))) + (else + (static-error expr "Malformed let-macro")))))) + + (let ((b-e/c-t + (lambda (kwd-symbol kwd-string phase-string on-demand?) + (let ([micro (let* ((kwd '()) + (in-pattern '(_ e0 e1 ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((exprs (pat:pexpand '(begin e0 e1 ...) + p-env kwd))) + (expand-expr + (structurize-syntax + (with-handlers + ((exn? (lambda (exn) + (static-error expr + "Exception at ~a time: ~a" + phase-string + (exn-message exn))))) + (m3-elaboration-evaluator + (let ([top-level? (get-top-level-status attributes)] + [internal? (get-internal-define-status attributes)]) + (dynamic-wind + (lambda () + (set-top-level-status attributes #t) + (set-internal-define-status attributes #f)) + (lambda () + (expand + (structurize-syntax exprs expr) + attributes vocab + m3-elaboration-evaluator + m3-macro-body-evaluator)) + (lambda () + (set-top-level-status attributes top-level?) + (set-internal-define-status attributes internal?)))) + parsed->raw + kwd-symbol)) + expr + '() #f (make-origin 'micro expr)) + env attributes vocab)))) + (else + (static-error expr + (string-append "Malformed " kwd-string))))))]) + (add-micro-form kwd-symbol full-vocabulary micro) + (if on-demand? + (add-on-demand-form 'micro kwd-symbol scheme-vocabulary micro) + (add-micro-form kwd-symbol scheme-vocabulary micro)))))) + (b-e/c-t 'begin-construction-time "begin-construction-time" "construction" #t) + (b-e/c-t 'begin-elaboration-time "begin-elaboration-time" "elaboration" #f)) + + (define unquote-micro + (lambda (expr env) + (static-error expr "Unquote outside quasiquote"))) + (add-primitivized-macro-form 'unquote intermediate-vocabulary unquote-micro) + (add-primitivized-macro-form 'unquote scheme-vocabulary unquote-micro) + + (define unquote-splicing-micro + (lambda (expr env) + (static-error expr "Unquote-splicing outside quasiquote"))) + (add-primitivized-macro-form 'unquote-splicing intermediate-vocabulary unquote-splicing-micro) + (add-primitivized-macro-form 'unquote-splicing scheme-vocabulary unquote-splicing-micro) + + (include "quasi.ss") + +; (include "shared.ss") + + (define reference-file-macro + (let* ((kwd '()) + (in-pattern '(_ filename)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd))) + (let ((f (expand-expr filename env attributes vocab))) + (if (and (quote-form? f) + (z:string? (quote-form-expr f))) + (expand-expr + (structurize-syntax + `(#%load/use-compiled ,(quote-form-expr f)) + expr '(-1) + #f + (make-origin 'macro expr)) + env attributes vocab) + (static-error filename "Does not yield a filename")))))) + (else + (static-error expr "Malformed reference-file")))))) + + (add-primitivized-micro-form 'reference-file beginner-vocabulary reference-file-macro) + (add-on-demand-form 'micro 'reference-file common-vocabulary reference-file-macro) + + (define require-library-micro + (let* ((kwd '()) + (in-pattern '(_ filename collections ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd)) + (collections (pat:pexpand '(collections ...) p-env kwd))) + (let ((f (as-nested attributes (lambda () (expand-expr filename env attributes vocab)))) + (cs (as-nested + attributes + (lambda () + (map (lambda (c) + (expand-expr c env attributes vocab)) + collections))))) + (unless (and (quote-form? f) + (z:string? (quote-form-expr f))) + (static-error filename "Does not yield a filename")) + (for-each + (lambda (c collection) + (unless (and (quote-form? c) + (z:string? (quote-form-expr c))) + (static-error collection "Does not yield a string"))) + cs collections) + (let ((raw-f (z:read-object (quote-form-expr f))) + (raw-cs (map (lambda (c) + (z:read-object (quote-form-expr c))) + cs))) + (unless (relative-path? raw-f) + (static-error f + "Library path ~s must be a relative path" + raw-f)) + (expand-expr + (structurize-syntax + `(#%require-library/proc ,(quote-form-expr f) + ,@(map quote-form-expr cs)) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr "Malformed require-library")))))) + + (add-primitivized-micro-form 'require-library beginner-vocabulary require-library-micro) + (add-primitivized-micro-form 'require-library scheme-vocabulary require-library-micro) + + (define require-relative-library-micro + (let* ((kwd '()) + (in-pattern '(_ filename collections ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd)) + (collections (pat:pexpand '(collections ...) p-env kwd))) + (let ((f (as-nested attributes (lambda () (expand-expr filename env attributes vocab)))) + (cs (as-nested + attributes + (lambda () + (map (lambda (c) + (expand-expr c env attributes vocab)) + collections))))) + (unless (and (quote-form? f) + (z:string? (quote-form-expr f))) + (static-error filename "Does not yield a filename")) + (for-each + (lambda (c collection) + (unless (and (quote-form? c) + (z:string? (quote-form-expr c))) + (static-error collection "Does not yield a string"))) + cs collections) + (let ((raw-f (z:read-object (quote-form-expr f))) + (raw-cs (map (lambda (c) + (z:read-object (quote-form-expr c))) + cs))) + (unless (relative-path? raw-f) + (static-error f + "Library path ~s must be a relative path" + raw-f)) + (expand-expr + (structurize-syntax + `(#%require-relative-library/proc ,(quote-form-expr f) + ,@(map quote-form-expr cs)) + expr '(-1) + #f + (make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr "Malformed require-relative-library")))))) + + (add-primitivized-micro-form 'require-relative-library beginner-vocabulary require-relative-library-micro) + (add-primitivized-micro-form 'require-relative-library scheme-vocabulary require-relative-library-micro) + + (add-macro-form 'define-constructor beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ sym modes ...)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern '(#%void))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed define-constructor"))))) + + (add-macro-form 'define-type beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ sym type)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern '(#%void))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed define-type"))))) + + (add-macro-form ': beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ expr type)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern 'expr)) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed :"))))) + + (add-macro-form 'type: beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ type attr ...)) + (out-pattern '(#%void)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed type:"))))) + + (add-macro-form 'mrspidey:control beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ para val)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern '(#%void))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed st:control"))))) + + (add-macro-form 'polymorphic beginner-vocabulary + (let* ((kwd '()) + (in-pattern '(_ body)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern 'body)) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed polymorphic"))))) + + ) diff --git a/collects/zodiac/scm-obj.ss b/collects/zodiac/scm-obj.ss new file mode 100644 index 00000000..b3776957 --- /dev/null +++ b/collects/zodiac/scm-obj.ss @@ -0,0 +1,830 @@ +; $Id: scm-obj.ss,v 1.43 1999/05/20 22:36:52 mflatt Exp $ + +(unit/sig zodiac:scheme-objects^ + (import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^) + zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ + zodiac:scheme-main^ zodiac:back-protocol^ + zodiac:expander^ zodiac:interface^) + + (define-struct (class*/names-form struct:parsed) + (this super-init super-expr interfaces init-vars inst-clauses)) + + (define-struct (interface-form struct:parsed) + (super-exprs variables)) + + (define create-class*/names-form + (lambda (this super-init super-expr interfaces + init-vars inst-clauses source) + (make-class*/names-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + this super-init super-expr interfaces init-vars inst-clauses))) + + (define create-interface-form + (lambda (super-exprs variables source) + (make-interface-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + super-exprs variables))) + + (define-struct (supervar-binding struct:binding) ()) + (define-struct (superinit-binding struct:binding) ()) + (define-struct (public-binding struct:binding) ()) + (define-struct (override-binding struct:binding) ()) + (define-struct (private-binding struct:binding) ()) + (define-struct (inherit-binding struct:binding) ()) + (define-struct (rename-binding struct:binding) ()) + + (define create-supervar-binding+marks + (create-binding+marks make-supervar-binding)) + (define create-superinit-binding+marks + (create-binding+marks make-superinit-binding)) + (define create-public-binding+marks + (create-binding+marks make-public-binding)) + (define create-override-binding+marks + (create-binding+marks make-override-binding)) + (define create-private-binding+marks + (create-binding+marks make-private-binding)) + (define create-inherit-binding+marks + (create-binding+marks make-inherit-binding)) + (define create-rename-binding+marks + (create-binding+marks make-rename-binding)) + + (define-struct (supervar-varref struct:bound-varref) ()) + (define-struct (superinit-varref struct:bound-varref) ()) + (define-struct (public-varref struct:bound-varref) ()) + (define-struct (override-varref struct:bound-varref) ()) + (define-struct (private-varref struct:bound-varref) ()) + (define-struct (inherit-varref struct:bound-varref) ()) + (define-struct (rename-varref struct:bound-varref) ()) + + (define create-supervar-varref + (create-bound-varref make-supervar-varref)) + (define create-superinit-varref + (create-bound-varref make-superinit-varref)) + (define create-public-varref + (create-bound-varref make-public-varref)) + (define create-override-varref + (create-bound-varref make-override-varref)) + (define create-private-varref + (create-bound-varref make-private-varref)) + (define create-inherit-varref + (create-bound-varref make-inherit-varref)) + (define create-rename-varref + (create-bound-varref make-rename-varref)) + + (define-struct public-clause (exports internals exprs)) + (define-struct override-clause (exports internals exprs)) + (define-struct private-clause (internals exprs)) + (define-struct inherit-clause (internals imports)) + (define-struct rename-clause (internals imports)) + (define-struct sequence-clause (exprs)) + + ; -------------------------------------------------------------------- + + (define interface-micro + (let* ((kwd '()) + (in-pattern `(_ + (super-interfaces ...) + variables ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((super-interfaces + (pat:pexpand '(super-interfaces ...) p-env kwd)) + (variables + (pat:pexpand '(variables ...) p-env kwd))) + (distinct-valid-syntactic-id/s? variables) + (let* ((proc:super-interfaces + (as-nested + attributes + (lambda () + (map (lambda (e) + (expand-expr e env + attributes vocab)) + super-interfaces))))) + (create-interface-form + proc:super-interfaces + variables + expr))))) + (else + (static-error expr "Malformed interface")))))) + + (add-primitivized-micro-form 'interface full-vocabulary interface-micro) + (add-primitivized-micro-form 'interface scheme-vocabulary interface-micro) + + ; ---------------------------------------------------------------------- + + (define sym-micro + (lambda (expr env attributes vocab) + (let ((r (resolve expr env vocab))) + (cond + ((lexical-binding? r) + (create-lexical-varref r expr)) + ((top-level-resolution? r) + (check-for-signature-name expr attributes) + (process-top-level-resolution expr attributes)) + ((public-binding? r) + (create-public-varref r expr)) + ((override-binding? r) + (create-override-varref r expr)) + ((private-binding? r) + (create-private-varref r expr)) + ((inherit-binding? r) + (create-inherit-varref r expr)) + ((rename-binding? r) + (create-rename-varref r expr)) + ((supervar-binding? r) + (create-supervar-varref r expr)) + ((superinit-binding? r) + (create-superinit-varref r expr)) + ((or (macro-resolution? r) (micro-resolution? r)) + (static-error expr + "Invalid use of keyword ~s" (z:symbol-orig-name expr))) + (else + (internal-error expr "Invalid resolution in obj: ~s" r)))))) + + (add-sym-micro full-vocabulary sym-micro) + (add-sym-micro scheme-vocabulary sym-micro) + + ; ---------------------------------------------------------------------- + + (define-struct ivar-entry (bindings)) + (define-struct (public-entry struct:ivar-entry) (exports exprs)) + (define-struct (override-entry struct:ivar-entry) (exports exprs)) + (define-struct (private-entry struct:ivar-entry) (exprs)) + (define-struct (inherit-entry struct:ivar-entry) (imports)) + (define-struct (rename-entry struct:ivar-entry) (imports)) + + (define-struct sequence-entry (exprs)) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define make-void-init-expr + (lambda (expr) + (structurize-syntax '(#%void) expr '(-1)))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define ivar-decls-vocab + (create-vocabulary 'ivar-decls-vocab #f + "Invalid ivar declaration" + "Invalid ivar declaration" + "Invalid ivar declaration" + "Invalid ivar declaration")) + + (define public-ivar-decl-entry-parser-vocab + (create-vocabulary 'public-ivar-decl-entry-parser-vocab #f + "Invalid public declaration" + "Invalid public declaration" + "Invalid public declaration" + "Invalid public declaration")) + + (define override-ivar-decl-entry-parser-vocab + (create-vocabulary 'override-ivar-decl-entry-parser-vocab #f + "Invalid override declaration" + "Invalid override declaration" + "Invalid override declaration" + "Invalid override declaration")) + + (add-sym-micro public-ivar-decl-entry-parser-vocab + (lambda (expr env attributes vocab) + (list + (create-public-binding+marks expr) + expr + (make-void-init-expr expr)))) + + (define (mk-public/override-micro kind-sym kind-str + ivar-decl-entry-parser-vocab + create-binding+marks + make-entry) + (add-list-micro ivar-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern-1 '((internal-var var) expr)) + (in-pattern-2 '(var expr)) + (in-pattern-3 '(var)) + (m&e-1 (pat:make-match&env in-pattern-1 '())) + (m&e-2 (pat:make-match&env in-pattern-2 '())) + (m&e-3 (pat:make-match&env in-pattern-3 '()))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((internal-var (pat:pexpand 'internal-var p-env kwd)) + (var (pat:pexpand 'var p-env kwd)) + (expr (pat:pexpand 'expr p-env kwd))) + (valid-syntactic-id? internal-var) + (valid-syntactic-id? var) + (list (create-binding+marks internal-var) var expr)))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (expr (pat:pexpand 'expr p-env kwd))) + (valid-syntactic-id? var) + (list (create-binding+marks var) var expr)))) + ((pat:match-against m&e-3 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd))) + (valid-syntactic-id? var) + (list + (create-binding+marks var) + var + (make-void-init-expr expr))))) + (else + (static-error expr (format "Invalid ~a ivar declaration" kind-str))))))) + + (let* ((kwd `(,kind-sym)) + (in-pattern `(,kind-sym ivar-decl ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (add-micro-form kind-sym ivar-decls-vocab + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((decls + (map (lambda (decl) + (expand-expr decl env attributes + ivar-decl-entry-parser-vocab)) + (pat:pexpand '(ivar-decl ...) p-env kwd)))) + (make-entry + (map car decls) + (map cadr decls) + (map caddr decls))))) + (else + (static-error expr (format "Invalid ~a clause" kind-str)))))))) + + (mk-public/override-micro 'public "public" + public-ivar-decl-entry-parser-vocab + create-public-binding+marks + make-public-entry) + + (mk-public/override-micro 'override "override" + override-ivar-decl-entry-parser-vocab + create-override-binding+marks + make-override-entry) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define private-ivar-decl-entry-parser-vocab + (create-vocabulary 'private-ivar-decl-entry-parser-vocab #f + "Invalid private declaration" + "Invalid private declaration" + "Invalid private declaration" + "Invalid private declaration")) + + (add-sym-micro private-ivar-decl-entry-parser-vocab + (lambda (expr env attributes vocab) + (cons (create-private-binding+marks expr) + (make-void-init-expr expr)))) + + (add-list-micro private-ivar-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern-1 '(var expr)) + (in-pattern-2 '(var)) + (m&e-1 (pat:make-match&env in-pattern-1 '())) + (m&e-2 (pat:make-match&env in-pattern-2 '()))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (expr (pat:pexpand 'expr p-env kwd))) + (valid-syntactic-id? var) + (cons (create-private-binding+marks var) expr)))) + ((pat:match-against m&e-2 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd))) + (valid-syntactic-id? var) + (cons (create-private-binding+marks var) + (make-void-init-expr expr))))) + (else + (static-error expr "Invalid ivar declaration")))))) + + (let* ((kwd '(private)) + (in-pattern '(private ivar-decl ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (add-micro-form 'private ivar-decls-vocab + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((decls + (map (lambda (decl) + (expand-expr decl env attributes + private-ivar-decl-entry-parser-vocab)) + (pat:pexpand '(ivar-decl ...) p-env kwd)))) + (make-private-entry + (map car decls) + (map cdr decls))))) + (else + (static-error expr "Invalid private clause")))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define inherit-ivar-decl-entry-parser-vocab + (create-vocabulary 'inherit-ivar-decl-entry-parser-vocab #f + "Invalid inherit declaration" + "Invalid inherit declaration" + "Invalid inherit declaration" + "Invalid inherit declaration")) + + (add-sym-micro inherit-ivar-decl-entry-parser-vocab + (lambda (expr env attributes vocab) + (cons + (create-inherit-binding+marks expr) + expr))) + + (add-list-micro inherit-ivar-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern '(internal-var var)) + (m&e (pat:make-match&env in-pattern '()))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((internal-var (pat:pexpand 'internal-var p-env kwd)) + (var (pat:pexpand 'var p-env kwd))) + (valid-syntactic-id? internal-var) + (valid-syntactic-id? var) + (cons + (create-inherit-binding+marks internal-var) + var)))) + (else + (static-error expr "Invalid ivar declaration")))))) + + (let* ((kwd '(inherit)) + (in-pattern '(inherit ivar-decl ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (add-micro-form 'inherit ivar-decls-vocab + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((decls + (map (lambda (decl) + (expand-expr decl env attributes + inherit-ivar-decl-entry-parser-vocab)) + (pat:pexpand '(ivar-decl ...) p-env kwd)))) + (make-inherit-entry + (map car decls) + (map cdr decls))))) + (else + (static-error expr "Invalid inherit clause")))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (define rename-ivar-decl-entry-parser-vocab + (create-vocabulary 'rename-ivar-decl-entry-parser-vocab #f + "Invalid rename declaration" + "Invalid rename declaration" + "Invalid rename declaration" + "Invalid rename declaration")) + + (add-list-micro rename-ivar-decl-entry-parser-vocab + (let* ((kwd '()) + (in-pattern-1 '(var inherited-var)) + (m&e-1 (pat:make-match&env in-pattern-1 '()))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let ((var (pat:pexpand 'var p-env kwd)) + (inherited-var (pat:pexpand 'inherited-var p-env kwd))) + (valid-syntactic-id? var) + (valid-syntactic-id? inherited-var) + (cons (create-rename-binding+marks var) inherited-var)))) + (else + (static-error expr "Invalid ivar declaration")))))) + + (let* ((kwd '(rename)) + (in-pattern '(rename ivar-decl ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (add-micro-form 'rename ivar-decls-vocab + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((decls + (map (lambda (decl) + (expand-expr decl env attributes + rename-ivar-decl-entry-parser-vocab)) + (pat:pexpand '(ivar-decl ...) p-env kwd)))) + (make-rename-entry + (map car decls) + (map cdr decls))))) + (else + (static-error expr "Invalid rename clause")))))) + + ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + (let* ((kwd '(sequence)) + (in-pattern '(sequence expr ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (add-micro-form 'sequence ivar-decls-vocab + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (make-sequence-entry + (pat:pexpand '(expr ...) p-env kwd)))) + (else + (static-error expr "Invalid sequence clause")))))) + + ; ---------------------------------------------------------------------- + + (define class-micro + (let* ((kwd '()) + (in-pattern `(kwd super args insts ...)) + (out-pattern '(class*/names (this super-init) + super () args insts ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ((kwd-pos (pat:pexpand 'kwd p-env kwd)) + (captured-this + (introduce-fresh-identifier 'this kwd-pos)) + (captured-super-init + (introduce-fresh-identifier 'super-init kwd-pos)) + (new-p-env (pat:extend-penv + 'this captured-this + (pat:extend-penv + 'super-init + captured-super-init + p-env)))) + (expand-expr + (structurize-syntax + (pat:pexpand out-pattern new-p-env kwd) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))) + (else + (static-error expr "Malformed class")))))) + + (add-primitivized-micro-form 'class full-vocabulary class-micro) + (add-primitivized-micro-form 'class scheme-vocabulary class-micro) + + (define class*-micro + (let* ((kwd '()) + (in-pattern `(kwd super interfaces args insts ...)) + (out-pattern '(class*/names (this super-init) + super interfaces args insts ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let* ((kwd-pos (pat:pexpand 'kwd p-env kwd)) + (captured-this + (introduce-fresh-identifier 'this kwd-pos)) + (captured-super-init + (introduce-fresh-identifier 'super-init kwd-pos)) + (new-p-env (pat:extend-penv + 'this captured-this + (pat:extend-penv + 'super-init + captured-super-init + p-env)))) + (expand-expr + (structurize-syntax + (pat:pexpand out-pattern new-p-env kwd) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))) + (else + (static-error expr "Malformed class*")))))) + + (add-primitivized-micro-form 'class* full-vocabulary class*-micro) + (add-primitivized-micro-form 'class* scheme-vocabulary class*-micro) + + (define flag-non-supervar + (lambda (super env) + (unless (supervar-binding? + (resolve-in-env (z:read-object super) + (z:symbol-marks super) env)) + (static-error super "Not a superclass reference")))) + + (define class*/names-micro + (let* ((kwd '()) + (in-pattern `(kwd (this super-init) + super-expr + (interface ...) + ,paroptarglist-pattern + inst-vars ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((in:this (pat:pexpand 'this p-env kwd)) + (in:superinit (pat:pexpand 'super-init + p-env kwd)) + (in:super-expr (pat:pexpand 'super-expr + p-env kwd)) + (in:interfaces (pat:pexpand '(interface ...) + p-env kwd)) + (in:initvars (pat:pexpand `,paroptarglist-pattern + p-env kwd)) + (in:ivars (pat:pexpand '(inst-vars ...) + p-env kwd))) + (valid-syntactic-id? in:this) + (valid-syntactic-id? in:superinit) + (as-nested + attributes + (lambda () + (let* ((proc:superinit + (create-superinit-binding+marks + in:superinit)) + (proc:super-expr + (expand-expr in:super-expr env + attributes vocab)) + (proc:interfaces + (map (lambda (e) + (expand-expr e env + attributes vocab)) + in:interfaces)) + (proc:this (create-lexical-binding+marks + in:this)) + (proc:initvar-info + (expand-expr in:initvars env attributes + paroptarglist-decls-vocab)) + (proc:ivar-info + (map (lambda (iv-decl) + (expand-expr iv-decl env attributes + ivar-decls-vocab)) + in:ivars))) + (let ((proc:initvars + (map paroptarglist-entry-var+marks + (paroptarglist-vars + proc:initvar-info))) + (proc:ivars + (apply append + (map (lambda (i) + (if (ivar-entry? i) + (ivar-entry-bindings i) + '())) + proc:ivar-info)))) + (let ((extensions + (cons proc:this + (cons proc:superinit + proc:ivars)))) + (let* ((new-names (map car extensions)) + (parsed-initvars + (make-paroptargument-list + proc:initvar-info + env attributes vocab))) + (distinct-valid-id/s? (append new-names + (map car + proc:initvars))) + (let ((external-ivars + (apply append + (map + (lambda (e) + (cond + ((public-entry? e) + (public-entry-exports e)) + ((override-entry? e) + (override-entry-exports e)) + (else null))) + proc:ivar-info)))) + (distinct-valid-syntactic-id/s? external-ivars) + (void)) + (extend-env extensions env) + (let + ((result + (create-class*/names-form + (car proc:this) + (car proc:superinit) + proc:super-expr + proc:interfaces + parsed-initvars + (let ((expand-exprs + (lambda (exprs) + (map (lambda (expr) + (expand-expr expr env + attributes vocab)) + exprs)))) + (map + (lambda (e) + (cond + ((public-entry? e) + (make-public-clause + (public-entry-exports e) + (map car (ivar-entry-bindings e)) + (expand-exprs + (public-entry-exprs e)))) + ((override-entry? e) + (make-override-clause + (override-entry-exports e) + (map car (ivar-entry-bindings e)) + (expand-exprs + (override-entry-exprs e)))) + ((private-entry? e) + (make-private-clause + (map car (ivar-entry-bindings e)) + (expand-exprs + (private-entry-exprs e)))) + ((inherit-entry? e) + (make-inherit-clause + (map car + (ivar-entry-bindings e)) + (inherit-entry-imports e))) + ((rename-entry? e) + (make-rename-clause + (map car (ivar-entry-bindings e)) + (rename-entry-imports e))) + ((sequence-entry? e) + (make-sequence-clause + (expand-exprs + (sequence-entry-exprs e)))) + (else + (internal-error e + "Invalid entry in class*/names maker")))) + proc:ivar-info)) + expr))) + (retract-env (append + (map car proc:initvars) + new-names) + env) + result)))))))))) + (else + (static-error expr "Malformed class*/names")))))) + + + (add-primitivized-micro-form 'class*/names full-vocabulary class*/names-micro) + (add-primitivized-micro-form 'class*/names scheme-vocabulary class*/names-micro) + + ; ---------------------------------------------------------------------- + + (define ivar-micro + (let* ((kwd '()) + (in-pattern '(_ object name)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((object (pat:pexpand 'object p-env kwd)) + (name (pat:pexpand 'name p-env kwd))) + (valid-syntactic-id? name) + (as-nested + attributes + (lambda () + (expand-expr + (structurize-syntax + `(#%ivar/proc ,object (quote ,name)) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr "Malformed ivar")))))) + + (add-primitivized-micro-form 'ivar full-vocabulary ivar-micro) + (add-primitivized-micro-form 'ivar scheme-vocabulary ivar-micro) + + (define send-macro + (let* ((kwd '()) + (in-pattern '(_ object name arg ...)) + (out-pattern '((ivar object name) arg ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed send"))))) + + (add-primitivized-macro-form 'send full-vocabulary send-macro) + (add-primitivized-macro-form 'send scheme-vocabulary send-macro) + + (define send*-macro + (let* ((kwd '()) + (in-pattern '(_ object (n0 a0 ...) ...)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern '(begin + (send object n0 a0 ...) + ...))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed send*"))))) + + (add-primitivized-macro-form 'send* full-vocabulary send*-macro) + (add-on-demand-form 'macro 'send* common-vocabulary send*-macro) + + (define make-generic-macro + (let* ((kwd '()) + (in-pattern '(_ class name)) + (m&e (pat:make-match&env in-pattern kwd)) + (out-pattern '(#%make-generic/proc class (quote name)))) + (lambda (expr env) + (or (pat:match-and-rewrite expr m&e out-pattern kwd env) + (static-error expr "Malformed make-generic"))))) + + (add-primitivized-macro-form 'make-generic full-vocabulary make-generic-macro) + (add-primitivized-macro-form 'make-generic scheme-vocabulary make-generic-macro) + + ; ---------------------------------------------------------------------- + + (define set!-micro + (let* ((kwd '()) + (in-pattern `(_ var val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((p-env (pat:match-against m&e expr env))) + (if p-env + (let* ((var-p (pat:pexpand 'var p-env kwd)) + (_ (valid-syntactic-id? var-p)) + (id-expr (expand-expr var-p env attributes vocab)) + (expr-expr (as-nested + attributes + (lambda () + (expand-expr + (pat:pexpand 'val p-env kwd) + env attributes vocab))))) + (when (or (inherit-varref? id-expr) + (rename-varref? id-expr)) + (static-error var-p + "Cannot mutate inherited or renamed variables")) + (create-set!-form id-expr expr-expr expr)) + (static-error expr "Malformed set!")))))) + + (add-primitivized-micro-form 'set! full-vocabulary set!-micro) + (add-primitivized-micro-form 'set! scheme-vocabulary set!-micro) + + ; -------------------------------------------------------------------- + + (extend-parsed->raw class*/names-form? + (lambda (expr p->r) + `(class*/names + (,(p->r (class*/names-form-this expr)) + ,(p->r (class*/names-form-super-init expr))) + ,(p->r (class*/names-form-super-expr expr)) + ,(map p->r (class*/names-form-interfaces expr)) + ,(p->r (class*/names-form-init-vars expr)) + ,@(map (lambda (clause) + (cond + ((public-clause? clause) + `(public + ,@(map (lambda (internal export expr) + `((,(p->r internal) ,(sexp->raw export)) + ,(p->r expr))) + (public-clause-internals clause) + (public-clause-exports clause) + (public-clause-exprs clause)))) + ((override-clause? clause) + `(override + ,@(map (lambda (internal export expr) + `((,(p->r internal) ,(sexp->raw export)) + ,(p->r expr))) + (override-clause-internals clause) + (override-clause-exports clause) + (override-clause-exprs clause)))) + ((private-clause? clause) + `(private + ,@(map (lambda (internal expr) + `(,(p->r internal) ,(p->r expr))) + (private-clause-internals clause) + (private-clause-exprs clause)))) + ((inherit-clause? clause) + `(inherit + ,@(map (lambda (internal inherited) + `(,(p->r internal) ,(sexp->raw inherited))) + (inherit-clause-internals clause) + (inherit-clause-imports clause)))) + ((rename-clause? clause) + `(rename + ,@(map (lambda (internal inherited) + `(,(p->r internal) ,(sexp->raw inherited))) + (rename-clause-internals clause) + (rename-clause-imports clause)))) + ((sequence-clause? clause) + `(sequence + ,@(map p->r (sequence-clause-exprs clause)))))) + (class*/names-form-inst-clauses expr))))) + + (extend-parsed->raw interface-form? + (lambda (expr p->r) + `(interface ,(map p->r (interface-form-super-exprs expr)) + ,@(map sexp->raw (interface-form-variables expr))))) + + ) diff --git a/collects/zodiac/scm-ou.ss b/collects/zodiac/scm-ou.ss new file mode 100644 index 00000000..4d2dd58a --- /dev/null +++ b/collects/zodiac/scm-ou.ss @@ -0,0 +1,48 @@ +; $Id: scm-ou.ss,v 1.17 1999/02/02 19:33:15 mflatt Exp $ + +(unit/sig zodiac:scheme-objects+units^ + (import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^) + zodiac:sexp^ (pat : zodiac:pattern^) + zodiac:expander^ zodiac:interface^ + zodiac:scheme-core^ zodiac:scheme-main^ + zodiac:scheme-objects^ zodiac:scheme-units^) + + (let ((handler + (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) + (lambda (expr env attributes vocab) + (let loop ((r (resolve expr env vocab))) + (cond + ((lexical-binding? r) + (create-lexical-varref r expr)) + ((top-level-resolution? r) + (check-for-signature-name expr attributes) + (process-unit-top-level-resolution expr attributes)) + ((public-binding? r) + (create-public-varref r expr)) + ((override-binding? r) + (create-override-varref r expr)) + ((private-binding? r) + (create-private-varref r expr)) + ((inherit-binding? r) + (create-inherit-varref r expr)) + ((rename-binding? r) + (create-rename-varref r expr)) + ((supervar-binding? r) + (create-supervar-varref r expr)) + ((superinit-binding? r) + (create-superinit-varref r expr)) + ((or (macro-resolution? r) (micro-resolution? r)) + (if (and (inside-unit? attributes) + (check-export expr attributes)) + (loop top-level-resolution) + (static-error + expr + "Invalid use of keyword ~a" (z:symbol-orig-name expr)))) + (else + (internal-error expr "Invalid resolution in ou: ~s" r)))))))) + + (add-sym-micro full-vocabulary handler) + (add-sym-micro scheme-vocabulary handler) + (add-sym-micro unit-clauses-vocab-delta handler)) + + ) diff --git a/collects/zodiac/scm-spdy.ss b/collects/zodiac/scm-spdy.ss new file mode 100644 index 00000000..07877778 --- /dev/null +++ b/collects/zodiac/scm-spdy.ss @@ -0,0 +1,535 @@ +; $Id: scm-spdy.ss,v 1.42 1999/01/16 15:47:07 mflatt Exp $ + +(unit/sig zodiac:scheme-mrspidey^ + (import zodiac:misc^ (z : zodiac:structures^) + (z : zodiac:scanner-parameters^) + (z : zodiac:reader-structs^) + (z : zodiac:reader-code^) + zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ + zodiac:scheme-main^ zodiac:back-protocol^ + zodiac:expander^ zodiac:interface^ + (mzlib : mzlib:file^)) + + (define-struct (poly-form struct:parsed) (exp)) + (define-struct (:-form struct:parsed) (exp type)) + (define-struct (type:-form struct:parsed) (type attrs)) + (define-struct (st:control-form struct:parsed) (para val)) + (define-struct (reference-unit-form struct:parsed) + (file kind signed?)) + (define-struct (define-type-form struct:parsed) (sym type)) + (define-struct (define-constructor-form struct:parsed) (sym modes)) + + (define create-poly-form + (lambda (exp source) + (make-poly-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + exp))) + + (define create-:-form + (lambda (exp type source) + (make-:-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + exp type))) + + (define create-type:-form + (lambda (type attrs source) + (make-type:-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + type attrs))) + + (define create-st:control-form + (lambda (para val source) + (make-st:control-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + para val))) + + (define create-reference-unit-form + (lambda (file kind signed? source) + (make-reference-unit-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + file kind signed?))) + + (define create-define-type-form + (lambda (sym type source) + (make-define-type-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + sym type))) + + (define create-define-constructor-form + (lambda (sym modes source) + (make-define-constructor-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + sym modes))) + + ; -------------------------------------------------------------------- + + (define mrspidey-vocabulary + (create-vocabulary 'mrspidey-vocabulary full-vocabulary)) + + ; -------------------------------------------------------------------- + + (add-primitivized-micro-form 'polymorphic mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ p-expr)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((p-expr (pat:pexpand 'p-expr p-env kwd))) + (create-poly-form + (expand-expr p-expr env attributes vocab) + expr)))) + (else + (static-error expr "Malformed poly")))))) + + (add-primitivized-micro-form ': mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ :-expr type)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((:-expr (pat:pexpand ':-expr p-env kwd)) + (type (pat:pexpand 'type p-env kwd))) + (create-:-form + (expand-expr :-expr env attributes vocab) + (sexp->raw type) + expr)))) + (else + (static-error expr "Malformed :")))))) + + (add-primitivized-micro-form 'type: mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ type attr ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((type (pat:pexpand 'type p-env kwd)) + (attrs (pat:pexpand '(attr ...) p-env kwd))) + (create-type:-form + (sexp->raw type) + (map sexp->raw attrs) + expr)))) + (else + (static-error expr "Malformed type:")))))) + + (add-primitivized-micro-form 'mrspidey:control mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ para val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((para (pat:pexpand 'para p-env kwd)) + (val (pat:pexpand 'val p-env kwd))) + (create-st:control-form + (sexp->raw para) + (sexp->raw val) + expr)))) + (else + (static-error expr "Malformed mrspidey:control")))))) + + (add-primitivized-micro-form 'define-type mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ sym type)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((sym (pat:pexpand 'sym p-env kwd)) + (type (pat:pexpand 'type p-env kwd))) + (valid-syntactic-id? sym) + (create-define-type-form + (z:read-object sym) + (sexp->raw type) + expr)))) + (else + (static-error expr "Malformed define-type")))))) + + (add-primitivized-micro-form 'define-constructor mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ sym modes ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((sym (pat:pexpand 'sym p-env kwd)) + (modes (pat:pexpand '(modes ...) p-env kwd))) + (valid-syntactic-id? sym) + ; Cormac has an (assert-syn def (andmap boolean? modes)) + ; here. I only do the andmap z:boolean? part since + ; I have no idea what (assert-syn def ...) does. + (map (lambda (mode) + (unless (z:boolean? mode) + (static-error mode "Malformed mode"))) + modes) + (create-define-constructor-form + (z:read-object sym) + (map sexp->raw modes) + expr)))) + (else + (static-error expr "Malformed define-constructor")))))) + + (add-primitivized-micro-form 'reference-file mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern `(_ file)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((file (pat:pexpand 'file p-env kwd))) + (let ((f (expand-expr file env attributes vocab))) + (if (and (quote-form? f) + (z:string? (quote-form-expr f))) + (let* ((raw-filename (z:read-object (quote-form-expr f)))) + (let-values (((base name dir?) + (split-path raw-filename))) + (when dir? + (static-error file + "Cannot include a directory")) + (let* ((original-directory + (current-load-relative-directory)) + (p (with-handlers + ((exn:i/o:filesystem? + (lambda (exn) + (static-error file + "Unable to open file ~a" + raw-filename)))) + (open-input-file + (if (complete-path? raw-filename) + raw-filename + (build-path + (or original-directory + (current-directory)) + raw-filename)))))) + (dynamic-wind + (lambda () + (when (string? base) + (current-load-relative-directory + (if (complete-path? base) + base + (build-path (or original-directory + (current-directory)) + base))))) + (lambda () + (let ((reader + (z:read p + (z:make-location + (z:location-line + z:default-initial-location) + (z:location-column + z:default-initial-location) + (z:location-offset + z:default-initial-location) + (build-path + (current-load-relative-directory) + name))))) + (let ((code + (let loop () + (let ((input (reader))) + (if (z:eof? input) + '() + (cons input + (loop))))))) + (if (null? code) + (static-error expr "Empty file") + (expand-expr + (structurize-syntax + `(begin ,@code) + expr '(-1)) + env attributes vocab))))) + (lambda () + (current-load-relative-directory original-directory) + (close-input-port p)))))) + (static-error file "Does not yield a filename")))))) + (else + (static-error expr "Malformed reference-file")))))) + + (define reference-library/relative-maker + (lambda (form-name make-raw-filename) + (let* ((kwd '()) + (in-pattern '(_ filename collections ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd)) + (collections (pat:pexpand '(collections ...) p-env kwd))) + (let ((f (expand-expr filename env attributes vocab)) + (cs (map (lambda (c) + (expand-expr c env attributes vocab)) + collections))) + (unless (and (quote-form? f) + (z:string? (quote-form-expr f))) + (static-error filename "Does not yield a filename")) + (for-each + (lambda (c collection) + (unless (and (quote-form? c) + (z:string? (quote-form-expr c))) + (static-error collection "Does not yield a string"))) + cs collections) + (let* ((raw-f (z:read-object (quote-form-expr f))) + (raw-cs (map (lambda (c) + (z:read-object (quote-form-expr c))) + cs)) + (raw-filename + (if (relative-path? raw-f) + (or (make-raw-filename raw-f raw-cs expr) + (static-error filename + "No such library file found")) + (static-error f + "Library path ~s must be a relative path" + raw-f)))) + (let-values (((base name dir?) + (split-path raw-filename))) + (when dir? + (static-error filename + "Cannot include a directory")) + (let ((original-directory + (current-load-relative-directory)) + (original-collections + (current-require-relative-collection)) + (p (with-handlers + ((exn:i/o:filesystem? + (lambda (exn) + (static-error filename + "Unable to open file ~a" + raw-filename)))) + (open-input-file raw-filename)))) + (dynamic-wind + (lambda () + (current-require-relative-collection + (if (null? raw-cs) '("mzlib") raw-cs)) + (when (string? base) + (current-load-relative-directory base))) + (lambda () + (let ((reader + (z:read p + (z:make-location + (z:location-line + z:default-initial-location) + (z:location-column + z:default-initial-location) + (z:location-offset + z:default-initial-location) + (build-path + (current-load-relative-directory) + name))))) + (let ((code + (let loop () + (let ((input (reader))) + (if (z:eof? input) + '() + (cons input + (loop))))))) + (if (null? code) + (static-error expr "Empty file") + (expand-expr + (structurize-syntax + `(begin ,@code) + expr '(-1)) + env attributes vocab))))) + (lambda () + (current-load-relative-directory + original-directory) + (current-require-relative-collection + original-collections) + (close-input-port p)))))))))) + (else + (static-error expr (string-append "Malformed " + (symbol->string form-name))))))))) + + (add-primitivized-micro-form 'require-library mrspidey-vocabulary + (reference-library/relative-maker 'require-library + (lambda (raw-f raw-cs expr) + (apply mzlib:find-library raw-f raw-cs)))) + + (add-primitivized-micro-form 'require-relative-library mrspidey-vocabulary + (reference-library/relative-maker 'require-relative-library + (lambda (raw-f raw-cs expr) + (apply mzlib:find-library raw-f + (append (or (current-require-relative-collection) + (static-error expr + "No current collection for library \"~a\"" raw-f)) + raw-cs))))) + + (define reference-unit-maker + (lambda (form-name signed?) + (add-primitivized-micro-form form-name mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern `(_ file)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((file (pat:pexpand 'file p-env kwd))) + (let ((f (expand-expr file env attributes vocab))) + (if (and (quote-form? f) + (z:string? (quote-form-expr f))) + (create-reference-unit-form + (structurize-syntax + (path->complete-path (z:read-object + (quote-form-expr f)) + (or (current-load-relative-directory) + (current-directory))) + expr) + 'exp + signed? + expr) + (static-error file "Does not yield a filename")))))) + (else + (static-error expr "Malformed ~a" form-name)))))))) + + (reference-unit-maker 'require-unit #f) + (reference-unit-maker 'require-unit/sig #t) + + (define reference-library-unit-maker + (lambda (form-name sig? relative?) + (add-primitivized-micro-form form-name mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ filename collections ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd)) + (collections (pat:pexpand '(collections ...) + p-env kwd))) + (let ((f (expand-expr filename env attributes vocab)) + (cs (map (lambda (c) + (expand-expr c env attributes vocab)) + collections))) + (unless (and (quote-form? f) + (z:string? (quote-form-expr f))) + (static-error filename "Does not yield a filename")) + (for-each + (lambda (c collection) + (unless (and (quote-form? c) + (z:string? (quote-form-expr c))) + (static-error collection + "Does not yield a string"))) + cs collections) + (let ((raw-f (z:read-object (quote-form-expr f))) + (raw-cs (map (lambda (c) + (z:read-object + (quote-form-expr c))) + cs))) + (unless (relative-path? raw-f) + (static-error f + "Library path ~s must be a relative path" + raw-f)) + (create-reference-unit-form + (structurize-syntax + (path->complete-path + (or (apply mzlib:find-library raw-f + (if relative? + (append (or (current-require-relative-collection) + null) + raw-cs) + raw-cs)) + (static-error expr + "Unable to locate library ~a in collection path ~a" + raw-f + (if (null? raw-cs) "mzlib" raw-cs))) + (or (current-load-relative-directory) + (current-directory))) + expr) + 'exp + sig? + expr)))))) + (else + (static-error expr + (string-append "Malformed ~a" form-name))))))))) + + (reference-library-unit-maker 'require-library-unit #f #f) + (reference-library-unit-maker 'require-library-unit/sig #t #f) + (reference-library-unit-maker 'require-relative-library-unit #f #t) + (reference-library-unit-maker 'require-relative-library-unit/sig #t #t) + +' (add-primitivized-micro-form 'references-unit-imports mrspidey-vocabulary + (let* ((kwd '()) + (in-pattern '(_ file)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((file (pat:pexpand 'file p-env kwd))) + (create-reference-unit-form + file + (current-directory) + 'imp + expr)))) + (else + (static-error expr "Malformed require-unit-imports")))))) + + ; -------------------------------------------------------------------- + + (extend-parsed->raw poly-form? + (lambda (expr p->r) + `(polymorphic ,(p->r (poly-form-exp expr))))) + + (extend-parsed->raw :-form? + (lambda (expr p->r) + `(: ,(p->r (:-form-exp expr)) ,(:-form-type expr)))) + + (extend-parsed->raw type:-form? + (lambda (expr p->r) + `(type: ,(type:-form-type expr) ,@(type:-form-attrs expr)))) + + (extend-parsed->raw st:control-form? + (lambda (expr p->r) + `(mrspidey:control ,(st:control-form-para expr) + ,(st:control-form-val expr)))) + + (extend-parsed->raw reference-unit-form? + (lambda (expr p->r) + (case (reference-unit-form-kind expr) + ((exp) `(,(if (reference-unit-form-signed? expr) + 'require-unit/sig + 'require-unit) + ,(sexp->raw (reference-unit-form-file expr)))) + ((imp) `(require-unit-imports + ,(sexp->raw (reference-unit-form-file expr)))) + (else (internal-error 'require-unit-form "Invalid kind"))))) + + (extend-parsed->raw define-type-form? + (lambda (expr p->r) + `(define-type ,(define-type-form-sym expr) + ,(define-type-form-type expr)))) + + (extend-parsed->raw define-constructor-form? + (lambda (expr p->r) + `(define-constructor-form ,(define-constructor-form-sym expr) + ,@(define-constructor-form-modes expr)))) + + ) diff --git a/collects/zodiac/scm-unit.ss b/collects/zodiac/scm-unit.ss new file mode 100644 index 00000000..6fe18a3b --- /dev/null +++ b/collects/zodiac/scm-unit.ss @@ -0,0 +1,1168 @@ +; $Id: scm-unit.ss,v 1.86 1999/05/21 12:53:30 mflatt Exp $ + +(unit/sig zodiac:scheme-units^ + (import zodiac:misc^ (z : zodiac:structures^) + (z : zodiac:scanner-parameters^) + (z : zodiac:reader-structs^) + (z : zodiac:reader-code^) + zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ + zodiac:scheme-main^ zodiac:scheme-objects^ zodiac:back-protocol^ + zodiac:expander^ zodiac:interface^) + + (define-struct (unit-form struct:parsed) + (imports exports clauses)) + + (define-struct (compound-unit-form struct:parsed) + (imports links exports)) + + (define-struct (invoke-unit-form struct:parsed) + (unit variables)) + + (define create-unit-form + (lambda (imports exports clauses source) + (make-unit-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + imports exports clauses))) + + (define create-compound-unit-form + (lambda (imports links exports source) + (make-compound-unit-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + imports links exports))) + + (define create-invoke-unit-form + (lambda (unit variables source) + (make-invoke-unit-form (z:zodiac-origin source) + (z:zodiac-start source) (z:zodiac-finish source) + (make-empty-back-box) + unit variables))) + + ; -------------------------------------------------------------------- + + (define (make-put-get-remove attr) + (define put + (lambda (attributes v) + (put-attribute + attributes attr + (cons v + (get-attribute attributes attr + (lambda () null)))))) + (define get + (lambda (attributes) + (car (get-attribute attributes attr)))) + (define remove + (lambda (attributes) + (put-attribute + attributes attr + (cdr (get-attribute attributes attr))))) + (values put get remove)) + + (define-values (put-c-unit-vocab-attribute + get-c-unit-vocab-attribute + remove-c-unit-vocab-attribute) + (make-put-get-remove 'c-unit-link-import/body-vocab)) + + + (define-values (put-c-unit-current-link-tag-attribute + get-c-unit-current-link-tag-attribute + remove-c-unit-current-link-tag-attribute) + (make-put-get-remove 'c-unit-current-link-tag-attribute)) + + (define-values (put-c-unit-expand-env + get-c-unit-expand-env + remove-c-unit-expand-env) + (make-put-get-remove 'c-unit-expand-env)) + + (define-values (put-vars-attribute + get-vars-attribute + remove-vars-attribute) + (make-put-get-remove 'unit-vars)) + (define (make-vars-attribute attributes) + (put-vars-attribute attributes (make-hash-table))) + + (define-struct unresolved (id varref)) + + (define make-unresolved-attribute + (lambda (attributes) + (put-attribute attributes 'unresolved-unit-vars + (cons '() + (get-attribute attributes + 'unresolved-unit-vars (lambda () '())))))) + + (define get-unresolved-attribute + (lambda (attributes) + (car (get-attribute attributes 'unresolved-unit-vars)))) + + (define update-unresolved-attribute + (lambda (attributes id varref) + (let ((new-value (make-unresolved id varref)) + (current (get-attribute attributes 'unresolved-unit-vars + (lambda () '())))) ; List of lists to accomodate + ; nested units + (unless (null? current) + (put-attribute attributes 'unresolved-unit-vars + (cons + (cons new-value (car current)) + (cdr current))))))) + + (define remove/update-unresolved-attribute + (lambda (attributes unresolveds) + (let ((left-unresolveds + (cdr (get-attribute attributes + 'unresolved-unit-vars)))) + (if (null? left-unresolveds) + (begin + (put-attribute attributes 'unresolved-unit-vars null) + (unless (null? unresolveds) + (let ([id (unresolved-id (car unresolveds))]) + (check-for-signature-name id attributes) + (static-error (unresolved-id (car unresolveds)) + "Unbound unit identifier ~a" + (z:read-object id))))) + (put-attribute attributes 'unresolved-unit-vars + (cons (append unresolveds (car left-unresolveds)) + (cdr left-unresolveds))))))) + + ; -------------------------------------------------------------------- + + (define-struct unit-id (id)) + (define-struct (import-id struct:unit-id) ()) + (define-struct (export-id struct:unit-id) (defined?)) + (define-struct (internal-id struct:unit-id) ()) + (define-struct (link-id struct:unit-id) ()) + + (define register-links + (lambda (ids attributes) + (map + (lambda (id) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (cond + ((not entry) + (hash-table-put! id-table id-name + (make-link-id id))) + ((link-id? entry) + (static-error id "Duplicate link name")) + (else + (internal-error entry "Invalid in register-links")))))) + ids))) + + (define check-link + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (link-id? entry))))) + + (define check-import + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (import-id? entry))))) + + (define inside-unit? + (lambda (attributes) + (not (null? (get-attribute attributes 'unit-vars + (lambda () null)))))) + + (define check-export + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (export-id? entry))))) + + (define register-import + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (cond + ((not entry) + (hash-table-put! id-table id-name + (make-import-id id))) + ((import-id? entry) + (static-error id "Duplicate import identifier ~a" id-name)) + ((export-id? entry) + (static-error id "Exported identifier ~a being imported" + id-name)) + ((internal-id? entry) + (static-error id + "Defined identifier ~a being imported" id-name)) + (else + (internal-error entry + "Invalid in register-import/export"))))))) + + (define register-definitions + (lambda (ids attributes) + (map + (lambda (id) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (cond + ((not entry) + (hash-table-put! id-table id-name + (make-internal-id id))) + ((import-id? entry) + (static-error id "Redefined imported identifier ~a" id-name)) + ((export-id? entry) + (if (export-id-defined? entry) + (static-error id "Redefining exported identifier ~a" + id-name) + (set-export-id-defined?! entry #t))) + ((internal-id? entry) + (static-error id "Duplicate internal definition for ~a" + id-name)) + (else + (internal-error entry + "Invalid entry in register-definitions")))))) + ids))) + + (define register-export + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (cond + ((not entry) + (hash-table-put! id-table id-name + (make-export-id id #f))) + ((import-id? entry) + (static-error id "Imported identifier ~a being exported" + id-name)) + ((export-id? entry) + (static-error id "Duplicate export identifier ~a" id-name)) + ((internal-id? entry) + (internal-error entry + "Should not have had an internal-id in register-export")) + (else + (internal-error entry + "Invalid in register-import/export"))))))) + + (define verify-export + (lambda (id attributes) + (let ((id-table (get-vars-attribute attributes)) + (id-name (z:read-object id))) + (let ((entry (hash-table-get id-table id-name + (lambda () #f)))) + (cond + ((not entry) + (static-error id "Exported identifier ~a not defined" + id-name)) + ((import-id? entry) + (static-error id "Imported identifier ~a being exported" + id-name)) + ((export-id? entry) + (unless (export-id-defined? entry) + (static-error id "Exported identifier ~a not defined" + id-name))) + ((internal-id? entry) + (internal-error entry + "Should not have had an internal-id in verify-export")) + (else + (internal-error entry + "Invalid in register-import/export"))))))) + + (define get-unresolved-vars + (lambda (attributes) + (let ((id-table (get-vars-attribute attributes)) + (top-level-space (get-attribute attributes 'top-levels)) + (unresolveds (get-unresolved-attribute attributes))) + (let loop ((remaining unresolveds) + (unr null)) + (if (null? remaining) unr + (let* ((u (car remaining)) + (uid (unresolved-id u))) + (let ((entry (hash-table-get id-table + (z:read-object uid) (lambda () #f)))) + (cond + ((or (internal-id? entry) (export-id? entry)) + ; Need to set the box here + (when (top-level-varref/bind? (unresolved-varref u)) + (let* ([id (unit-id-id entry)] + [box (and top-level-space + (hash-table-get top-level-space + (z:read-object uid) + (lambda () + (internal-error + entry + "Can't find box in get-unresolved-vars"))))]) + (set-top-level-varref/bind-slot! + (unresolved-varref u) + box) + (set-top-level-varref/bind/unit-unit?! + (unresolved-varref u) + #t))) + (loop (cdr remaining) unr)) + ((import-id? entry) + (loop (cdr remaining) unr)) + ((not entry) + (loop (cdr remaining) (cons u unr))) + (else + (internal-error entry + "Invalid in get-unresolved-vars")))))))))) + + ; ---------------------------------------------------------------------- + + (define c/imports-vocab + (create-vocabulary 'c/imports-vocab #f + "Invalid import declaration" + "Invalid import declaration" + "Invalid import declaration" + "Invalid import declaration")) + + (add-sym-micro c/imports-vocab + (lambda (expr env attributes vocab) + (register-import expr attributes) + (create-lexical-binding+marks expr))) + + ; ---------------------------------------------------------------------- + + (define unit-register-exports-vocab + (create-vocabulary 'unit-register-exports-vocab #f + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration")) + + (add-sym-micro unit-register-exports-vocab + (lambda (expr env attributes vocab) + (register-export expr attributes))) + + (add-list-micro unit-register-exports-vocab + (let* ((kwd '()) + (in-pattern '(internal-id external-id)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((internal (pat:pexpand 'internal-id p-env kwd)) + (external (pat:pexpand 'external-id p-env kwd))) + (valid-syntactic-id? internal) + (valid-syntactic-id? external) + (register-export internal attributes)))) + (else + (static-error expr "Malformed export declaration")))))) + + ;; ---------------------------------------------------------------------- + + (define unit-generate-external-names-vocab + (create-vocabulary 'unit-generate-external-names-vocab #f + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration")) + + (add-sym-micro unit-generate-external-names-vocab + (lambda (expr env attributes vocab) + expr)) + + (add-list-micro unit-generate-external-names-vocab + (let* ((kwd '()) + (in-pattern '(internal-id external-id)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (pat:pexpand 'external-id p-env kwd))) + (else + (static-error expr "Malformed export declaration")))))) + + ;; -------------------------------------------------------------------- + + (define unit-verify-exports-vocab + (create-vocabulary 'unit-verify-exports-vocab #f + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration" + "Invalid export declaration")) + + (add-sym-micro unit-verify-exports-vocab + (lambda (expr env attributes vocab) + (verify-export expr attributes) + (let ((expand-vocab (get-attribute attributes 'exports-expand-vocab))) + (cons (process-unit-top-level-resolution expr attributes) + expr)))) + + (add-list-micro unit-verify-exports-vocab + (let* ((kwd '()) + (in-pattern '(internal-id external-id)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((internal (pat:pexpand 'internal-id p-env kwd)) + (external (pat:pexpand 'external-id p-env kwd))) + (verify-export internal attributes) + (let ((expand-vocab (get-attribute attributes + 'exports-expand-vocab))) + (cons (process-unit-top-level-resolution internal attributes) + external))))) + (else + (static-error expr "Malformed export declaration")))))) + + ; ---------------------------------------------------------------------- + + (define (fixup-shadowed-varrefs exprs exports env attributes vocab) + (let ([shadowed (let loop ([exports exports]) + (if (null? exports) + null + (let ([r (resolve (car exports) env vocab)] + [rest (loop (cdr exports))]) + (if (binding? r) + (cons (cons + r + (lambda () + (process-unit-top-level-resolution + (car exports) + attributes))) + rest) + rest))))]) + (if (null? shadowed) + exprs + (begin + (map + (lambda (expr) + (fixup expr shadowed)) + exprs))))) + + ;; Yuck - traverse and patch expressions to fix varrefs pointing to + ;; lexical bindings that are shadowed by unit definitions. + + (define (fixup expr binding-map) + (let fix ([expr expr]) + (if (bound-varref? expr) + (let ([fixed (assoc (bound-varref-binding expr) binding-map)]) + (if fixed + ((cdr fixed)) + expr)) + (begin + (cond + [(not expr) expr] + [(varref? expr) expr] + [(quote-form? expr) expr] + [(app? expr) + (set-app-fun! expr (fix (app-fun expr))) + (set-app-args! expr (map fix (app-args expr)))] + [(struct-form? expr) + (set-struct-form-super! expr (fix (struct-form-super expr)))] + [(if-form? expr) + (set-if-form-test! expr (fix (if-form-test expr))) + (set-if-form-then! expr (fix (if-form-then expr))) + (set-if-form-else! expr (fix (if-form-else expr)))] + [(begin-form? expr) + (set-begin-form-bodies! expr (map fix (begin-form-bodies expr)))] + [(begin0-form? expr) + (set-begin0-form-bodies! expr (map fix (begin0-form-bodies expr)))] + [(let-values-form? expr) + (set-let-values-form-vals! expr (map fix (let-values-form-vals expr))) + (set-let-values-form-body! expr (fix (let-values-form-body expr)))] + [(letrec-values-form? expr) + (set-letrec-values-form-vals! expr (map fix (letrec-values-form-vals expr))) + (set-letrec-values-form-body! expr (fix (letrec-values-form-body expr)))] + [(define-values-form? expr) + (set-define-values-form-val! expr (fix (define-values-form-val expr)))] + [(set!-form? expr) + (set-set!-form-var! expr (fix (set!-form-var expr))) + (set-set!-form-val! expr (fix (set!-form-val expr)))] + [(case-lambda-form? expr) + (set-case-lambda-form-bodies! expr (map fix (case-lambda-form-bodies expr)))] + [(with-continuation-mark-form? expr) + (set-with-continuation-mark-form-key! expr (fix (with-continuation-mark-form-key expr))) + (set-with-continuation-mark-form-val! expr (fix (with-continuation-mark-form-val expr))) + (set-with-continuation-mark-form-body! expr (fix (with-continuation-mark-form-body expr)))] + [(class*/names-form? expr) + (for-each + (lambda (clause) + (cond + [(public-clause? clause) + (set-public-clause-exprs! clause (map fix (public-clause-exprs clause)))] + [(private-clause? clause) + (set-private-clause-exprs! clause (map fix (private-clause-exprs clause)))] + [(sequence-clause? clause) + (set-sequence-clause-exprs! clause (map fix (sequence-clause-exprs clause)))] + [else (void)])) + (class*/names-form-inst-clauses expr))] + [(interface-form? expr) + (set-interface-form-super-exprs! expr (map fix (interface-form-super-exprs expr)))] + [(unit-form? expr) + (set-unit-form-clauses! expr (map fix (unit-form-clauses expr)))] + [(compound-unit-form? expr) + (for-each + (lambda (link) + (set-car! (cdr link) (fix (cadr link)))) + (compound-unit-form-links expr))] + [(invoke-unit-form? expr) + (set-invoke-unit-form-unit! expr (fix (invoke-unit-form-unit expr))) + (set-invoke-unit-form-variables! expr (map fix (invoke-unit-form-variables expr)))] + [else + (internal-error expr "Cannot fix unknown form: ~s" expr)]) + expr)))) + + ; ---------------------------------------------------------------------- + + (define unit-micro + (let* ((kwd `(import export)) + (in-pattern `(_ + (import imports ...) + (export exports ...) + clauses ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ([top-level? (get-top-level-status attributes)] + [internal? (get-internal-define-status attributes)] + [old-top-level (get-attribute attributes 'top-levels)] + [old-delay (get-attribute attributes 'delay-sig-name-check?)] + [unit-clauses-vocab + (append-vocabulary unit-clauses-vocab-delta + vocab 'unit-clauses-vocab)]) + (dynamic-wind + void + (lambda () + (set-top-level-status attributes #t) + (set-internal-define-status attributes #f) + (put-attribute attributes 'top-levels (make-hash-table)) + (put-attribute attributes 'delay-sig-name-check? #t) + (let ((in:imports (pat:pexpand '(imports ...) p-env kwd)) + (in:exports (pat:pexpand '(exports ...) p-env kwd)) + (in:clauses (pat:pexpand '(clauses ...) p-env kwd))) + (make-vars-attribute attributes) + (make-unresolved-attribute attributes) + (let* ((proc:imports (map (lambda (e) + (expand-expr e env + attributes c/imports-vocab)) + in:imports)) + (_ (extend-env proc:imports env)) + (_ (put-attribute attributes 'exports-expand-vocab + unit-clauses-vocab)) + (_ (for-each (lambda (e) + (expand-expr e env attributes + unit-register-exports-vocab)) + in:exports)) + (proc:clauses (map (lambda (e) + (expand-expr e env + attributes + unit-clauses-vocab)) + in:clauses)) + (_ (retract-env (map car proc:imports) env)) + (proc:exports (map (lambda (e) + (expand-expr e env + attributes + unit-verify-exports-vocab)) + in:exports)) + (proc:exports-externals + (map (lambda (e) + (expand-expr e env attributes + unit-generate-external-names-vocab)) + in:exports)) + (unresolveds (get-unresolved-vars attributes)) + (fixed-proc:clauses (fixup-shadowed-varrefs + proc:clauses + (hash-table-map + (get-vars-attribute attributes) + (lambda (key val) (unit-id-id val))) + env + attributes + vocab))) + + (put-attribute attributes 'delay-sig-name-check? old-delay) + + (distinct-valid-syntactic-id/s? proc:exports-externals) + (remove-vars-attribute attributes) + (remove/update-unresolved-attribute attributes + unresolveds) + (set-top-level-status attributes top-level?) + (set-internal-define-status attributes internal?) + (put-attribute attributes 'exports-expand-vocab #f) + + (create-unit-form + (map car proc:imports) + proc:exports + fixed-proc:clauses + expr)))) + (lambda () (put-attribute attributes 'top-levels old-top-level)))))) + (else + (static-error expr "Malformed unit")))))) + + (add-primitivized-micro-form 'unit full-vocabulary unit-micro) + (add-primitivized-micro-form 'unit scheme-vocabulary unit-micro) + + ; ---------------------------------------------------------------------- + + (define c-unit-link-import-vocab + (create-vocabulary 'c-unit-link-import-vocab #f + "Invalid link import declaration" + "Invalid link import declaration" + "Invalid link import declaration" + "Invalid link import declaration")) + + (add-sym-micro c-unit-link-import-vocab + (lambda (expr env attributes vocab) + (if (check-import expr attributes) + (list (expand-expr expr env attributes + (get-c-unit-vocab-attribute attributes))) + (static-error expr "~a: Not an imported identifier" + (z:read-object expr))))) + + (add-list-micro c-unit-link-import-vocab + (let* ((kwd '()) + (in-pattern '(tag id ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (ids (pat:pexpand '(id ...) p-env kwd))) + (when #f ; we allow self-import, now + (when (eq? (z:read-object tag) + (get-c-unit-current-link-tag-attribute + attributes)) + (static-error expr "Self-import of tag ~a" + (z:read-object tag)))) + (map (lambda (id) (cons tag id)) ids)))) + (else + (static-error expr "Invalid link syntax")))))) + + (define c-unit-link-body-vocab + (create-vocabulary 'c-unit-link-body-vocab #f + "Invalid link body declaration" + "Invalid link body declaration" + "Invalid link body declaration" + "Invalid link body declaration")) + + (add-list-micro c-unit-link-body-vocab + (let* ((kwd '()) + (in-pattern '(sub-unit-expr imported-var ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((sub-unit-expr (pat:pexpand 'sub-unit-expr p-env kwd)) + (imported-vars + (pat:pexpand '(imported-var ...) p-env kwd))) + (cons (expand-expr sub-unit-expr + (get-c-unit-expand-env attributes) + attributes + (get-c-unit-vocab-attribute attributes)) + (map (lambda (imported-var) + (expand-expr imported-var env attributes + c-unit-link-import-vocab)) + imported-vars))))) + (else + (static-error expr "Invalid linkage body")))))) + + (define c-unit-exports-vocab + (create-vocabulary 'c-unit-exports-vocab #f + "Invalid unit export declaration" + "Invalid unit export declaration" + "Invalid unit export declaration" + "Invalid unit export declaration")) + + (add-sym-micro c-unit-exports-vocab + (lambda (expr env attributes vocab) + (cons expr expr))) + + (add-list-micro c-unit-exports-vocab + (let* ((kwd '()) + (in-pattern '(internal-id external-id)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((internal-id (pat:pexpand 'internal-id p-env kwd)) + (external-id (pat:pexpand 'external-id p-env kwd))) + (valid-syntactic-id? internal-id) + (valid-syntactic-id? external-id) + (cons internal-id external-id)))) + (else + (static-error expr "Invalid export clause")))))) + + (define c-unit-export-clause-vocab + (create-vocabulary 'c-unit-export-clause-vocab #f + "Invalid export clause declaration" + "Invalid export clause declaration" + "Invalid export clause declaration" + "Invalid export clause declaration")) + + (add-list-micro c-unit-export-clause-vocab + (let* ((kwd '()) + (in-pattern '(tag exports ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((tag (pat:pexpand 'tag p-env kwd)) + (exports (pat:pexpand '(exports ...) p-env kwd))) + (valid-syntactic-id? tag) + (if (check-link tag attributes) + (map (lambda (e) + (cons tag + (expand-expr e env attributes + c-unit-exports-vocab))) + exports) + (static-error tag "Not a valid tag"))))) + (else + (static-error expr "Invalid export clause")))))) + + (define compound-unit-micro + (let* ((kwd `(import link export)) + (in-pattern `(_ + (import imports ...) + (link + (link-tag link-body) ...) + (export export-clause ...))) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((in:imports (pat:pexpand '(imports ...) p-env kwd)) + (in:link-tags (pat:pexpand '(link-tag ...) p-env kwd)) + (in:link-bodies + (pat:pexpand '(link-body ...) p-env kwd)) + (in:export-clauses + (pat:pexpand '(export-clause ...) p-env kwd))) + (distinct-valid-syntactic-id/s? in:link-tags) + (make-vars-attribute attributes) + (put-c-unit-vocab-attribute attributes vocab) + (put-c-unit-expand-env attributes (copy-env env)) + (let* ((proc:imports (map (lambda (e) + (expand-expr e env + attributes c/imports-vocab)) + in:imports)) + (_ (extend-env proc:imports env)) + (_ (register-links in:link-tags attributes)) + (raw-link-clauses (map z:read-object in:link-tags)) + (proc:link-clauses + (map (lambda (link-tag link-body) + (let ((this-tag (z:read-object link-tag))) + (put-c-unit-current-link-tag-attribute + attributes this-tag) + (let ((expanded-body + (as-nested + attributes + (lambda () + (expand-expr link-body env + attributes + c-unit-link-body-vocab))))) + (let ((unit-expr (car expanded-body)) + (unit-args (apply append + (cdr expanded-body)))) + (let loop ((args unit-args)) + (if (null? args) + (begin + (remove-c-unit-current-link-tag-attribute + attributes) + (cons link-tag + (cons unit-expr unit-args))) + (begin + (if (pair? (car args)) + (let ((arg (caar args))) + (if (z:symbol? arg) + (when (not (memq (z:read-object arg) + raw-link-clauses)) + (static-error arg + "Not a valid tag")) + (static-error arg + "Tag must be a symbol")))) + (loop (cdr args))))))))) + in:link-tags in:link-bodies)) + (proc:export-clauses + (apply append + (map (lambda (e) + (expand-expr e env + attributes c-unit-export-clause-vocab)) + in:export-clauses))) + (_ (retract-env (map car proc:imports) env))) + (remove-c-unit-vocab-attribute attributes) + (remove-c-unit-expand-env attributes) + (remove-vars-attribute attributes) + (create-compound-unit-form + (map car proc:imports) + proc:link-clauses + proc:export-clauses + expr))))) + (else + (static-error expr "Malformed compound-unit")))))) + + (add-primitivized-micro-form 'compound-unit full-vocabulary compound-unit-micro) + (add-primitivized-micro-form 'compound-unit scheme-vocabulary compound-unit-micro) + + ; -------------------------------------------------------------------- + + (define invoke-unit-micro + (let* ((kwd '()) + (in-pattern `(_ unit vars ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((unit (pat:pexpand 'unit p-env kwd)) + (vars (pat:pexpand '(vars ...) p-env kwd))) + (valid-syntactic-id/s? vars) + (let* ((expr-expr + (as-nested + attributes + (lambda () + (expand-expr unit env attributes vocab)))) + (var-exprs + (map (lambda (e) + (expand-expr e env + attributes vocab)) + vars))) + (create-invoke-unit-form + expr-expr + var-exprs + expr))))) + (else + (static-error expr "Malformed invoke-unit")))))) + + (add-primitivized-micro-form 'invoke-unit full-vocabulary invoke-unit-micro) + (add-primitivized-micro-form 'invoke-unit scheme-vocabulary invoke-unit-micro) + + ; -------------------------------------------------------------------- + + (extend-parsed->raw unit-form? + (lambda (expr p->r) + `(unit (import ,@(map p->r (unit-form-imports expr))) + (export ,@(map (lambda (e) + `(,(p->r (car e)) ,(sexp->raw (cdr e)))) + (unit-form-exports expr))) + ,@(map p->r (unit-form-clauses expr))))) + + (extend-parsed->raw compound-unit-form? + (lambda (expr p->r) + `(compound-unit + (import ,@(map p->r (compound-unit-form-imports expr))) + (link + ,@(map (lambda (link-clause) + (let ((tag (car link-clause)) + (sub-unit (cadr link-clause)) + (imports (map (lambda (import) + (if (lexical-varref? import) + (p->r import) + `(,(sexp->raw (car import)) + ,(sexp->raw (cdr import))))) + (cddr link-clause)))) + `(,(sexp->raw tag) + (,(p->r sub-unit) + ,@imports)))) + (compound-unit-form-links expr))) + (export + ,@(map (lambda (export-clause) + `(,(sexp->raw (car export-clause)) + (,(sexp->raw (cadr export-clause)) + ,(sexp->raw (cddr export-clause))))) + (compound-unit-form-exports expr)))))) + + (extend-parsed->raw invoke-unit-form? + (lambda (expr p->r) + `(invoke-unit ,(p->r (invoke-unit-form-unit expr)) + ,@(map p->r (invoke-unit-form-variables expr))))) + + ; ---------------------------------------------------------------------- + + (define unit-clauses-vocab-delta + (create-vocabulary 'unit-clauses-vocab-delta)) + + (let* ((kwd '()) + (in-pattern-1 `(_ (var ...) val)) + (m&e-1 (pat:make-match&env in-pattern-1 kwd))) + (let ((define-values-helper + (lambda (handler) + (lambda (expr env attributes vocab) + (unless (at-top-level? attributes) + (static-error expr + "Invalid definition: must be at the top level")) + (cond + ((pat:match-against m&e-1 expr env) + => + (lambda (p-env) + (let* ((top-level? (get-top-level-status + attributes)) + (_ (set-top-level-status + attributes)) + (vars (pat:pexpand '(var ...) + p-env kwd)) + (_ (map valid-syntactic-id? vars)) + (_ (for-each + (lambda (var) + (let ((r (resolve var env vocab))) + (when (or (micro-resolution? r) + (macro-resolution? r)) + (unless (check-export var attributes) + (static-error var + "Cannot bind keyword ~s" + (z:symbol-orig-name var)))))) + vars)) + (out (handler expr env attributes + vocab p-env vars))) + (set-top-level-status attributes + top-level?) + out))) + (else (static-error expr "Malformed define-values"))))))) + + (add-primitivized-micro-form 'define-values unit-clauses-vocab-delta + (define-values-helper + (lambda (expr env attributes vocab p-env vars) + (register-definitions vars attributes) + (let* ((id-exprs (map (lambda (v) + (let ((parsed + (expand-expr v env attributes + define-values-id-parse-vocab))) + parsed)) + vars)) + (expr-expr (expand-expr + (pat:pexpand 'val p-env kwd) + env attributes vocab))) + (create-define-values-form id-exprs expr-expr expr))))))) + + (define define-values-id-parse-vocab + (create-vocabulary 'define-values-id-parse-vocab #f + "Invalid in identifier position" + "Invalid in identifier position" + "Invalid in identifier position" + "Invalid in identifier position")) + + (add-sym-micro define-values-id-parse-vocab + (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) + (lambda (expr env attributes vocab) + (let ((id (z:read-object expr))) + (let ((top-level-space (get-attribute attributes 'top-levels))) + (if top-level-space + (begin + (let ((ref + (create-top-level-varref/bind/unit + id + (hash-table-get top-level-space id + (lambda () + (let ((b (box '()))) + (hash-table-put! top-level-space id b) + b))) + expr))) + ;; Define a unit-bound variable => mark this and pre-existing as unit + (set-top-level-varref/bind/unit-unit?! ref #t) + (let ((b (top-level-varref/bind-slot ref))) + (map (lambda (r) (set-top-level-varref/bind/unit-unit?! r #t)) (unbox b)) + (set-box! b (cons ref (unbox b)))) + ref)) + (create-top-level-varref id expr))))))) + + (add-primitivized-micro-form 'set! unit-clauses-vocab-delta + (let* ((kwd '()) + (in-pattern `(_ var val)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (let ((p-env (pat:match-against m&e expr env))) + (if p-env + (let* ((top-level? (get-top-level-status attributes)) + (_ (set-top-level-status attributes)) + (var-p (pat:pexpand 'var p-env kwd)) + (_ (valid-syntactic-id? var-p)) + (id-expr (expand-expr var-p env attributes vocab)) + (expr-expr (expand-expr + (pat:pexpand 'val p-env kwd) + env attributes vocab))) + (when (check-import var-p attributes) + (static-error var-p "Mutating imported identifier")) + (set-top-level-status attributes top-level?) + (create-set!-form id-expr expr-expr expr)) + (static-error expr "Malformed set!")))))) + + (define process-unit-top-level-resolution + (lambda (expr attributes) + (let ([varref + (process-top-level-resolution expr attributes)]) + (let ([id (z:read-object expr)]) + (unless (built-in-name id) + (update-unresolved-attribute attributes expr varref))) + varref))) + + (add-sym-micro unit-clauses-vocab-delta + (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) + (lambda (expr env attributes vocab) + (let loop ((r (resolve expr env vocab))) + (cond + ((or (macro-resolution? r) (micro-resolution? r)) + (if (check-export expr attributes) + (loop top-level-resolution) + (static-error expr + "Invalid use of keyword ~a" (z:symbol-orig-name expr)))) + ((lexical-binding? r) + (create-lexical-varref r expr)) + ((top-level-resolution? r) + (check-for-signature-name expr attributes) + (process-unit-top-level-resolution expr attributes)) + (else + (internal-error expr "Invalid resolution in unit delta: ~s" + r))))))) + + ; -------------------------------------------------------------------- + + (include "scm-hanc.ss") + + ; -------------------------------------------------------------------- + + (define reference-unit-maker + (lambda (form-name sig?) + (let ([micro + (let* ((kwd '()) + (in-pattern `(_ filename)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd))) + (let ((f (expand-expr filename env attributes vocab))) + (if (and (quote-form? f) + (z:string? (quote-form-expr f))) + (expand-expr + (structurize-syntax + `(let ((result (#%load/use-compiled + ,(quote-form-expr f)))) + (unless (,(if sig? + '#%unit/sig? + '#%unit?) + result) + (#%raise + (#%make-exn:unit + ,(format + "~s: result from ~s is not ~aunit" + form-name + (sexp->raw (quote-form-expr f)) + (if sig? "signed " "")) + (#%current-continuation-marks)))) + result) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab) + (static-error filename + "Does not yield a filename")))))) + (else + (static-error expr "Malformed ~a" form-name)))))]) + (add-primitivized-micro-form form-name full-vocabulary micro) + (add-on-demand-form 'micro form-name common-vocabulary micro)))) + + (reference-unit-maker 'require-unit #f) + (reference-unit-maker 'require-unit/sig #t) + + (define reference-library-unit-maker + (lambda (form-name sig? relative?) + (let ([micro + (let* ((kwd '()) + (in-pattern '(_ filename collections ...)) + (m&e (pat:make-match&env in-pattern kwd))) + (lambda (expr env attributes vocab) + (cond + ((pat:match-against m&e expr env) + => + (lambda (p-env) + (let ((filename (pat:pexpand 'filename p-env kwd)) + (collections (pat:pexpand '(collections ...) + p-env kwd))) + (let ((f (expand-expr filename env attributes vocab)) + (cs (map (lambda (c) + (expand-expr c env attributes vocab)) + collections))) + (unless (and (quote-form? f) + (z:string? (quote-form-expr f))) + (static-error filename "Does not yield a filename")) + (for-each + (lambda (c collection) + (unless (and (quote-form? c) + (z:string? (quote-form-expr c))) + (static-error collection + "Does not yield a string"))) + cs collections) + (let ((raw-f (z:read-object (quote-form-expr f))) + (raw-cs (map (lambda (c) + (z:read-object + (quote-form-expr c))) + cs))) + (unless (relative-path? raw-f) + (static-error f + "Library path ~s must be a relative path" + raw-f)) + (expand-expr + (structurize-syntax + `(let ((result (,(if relative? + '#%require-relative-library + '#%require-library) + ,(quote-form-expr f) + ,@(map quote-form-expr cs)))) + (unless (,(if sig? '#%unit/sig? '#%unit?) + result) + (#%raise + (#%make-exn:unit + ,(format + "~s: result from ~s in collection ~a not a ~aunit" + form-name + raw-f + (if (null? raw-cs) + '"mzlib" + raw-cs) + (if sig? "signed " "")) + (#%current-continuation-marks)))) + result) + expr '(-1) + #f + (z:make-origin 'micro expr)) + env attributes vocab)))))) + (else + (static-error expr + (string-append "Malformed ~a" form-name))))))]) + (add-primitivized-micro-form form-name full-vocabulary micro) + (add-on-demand-form 'micro form-name common-vocabulary micro)))) + + (reference-library-unit-maker 'require-library-unit #f #f) + (reference-library-unit-maker 'require-library-unit/sig #t #f) + (reference-library-unit-maker 'require-relative-library-unit #f #t) + (reference-library-unit-maker 'require-relative-library-unit/sig #t #t) + + (define (reset-unit-attributes attr) + (put-attribute attr 'c-unit-link-import/body-vocab null) + (put-attribute attr 'c-unit-current-link-tag-attribute null) + (put-attribute attr 'c-unit-expand-env null) + (put-attribute attr 'unit-vars null) + (put-attribute attr 'unresolved-unit-vars null) + (put-attribute attr 'exports-expand-vocab #f)) + + (attributes-resetters (cons reset-unit-attributes (attributes-resetters))) + + ) diff --git a/collects/zodiac/sexp.ss b/collects/zodiac/sexp.ss new file mode 100644 index 00000000..9b6705d1 --- /dev/null +++ b/collects/zodiac/sexp.ss @@ -0,0 +1,278 @@ +; $Id: sexp.ss,v 1.24 1999/06/02 11:29:38 mflatt Exp $ + +(unit/sig zodiac:sexp^ + (import zodiac:misc^ + zodiac:structures^ + (z : zodiac:reader-structs^) + zodiac:interface^ + zodiac:scheme-main^) + + (define identity (lambda (x) x)) + + (define structurize-syntax + (let ((default-origin (make-origin 'non-source 'never-mind))) + (opt-lambda (expr source (marks '()) (table #f) (origin default-origin)) + (let ((start (zodiac-start source)) + (finish (zodiac-finish source))) + (letrec + ((structurize + (lambda (expr origin) + (cond + ((zodiac? expr) expr) + ((and table + (hash-table-get table expr (lambda () #f))) + => + (lambda (cached-input) + cached-input)) + ((pair? expr) + (let loop ((expr expr) (rev-seen '()) (length 0)) + (cond + ((pair? expr) + (loop (cdr expr) + (cons (structurize (car expr) default-origin) rev-seen) + (add1 length))) + ((null? expr) + (z:make-list origin start finish + (reverse rev-seen) + length '())) + (else + (z:make-improper-list origin start finish + (reverse + (cons (structurize expr default-origin) rev-seen)) + (add1 length) + (make-period start) + '()))))) + ((vector? expr) + (z:make-vector origin start finish + (map (lambda (x) (structurize x default-origin)) (vector->list expr)) + (vector-length expr))) + ((symbol? expr) + (z:make-symbol + origin start finish expr expr marks)) + ((null? expr) + (z:make-list origin start finish '() 0 marks)) + ((string? expr) + (z:make-string origin start finish expr)) + ((number? expr) + (z:make-number origin start finish expr)) + ((boolean? expr) + (z:make-boolean origin start finish expr)) + ((char? expr) + (z:make-char origin start finish expr)) + [(and (object? expr) + (is-a? expr expands<%>)) + (z:make-external origin start finish expr)] + (else + (z:make-list origin start finish + (list + (z:make-symbol origin start finish + 'quote 'quote '(-1)) + expr) + 2 marks)))))) + (structurize expr origin)))))) + + (define set-macro-origin + (lambda (parsed-term head-sexp) + (when (zodiac? parsed-term) + (set-zodiac-origin! parsed-term + (make-origin 'macro + (if (z:symbol? head-sexp) + head-sexp + (internal-error 'set-macro-origin + "Shouldn't get ~s here" head-sexp))))) + parsed-term)) + + (define sexp->raw + (opt-lambda (expr (table #f)) + (cond + ((z:scalar? expr) + (if (z:box? expr) + (let ([b (box (sexp->raw (z:read-object expr) table))]) + (when table + (hash-table-put! table b expr)) + b) + (z:read-object expr))) + + ((z:sequence? expr) + (let ((output + (let ((objects (map (lambda (s) + (sexp->raw s table)) + (z:read-object expr)))) + (cond + ((z:list? expr) objects) + ((z:improper-list? expr) + (let loop ((objects objects)) + (if (or (null? objects) (null? (cdr objects))) + (internal-error expr + "Invalid ilist in sexp->raw") + (if (null? (cddr objects)) + (cons (car objects) (cadr objects)) + (cons (car objects) (loop (cdr objects))))))) + ((z:vector? expr) + (apply vector objects)))))) + (when table + (hash-table-put! table output expr)) + output)) + (else + expr)))) + + (define sanitized-sexp->raw + (let ((sa string-append)) + (lambda (expr) + (cond + ((z:scalar? expr) + (if (z:box? expr) + (box + (sanitized-sexp->raw (z:read-object expr))) + (z:read-object expr))) + ((z:vector? expr) + '#(...)) + ((z:list? expr) + '(...)) + ((z:improper-list? expr) + '(... . ...)) + (else + expr))))) + + ; ---------------------------------------------------------------------- + + (define syntax-null? + (lambda (l) + (and (z:list? l) + (= 0 (z:sequence-length l))))) + + (define syntax-car + (lambda (l) + (cond + ((or (z:list? l) (z:improper-list? l)) + (let ((object (expose-list l))) + (if (null? object) + (internal-error l "Empty list for syntax-car") + (car object)))) + (else (internal-error l "Not a list for syntax-car"))))) + + (define syntax-cdr + (lambda (l) + (cond + ((z:list? l) + (let ((object (expose-list l)) + (length (z:sequence-length l))) + (if (zero? length) + (internal-error l "Empty list for syntax-cdr") + (let ((result (cdr object))) + (z:make-list (zodiac-origin l) + (if (null? result) (zodiac-finish l) + (zodiac-start (car result))) + (zodiac-finish l) + result + (- length 1) '()))))) + ((z:improper-list? l) + (let ((object (expose-list l)) + (length (z:sequence-length l))) + (case length + ((0 1) (internal-error l "Improper list length is 0 or 1")) + ((2) (cadr object)) + (else + (let ((result (cdr object))) + (z:make-improper-list (zodiac-origin l) + (zodiac-start l) (zodiac-finish l) + result + (- length 1) + (z:improper-list-period l) '())))))) + (else (internal-error l "Not a list for syntax-cdr"))))) + + (define syntax-map + (case-lambda + ((f l) + (if (z:list? l) + (let ((object (expose-list l)) + (length (z:sequence-length l))) + (z:make-list (zodiac-origin l) + (zodiac-start l) (zodiac-finish l) + (map f object) length '())) + (internal-error l "Not a list for syntax-map"))) + ((f l1 l2) + (if (and (z:list? l1) (z:list? l2)) + (let ((object-1 (expose-list l1)) + (object-2 (expose-list l2)) + (length-1 (z:sequence-length l1)) + (length-2 (z:sequence-length l2))) + (if (= length-1 length-2) + (z:make-list (zodiac-origin l1) + (zodiac-start l1) (zodiac-finish l1) + (map f object-1 object-2) length-1 '()) + (internal-error l1 "Not of same length as ~s in syntax-map" + l2))) + (if (z:list? l1) + (internal-error l2 "Not a list for syntax-map") + (internal-error l1 "Not a list for syntax-map")))))) + + ; ---------------------------------------------------------------------- + + (define new-mark + (let ((m 0)) + (lambda () + (set! m (+ m 1)) + m))) + + (define mark-expression + (lambda (mark) + (lambda (expr) + (cond + ((z:list? expr) + (z:set-list-marks! expr + (add/remove-mark (z:list-marks expr) mark)) + expr) + ((z:symbol? expr) + (z:make-symbol (zodiac-origin expr) + (zodiac-start expr) (zodiac-finish expr) + (z:read-object expr) (z:symbol-orig-name expr) + (add/remove-mark (z:symbol-marks expr) mark))) + (else expr))))) + + (define carl car) + + (define add/remove-mark + (lambda (marks m) + (let loop + ((marks marks)) + (if (null? marks) (list m) + (let ((a (carl marks)) (d (cdr marks))) + (if (= a m) d + (cons a (loop d)))))))) + + (define expose-list + (lambda (l) + (cond + ((z:list? l) + (let ((marks (z:list-marks l)) + (object (z:read-object l))) + (if (null? marks) + object + (let + ((object + (let loop ((marks marks) (object object)) + (if (null? marks) object + (loop (cdr marks) + (map (mark-expression (carl marks)) object)))))) + (z:set-read-object! l object) + (z:set-list-marks! l '()) + object)))) + ((z:improper-list? l) + (let ((marks (z:improper-list-marks l)) + (object (z:read-object l))) + (if (null? marks) + object + (let + ((object + (let loop ((marks marks) (object object)) + (if (null? marks) object + (loop (cdr marks) + (map (mark-expression (carl marks)) object)))))) + (z:set-read-object! l object) + (z:set-improper-list-marks! l '()) + object)))) + (else + (internal-error l "Not appropriate for expose-list"))))) + + ) diff --git a/collects/zodiac/sigs.ss b/collects/zodiac/sigs.ss new file mode 100644 index 00000000..649e0bc8 --- /dev/null +++ b/collects/zodiac/sigs.ss @@ -0,0 +1,209 @@ +; $Id: sigs.ss,v 1.72 2000/01/10 22:51:13 clements Exp $ + +(begin-elaboration-time (require-library "macro.ss")) +(begin-elaboration-time (require-library "prettys.ss")) +(begin-elaboration-time (require-library "files.ss")) +(begin-elaboration-time (require-library "refer.ss")) +(require-library "refer.ss") + +(require-library "zsigs.ss" "zodiac") + +(define-signature zodiac:misc^ + (pretty-print debug-level symbol-append flush-printf print-and-return + attributes-resetters)) + +(define-signature zodiac:correlate^ + (make-correlator add-to-correlator find-in-correlator)) + +(define-signature zodiac:sexp^ + (structurize-syntax sexp->raw sanitized-sexp->raw + syntax-null? syntax-car syntax-cdr syntax-map + set-macro-origin + new-mark mark-expression add/remove-mark expose-list)) + +(define-signature zodiac:pattern^ + (make-match&env match-against penv-merge pexpand extend-penv + match-and-rewrite)) + +(define-signature zodiac:interface^ + (static-error internal-error)) + +(define-signature zodiac:expander^ + (expand expand-program expand-expr + m3-elaboration-evaluator + m3-macro-body-evaluator + add-system-macro-form add-user-macro-form + add-micro-form add-macro-form + add-list-micro add-ilist-micro add-lit-micro add-sym-micro + get-list-micro get-ilist-micro get-lit-micro get-sym-micro + make-attributes get-attribute put-attribute + extend-env copy-env retract-env print-env make-empty-environment + resolve resolve-in-env + macro-resolution? micro-resolution? + (struct top-level-resolution ()) + introduce-identifier introduce-fresh-identifier introduce-bound-id + create-vocabulary append-vocabulary + add-on-demand-form find-on-demand-form + set-subexpr-vocab! + (struct vocabulary-record + (name this rest symbol-error literal-error list-error ilist-error)))) + +(define-signature zodiac:scheme-core^ + (name-eq? marks-equal? + parsed->raw extend-parsed->raw + lexically-resolved? in-lexically-extended-env + add-primitivized-micro-form add-primitivized-macro-form + generate-name + elaboration-evaluator user-macro-body-evaluator + scheme-expand scheme-expand-program + common-vocabulary + beginner-vocabulary + intermediate-vocabulary + advanced-vocabulary + full-vocabulary + scheme-vocabulary + reset-previous-attribute + set-top-level-status get-top-level-status at-top-level? + set-internal-define-status get-internal-define-status at-internal-define? + as-nested + process-top-level-resolution ensure-not-macro/micro + check-for-signature-name + (struct parsed (back)) + (struct varref (var)) + (struct top-level-varref ()) create-top-level-varref + (struct top-level-varref/bind (slot)) create-top-level-varref/bind + (struct top-level-varref/bind/unit (unit?)) create-top-level-varref/bind/unit + (struct bound-varref (binding)) create-bound-varref + (struct lexical-varref ()) create-lexical-varref + (struct lambda-varref ()) create-lambda-varref + (struct app (fun args)) create-app + (struct binding (var orig-name)) create-binding+marks + (struct lexical-binding ()) create-lexical-binding+marks + (struct lambda-binding ()) create-lambda-binding+marks + (struct form ()) + valid-syntactic-id? valid-syntactic-id/s? + distinct-valid-syntactic-id/s? + valid-id? valid-id/s? + distinct-valid-id/s? + optarglist-pattern + (struct optarglist-entry (var+marks)) + (struct initialized-optarglist-entry (expr)) + (struct optarglist (vars)) + (struct sym-optarglist ()) + (struct list-optarglist ()) + (struct ilist-optarglist ()) + nonempty-arglist-decls-vocab lambda-nonempty-arglist-decls-vocab + proper-arglist-decls-vocab lambda-proper-arglist-decls-vocab + full-arglist-decls-vocab lambda-full-arglist-decls-vocab + optarglist-decls-vocab + make-optargument-list + paroptarglist-pattern + (struct paroptarglist-entry (var+marks)) + (struct initialized-paroptarglist-entry (expr)) + (struct paroptarglist (vars)) + (struct sym-paroptarglist ()) + (struct list-paroptarglist ()) + (struct ilist-paroptarglist ()) + paroptarglist-decls-vocab + make-paroptargument-list + arglist-pattern + (struct arglist (vars)) + (struct sym-arglist ()) + (struct list-arglist ()) + (struct ilist-arglist ()) + make-argument-list)) + +(define-signature zodiac:scheme-main^ + (create-const + (struct struct-form (type super fields)) create-struct-form + (struct if-form (test then else)) create-if-form + (struct quote-form (expr)) create-quote-form + (struct begin-form (bodies)) create-begin-form + (struct begin0-form (bodies)) create-begin0-form + (struct let-values-form (vars vals body)) create-let-values-form + (struct letrec-values-form (vars vals body)) create-letrec-values-form + (struct define-values-form (vars val)) create-define-values-form + (struct set!-form (var val)) create-set!-form + (struct case-lambda-form (args bodies)) create-case-lambda-form + (struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form + generate-struct-names + expands<%>)) + +(define-signature zodiac:scheme-objects^ + (create-class*/names-form + create-interface-form + (struct supervar-varref ()) create-supervar-varref + (struct superinit-varref ()) create-superinit-varref + (struct public-varref ()) create-public-varref + (struct override-varref ()) create-override-varref + (struct private-varref ()) create-private-varref + (struct inherit-varref ()) create-inherit-varref + (struct rename-varref ()) create-rename-varref + (struct supervar-binding ()) create-supervar-binding+marks + (struct superinit-binding ()) create-superinit-binding+marks + (struct public-binding ()) create-public-binding+marks + (struct override-binding ()) create-override-binding+marks + (struct private-binding ()) create-private-binding+marks + (struct inherit-binding ()) create-inherit-binding+marks + (struct rename-binding ()) create-rename-binding+marks + (struct class*/names-form + (this super-init super-expr interfaces init-vars inst-clauses)) + (struct interface-form (super-exprs variables)) + (struct public-clause (exports internals exprs)) + (struct override-clause (exports internals exprs)) + (struct private-clause (internals exprs)) + (struct inherit-clause (internals imports)) + (struct rename-clause (internals imports)) + (struct sequence-clause (exprs)))) + +(define-signature zodiac:scheme-units^ + (create-unit-form + create-compound-unit-form + create-invoke-unit-form + (struct unit-form (imports exports clauses)) + (struct compound-unit-form (imports links exports)) + (struct invoke-unit-form (unit variables)) + unit-clauses-vocab-delta update-unresolved-attribute + inside-unit? check-export + process-unit-top-level-resolution + )) + +(define-signature zodiac:scheme-objects+units^ + ()) + +(define-signature zodiac:scheme-mrspidey^ + (mrspidey-vocabulary + (struct poly-form (exp)) + (struct :-form (exp type)) + (struct type:-form (type attrs)) + (struct st:control-form (para val)) + (struct reference-unit-form (file kind signed?)) + (struct define-type-form (sym type)) + (struct define-constructor-form (sym modes)) + create-poly-form + create-:-form + create-type:-form + create-st:control-form + create-reference-unit-form + create-define-type-form + create-define-constructor-form)) + +(define-signature zodiac:back-protocol^ + (make-empty-back-box register-client)) + +(define-signature zodiac:system^ + ((open zodiac:structures^) + (open zodiac:scanner-parameters^) + (open zodiac:reader-structs^) + (open zodiac:reader-code^) + (open zodiac:sexp^) + (open zodiac:pattern^) + (open zodiac:correlate^) + (open zodiac:back-protocol^) + (open zodiac:expander^) + (open zodiac:scheme-core^) + (open zodiac:scheme-main^) + (open zodiac:scheme-objects^) + (open zodiac:scheme-units^) + (open zodiac:scheme-objects+units^) + (open zodiac:scheme-mrspidey^))) diff --git a/collects/zodiac/x.ss b/collects/zodiac/x.ss new file mode 100644 index 00000000..a03827ce --- /dev/null +++ b/collects/zodiac/x.ss @@ -0,0 +1,381 @@ +; $Id: x.ss,v 1.52 1999/05/31 11:19:39 mflatt Exp $ + +(unit/sig zodiac:expander^ + (import + zodiac:misc^ zodiac:sexp^ + zodiac:structures^ + (z : zodiac:reader-structs^) + zodiac:scheme-core^ + zodiac:interface^) + + ; ---------------------------------------------------------------------- + + (define-struct resolutions (name user?)) + (define-struct (micro-resolution struct:resolutions) (rewriter)) + (define-struct (macro-resolution struct:resolutions) (rewriter)) + + ; ---------------------------------------------------------------------- + + (define-struct vocabulary-record (name this rest + symbol-error literal-error + list-error ilist-error + on-demand subexpr-vocab)) + + (define get-vocabulary-name vocabulary-record-name) + + (define (self-subexpr-vocab v) + (set-vocabulary-record-subexpr-vocab! v v) + v) + + (define (set-subexpr-vocab! v subexpr-v) + (set-vocabulary-record-subexpr-vocab! v subexpr-v)) + + (define create-vocabulary + (opt-lambda (name (root #f) + (symbol-error (if root + (vocabulary-record-symbol-error root) + "Symbol invalid in this position")) + (literal-error (if root + (vocabulary-record-literal-error root) + "Literal invalid in this position")) + (list-error (if root + (vocabulary-record-list-error root) + "List invalid in this position")) + (ilist-error (if root + (vocabulary-record-ilist-error root) + "Improper-list syntax invalid in this position"))) + (let ((h (make-hash-table))) + (self-subexpr-vocab + (make-vocabulary-record + name h root + symbol-error literal-error list-error ilist-error + null #f))))) + + (define append-vocabulary + (opt-lambda (new old (name #f)) + (let loop ((this new) (first? #t)) + (let ((name (if (and first? name) name + (vocabulary-record-name this)))) + (self-subexpr-vocab + (make-vocabulary-record + name + (vocabulary-record-this this) + (if (vocabulary-record-rest this) + (loop (vocabulary-record-rest this) #f) + old) + (vocabulary-record-symbol-error this) + (vocabulary-record-literal-error this) + (vocabulary-record-list-error this) + (vocabulary-record-ilist-error this) + (vocabulary-record-on-demand this) + #f)))))) + + (define add-micro/macro-form + (lambda (constructor) + (lambda (name/s vocab rewriter) + (let ((v (vocabulary-record-this vocab)) + (names (if (symbol? name/s) (list name/s) name/s)) + (r (constructor rewriter))) + (set-resolutions-name! r name/s) + (map (lambda (n) + (hash-table-put! v n r)) + names))))) + + (define vocab->list + (lambda (vocab) + (cons (vocabulary-record-name vocab) + (hash-table-map cons (vocabulary-record-this vocab))))) + + (define add-micro-form + (add-micro/macro-form (lambda (r) + (make-micro-resolution 'dummy #f r)))) + + (define add-system-macro-form + (add-micro/macro-form (lambda (r) + (make-macro-resolution 'dummy #f r)))) + + (define add-user-macro-form + (add-micro/macro-form (lambda (r) + (make-macro-resolution 'dummy #t r)))) + + (define add-macro-form add-system-macro-form) + + (define list-micro-kwd + (string->uninterned-symbol "list-expander")) + (define ilist-micro-kwd + (string->uninterned-symbol "ilist-expander")) + (define sym-micro-kwd + (string->uninterned-symbol "symbol-expander")) + (define lit-micro-kwd + (string->uninterned-symbol "literal-expander")) + + (define add-list/sym/lit-micro + (lambda (kwd) + (lambda (vocab rewriter) + (hash-table-put! (vocabulary-record-this vocab) + kwd + (make-micro-resolution kwd #f rewriter))))) + + (define add-list-micro (add-list/sym/lit-micro list-micro-kwd)) + (define add-ilist-micro (add-list/sym/lit-micro ilist-micro-kwd)) + (define add-sym-micro (add-list/sym/lit-micro sym-micro-kwd)) + (define add-lit-micro (add-list/sym/lit-micro lit-micro-kwd)) + + (define get-list/sym/lit-micro + (lambda (kwd) + (lambda (vocab) + (let loop ((vocab vocab)) + (hash-table-get (vocabulary-record-this vocab) + kwd + (lambda () + (let ((v (vocabulary-record-rest vocab))) + (if v + (loop v) + #f)))))))) + + (define get-list-micro (get-list/sym/lit-micro list-micro-kwd)) + (define get-ilist-micro (get-list/sym/lit-micro ilist-micro-kwd)) + (define get-sym-micro (get-list/sym/lit-micro sym-micro-kwd)) + (define get-lit-micro (get-list/sym/lit-micro lit-micro-kwd)) + + (define (add-on-demand-form kind name vocab micro) + (set-vocabulary-record-on-demand! + vocab + (cons (list* name kind micro) + (vocabulary-record-on-demand vocab)))) + + (define (find-on-demand-form name vocab) + (let ([v (assq name (vocabulary-record-on-demand vocab))]) + (if v + (list (cadr v) (cddr v)) + (let ([super (vocabulary-record-rest vocab)]) + (and super (find-on-demand-form name super)))))) + + ; ---------------------------------------------------------------------- + + (define expand-expr + (lambda (expr env attributes vocab) + ; (printf "Expanding in ~s:~n" (get-vocabulary-name vocab)) + ; (pretty-print (sexp->raw expr)) (newline) + ; (printf "top-level-status: ~s~n" (get-top-level-status attributes)) + ; (printf "Expanding~n") (pretty-print expr) (newline) + ; (printf "Expanding~n") (display expr) (newline) (newline) + ; (printf "in ~s~n" (get-vocabulary-name vocab)) + ; (printf "in vocabulary~n") (print-env vocab) + ; (printf "in attributes~n") (hash-table-map attributes cons) + ; (printf "in~n") (print-env env) + ; (newline) + (cond + ((z:symbol? expr) + (let ((sym-expander (get-sym-micro vocab))) + (cond + ((micro-resolution? sym-expander) + ((micro-resolution-rewriter sym-expander) + expr env attributes (vocabulary-record-subexpr-vocab vocab))) + (sym-expander + (internal-error expr "Invalid sym expander ~s" sym-expander)) + (else + (static-error expr + (vocabulary-record-symbol-error vocab)))))) + ((or (z:scalar? expr) ; "literals" = scalars - symbols + (z:vector? expr)) + (let ((lit-expander (get-lit-micro vocab))) + (cond + ((micro-resolution? lit-expander) + ((micro-resolution-rewriter lit-expander) + expr env attributes (vocabulary-record-subexpr-vocab vocab))) + (lit-expander + (internal-error expr + "Invalid lit expander ~s" lit-expander)) + (else + (static-error expr + (vocabulary-record-literal-error vocab)))))) + ((z:list? expr) + (let ((invoke-list-expander + (lambda () + (let ((list-expander (get-list-micro vocab))) + (cond + ((micro-resolution? list-expander) + ((micro-resolution-rewriter list-expander) + expr env attributes (vocabulary-record-subexpr-vocab vocab))) + (list-expander + (internal-error expr + "Invalid list expander ~s" list-expander)) + (else + (static-error expr + (vocabulary-record-list-error vocab))))))) + (contents (expose-list expr))) + (if (null? contents) + (invoke-list-expander) + (let ((app-pos (car contents))) + (if (z:symbol? app-pos) + (let ((r (resolve app-pos env vocab))) + (cond + ((macro-resolution? r) + (with-handlers ((exn:user? + (lambda (exn) + (static-error expr + (exn-message exn))))) + (let* ((rewriter (macro-resolution-rewriter r)) + (m (new-mark)) + (rewritten (rewriter expr env)) + (structurized (structurize-syntax + rewritten expr (list m) + #f + (make-origin 'macro + expr))) + (expanded (expand-expr structurized env + attributes vocab))) + expanded))) + ((micro-resolution? r) + ((micro-resolution-rewriter r) + expr env attributes (vocabulary-record-subexpr-vocab vocab))) + (else + (invoke-list-expander)))) + (invoke-list-expander)))))) + ((z:improper-list? expr) + (let ((ilist-expander (get-ilist-micro vocab))) + (cond + ((micro-resolution? ilist-expander) + ((micro-resolution-rewriter ilist-expander) + expr env attributes (vocabulary-record-subexpr-vocab vocab))) + (ilist-expander + (internal-error expr + "Invalid ilist expander ~s" ilist-expander)) + (else + (static-error expr + (vocabulary-record-ilist-error vocab)))))) + (else + (internal-error expr + "Invalid body: ~s" expr))))) + + (define m3-elaboration-evaluator #f) + (define m3-macro-body-evaluator #f) + + (define expand + (lambda (expr attr vocab elaboration-eval macro-body-eval) + (fluid-let ((m3-elaboration-evaluator elaboration-eval) + (m3-macro-body-evaluator macro-body-eval)) + (expand-expr expr (make-new-environment) attr vocab)))) + + (define expand-program + (lambda (exprs attr vocab elaboration-eval macro-body-eval) + (fluid-let ((m3-elaboration-evaluator elaboration-eval) + (m3-macro-body-evaluator macro-body-eval)) + (put-attribute attr 'top-levels (make-hash-table)) + (map (lambda (expr) + (expand-expr expr (make-new-environment) attr vocab)) + exprs)))) + + ; ---------------------------------------------------------------------- + + (define make-attributes make-hash-table) + (define put-attribute + (lambda (table key value) + (hash-table-put! table key value) + table)) + (define get-attribute + (opt-lambda (table key (failure-thunk (lambda () #f))) + (hash-table-get table key failure-thunk))) + + ; ---------------------------------------------------------------------- + + (define introduce-identifier + (lambda (new-name old-id) + (z:make-symbol (zodiac-origin old-id) + (zodiac-start old-id) (zodiac-finish old-id) + new-name new-name (z:symbol-marks old-id)))) + + (define introduce-fresh-identifier + (lambda (new-name source) + (z:make-symbol (make-origin 'non-source 'never-mind) + (zodiac-start source) (zodiac-finish source) + new-name new-name '()))) + + (define introduce-bound-id + (lambda (binding-gen name-gen old-id old-id-marks) + (let* ((base-name (binding-var old-id)) + (real-base-name (binding-orig-name old-id)) + (new-base-name (name-gen real-base-name)) + (new-name (symbol-append base-name "-init"))) + (let ((s (z:make-symbol (zodiac-origin old-id) + (zodiac-start old-id) (zodiac-finish old-id) + new-base-name new-base-name old-id-marks))) + ((create-binding+marks binding-gen + (lambda (_) new-name)) + s))))) + + ; ---------------------------------------------------------------------- + + (define-struct (top-level-resolution struct:resolutions) ()) + + ; ---------------------------------------------------------------------- + + (define make-new-environment make-hash-table) + + (define make-empty-environment make-new-environment) + + (define resolve + (lambda (id env vocab) + (let ((name (z:read-object id)) (marks (z:symbol-marks id))) + (or (resolve-in-env name marks env) + (resolve-in-vocabulary name vocab))))) + + (define resolve-in-env + (lambda (name marks env) + (let ((v (hash-table-get env name (lambda () #f)))) ; name-eq? + (and v + (let ((w (assoc marks v))) ; marks-equal? + (and w (cdr w))))))) + + (define resolve-in-vocabulary + (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) ; name-eq? + (lambda (name vocab) + (let loop ((vocab vocab)) + (hash-table-get (vocabulary-record-this vocab) + name + (lambda () + (let ((v (vocabulary-record-rest vocab))) + (if v + (loop v) + top-level-resolution)))))))) + + (define print-env + (lambda (env) + (hash-table-map env (lambda (key value) + (printf "~s ->~n" key) + (pretty-print value))))) + + ; ---------------------------------------------------------------------- + + (define extend-env + (lambda (new-vars+marks env) + (for-each + (lambda (var+marks) + (let ((new-var (car var+marks))) + (let ((real-name (binding-orig-name new-var))) + (hash-table-put! env real-name + (cons (cons (cdr var+marks) new-var) + (hash-table-get env real-name (lambda () '()))))))) + new-vars+marks))) + + (define retract-env + (lambda (vars env) + (let ((names (map binding-orig-name vars))) + (for-each (lambda (name) + (hash-table-put! env name + (cdr (hash-table-get env name + (lambda () + '(internal-error:dummy-for-sake-of-cdr!)))))) + names)))) + + (define copy-env + (lambda (env) + (let ([new (make-hash-table)]) + (hash-table-for-each + env + (lambda (key val) + (hash-table-put! new key val))) + new))) + + ) diff --git a/collects/zodiac/zsigs.ss b/collects/zodiac/zsigs.ss new file mode 100644 index 00000000..346d0718 --- /dev/null +++ b/collects/zodiac/zsigs.ss @@ -0,0 +1,96 @@ +;; +;; $Id: zsigs.ss,v 1.9 1998/03/05 18:30:42 mflatt Exp $ +;; +;; The signatures for all scanner/reader units. +;; + +;; +;; Top-level zodiac structures (outside the hierarchy) +;; and base of zodiac hierarchy. +;; + +(define-signature zodiac:structures^ + ((struct origin (who how)) + (struct location (line column offset file)) + (struct period (location)) + (struct eof (location)) + (struct zodiac (origin start finish)))) + +;; +;; Scanner's subtree of the hierarchy. +;; +;; zodiac (origin start finish) +;; scanned +;; token (object type) +;; + +(define-signature zodiac:scanner-structs^ + ((struct scanned ()) + (struct token (object type)))) + +;; +;; Reader's subtree of the hierarchy. +;; +;; zodiac (origin start finish) +;; read (object) +;; scalar +;; symbol (orig-name marks) +;; number +;; string +;; boolean +;; char +;; box +;; type-symbol +;; external +;; sequence (length) +;; list +;; vector +;; improper-list (period) +;; + +(define-signature zodiac:reader-structs^ + ((struct read (object)) + (struct scalar ()) + (struct symbol (orig-name marks)) + (struct number ()) + (struct string ()) + (struct boolean ()) + (struct char ()) + (struct box ()) + (struct type-symbol ()) + (struct external ()) + (struct sequence (length)) + (struct list (marks)) + (struct vector ()) + (struct improper-list (period marks)))) + +;; +;; Scanner/Reader Parameters. +;; +;; The scan values (outside make-scanner) mostly can +;; be reset at will. But don't use letters, digits, #, etc. +;; The parameters inside make-scanner should not be reset. +;; +;; The char lists can be either chars or ints. +;; + +(define-signature zodiac:scanner-parameters^ + (disallow-untagged-inexact-numbers + scan:paren-relation + scan:self-delim-symbols + scan:newline-list + scan:tab-list + scan:whitespace-list + scan:delim-list + scan:special-char-list + default-initial-location + scan:def-first-col + scan:def-vect-val)) + +;; +;; The scanner & reader units just export one function. +;; + +(define-signature zodiac:scanner-code^ (scan)) +(define-signature zodiac:reader-code^ (read allow-improper-lists allow-reader-quasiquote)) + diff --git a/install b/install new file mode 100755 index 00000000..7f8d46ec --- /dev/null +++ b/install @@ -0,0 +1,158 @@ +#!/bin/sh + +# PLT software installer +# Configures PLTHOME path within scripts +# For certain platforms and installations, adds extra +# directory links (to reach non-standard binaries +# through the platform's standard path) +# Creates .zo files if the user assents + +didnothing=" (nothing to do)" + +showhelp () +{ + echo "Usage: $0 [ newplthomedir ]" + echo " newplthomedir defaults to the current directory" + echo " use \"\" for newplthomedir to keep the current setting" + exit 1 +} + +if [ $# -gt 1 ] ; then + showhelp +fi +if [ "$1" = '-h' ] ; then + showhelp +fi + +if [ ! \( \( -x install \) -a \( -d collects \) \) ] ; then + echo "$0: must be run from its own directory" + exit 1 +fi + +if [ $# -eq 1 ] ; then + installplthome="$1" +else + installplthome=`pwd` +fi + +PLTHOME="$installplthome" +export PLTHOME +PLTCOLLECTS="" +export PLTCOLLECTS +PLTEXTENSION="" +export PLTEXTENSION + +echo "setting PLTHOME to $installplthome in scripts:" + +case `uname -s` in + *BSD) # FreeBSD and OpenBSD, at least + chmod='chmod -RH' + ;; + *) + chmod='chmod' + ;; +esac + +if [ "$installplthome" != '' ] ; then + # Change the scripts in bin/, replacing + # PLTHOME=.* + # with + # PLTHOME= + # where is provided to this script + + PROGRAM="/set PLTHOME=.*/ { print \" set PLTHOME=$installplthome\"; next } /PLTHOME=.*/ { print \" PLTHOME=$installplthome\"; next } /.*/ {print} " + + for f in bin/* ; do + if [ -f $f ] ; then + echo " updating $f" + didnothing="" + awk "$PROGRAM" $f > $f.tmp + if [ -w $f ] ; then + cat $f.tmp > $f + else + # Ugh - temporarily chmod to allow writing + oldstate=`ls -Ll $f` + $chmod a+w $f + cat $f.tmp > $f + $chmod a-w $f + ucanwrite=`echo $oldstate | cut -c3,3` + gcanwrite=`echo $oldstate | cut -c6,6` + ocanwrite=`echo $oldstate | cut -c9,9` + if [ $ucanwrite = 'w' ] ; then + $chmod u+w $f + fi + if [ $gcanwrite = 'w' ] ; then + $chmod g+w $f + fi + if [ $ocanwrite = 'w' ] ; then + $chmod o+w $f + fi + fi + rm $f.tmp + else + if [ -d $f ]; then + echo "$0: weird - $f is not a file!" + fi + fi + done +fi + +checklink () +{ + PACKAGE=$1 + SPECIAL=$2 + STD=$3 + SHORTSPECIAL=$4 + SPECIALNAME=$5 + STDNAME=$6 + + if [ -r $SPECIAL ] ; then + if [ ! \( -r $STD \) ] ; then + echo "If you *do not* plan to install the $STDNAME " + echo " version of the PLT software, a soft-link to" + echo " the $SPECIALNAME version should be installed for" + echo " $PACKAGE." + echo -n " Add this link (y/n)? [y] " + read response + if [ "$response" != 'n' ] ; then + if [ "$response" != 'N' ] ; then + didnothing="" + ln -s $SHORTSPECIAL $STD + echo "link from $STDNAME ($STD) to $SPECIALNAME ($SHORTSPECIAL) added" + fi + fi + fi + fi +} + +checklink "MrEd/DrScheme" ".bin/rs6k-aix-xt/mred" ".bin/rs6k-aix/mred" "../rs6k-aix-xt/mred" "AIX Xt" "AIX Motif" +checklink "MrEd/DrScheme" ".bin/sparc-solaris-motif/mred" ".bin/sparc-solaris/mred" "../sparc-solaris-motif/mred" "Solaris Motif" "Solaris Xt" +checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4-static" ".bin/sparc-sunos4" "sparc-sunos4-static" "SunOS4 Static" "Regular SunOS4" + +if [ `bin/archsys` = "sparc-solaris" ] ; then + checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4" ".bin/sparc-solaris" "sparc-sunos4" "SunOS4" "Solaris" + checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4-static" ".bin/sparc-solaris" "sparc-sunos4-static" "SunOS4 Static" "Solaris" +fi + +if [ -z "${RPM_INSTALL_PREFIX}" ] ; then + echo 'PLT software starts up much faster with .zo files, but creating .zo' + echo 'files now takes a few minutes and requires about 5MB of additional' + echo 'disk space. Create .zo files later by running plt/bin/setup-plt.' + echo -n ' Create .zo files now (y/n)? [y] ' + read response +else + response="y" +fi +if [ "$response" != 'n' ] ; then + if [ "$response" != 'N' ] ; then + didnothing="" + bin/setup-plt + fi +fi + +echo +echo "PLT installation done${didnothing}." +if [ -f bin/drscheme ] ; then + echo "Run DrScheme as bin/drscheme." + echo "For Help, select \`Help Desk' from DrScheme's \`Help' menu, or run bin/help-desk." +fi diff --git a/man/man1/drscheme-jr.1 b/man/man1/drscheme-jr.1 new file mode 100644 index 00000000..0b3517b3 --- /dev/null +++ b/man/man1/drscheme-jr.1 @@ -0,0 +1,127 @@ +.\" dummy line +.TH DRSCHEME JR 1 "28 October 1999" +.UC 4 +.SH NAME +drscheme-jr \- The Rice PLT Scheme programming shell +.SH SYNOPSIS +.B drscheme-jr +[ +.I Xflag ... +] +[ +.I file ... +] +.SH DESCRIPTION +.I DrScheme Jr +is the Rice University PLT Scheme +programming shell. It is the text-only version of the +.I DrScheme +programming environment. +.PP +.I DrScheme Jr +treats its command line arguments as filenames and loads them after +starting up. +.SH OPTIONS + +Startup file and expression switches: +.TP +.BI \-l \ language ,\ \-\-language \ language +Set the language to one of the following: +Beginner Intermediate Advanced R4RS+ MzScheme. +.TP +.BR \-\-case\-sens \ { on , off } +Enable/disable case-sensitive symbols and variables +.TP +.BR \-\-set\-undef \ { on , off } +Enable/disable set! on undefined variables +.TP +.BR \-\-auto\-else \ { on , off } +Enable/disable non-matching cond/case produces (void) +.TP +.BR \-\-improper\-lists \ { on , off } +Enable/disable improper lists +.TP +.BR \-\-print\-sharing \ { on , off } +Enable/disable show sharing in values +.TP +.BR \-\-print\-list \ { on , off } +Enable/disable use `list' where appropriate in constructor style printing +.TP +.BR \-\-signal\-undef \ { on , off } +Enable/disable error if using # variable +.TP +.BR \-\-boolean\-conds \ { on , off } +Enable/disable conditionals must be #t or #f +.TP +.BR \-\-eq\-syms \ { on , off } +Enable/disable eq? only for symbols +.TP +.BR \-\-tag\-inexacts \ { on , off } +Enable/disable print inexact numbers with #i +.TP +.BR \-\-whole\-frac \ { on , off } +Enable/disable separate whole and fractional parts of exact numbers in printer +.TP +.BR \-\-constructor\-printing \ { on , off } +Enable/disable print values using constructor style input syntax +.TP +.BR \-\-quasi\-printing \ { on , off } +Enable/disable print values using quasi-quote style input syntax +.TP +.BI \-\-choose +Interactively choose the language level +.TP +.BI \-\-save\ \ \ +Save current settings to ~/.drscheme-jr.settings +.TP +.BI \-\-show\ \ \ +Show the current settings +.TP +.BI \-\-lhelp \ language +Show the flags implied by a particular language +.TP +.B \-\-help,\ \-h +Show help +.TP +.B \-\-\ \ \ \ \ +Do not treat any remaining argument as a flag (at this level) + +.PP +Multiple single-letter flags can be combined after one `-'. +For example, `-h-' is the same as `-h --' +If ~/.drscheme-jr.settings exists, it initializes the language settings. + +.pp +For further information on +.I DrScheme Jr, +please consult the on-line +documentation and other information available at +.PP +.ce 1 +http://www.cs.rice.edu/CS/PLT/packages/drschemejr/ +.SH FILES +.I DrScheme Jr +looks for its libraries using the environment variables +PLTHOME and PLTCOLLECTS. If this variable is not defined, +the installation directory is assumed (usually +"/usr/local/lib/plt/"). See the documentation for details. +.PP +Please consult your local administrator to determine whether +the on-line documentation has been installed locally. +.SH BUGS +Submit bug reports via +.ce 1 +http://www.cs.rice.edu/CS/PLT/Bugs/ (encouraged) +or by e-mail to +.ce 1 +plt-bugs@cs.rice.edu (discouraged) +.SH AUTHOR +.I DrScheme Jr +was implemented by Robby Findler (robby@cs.rice.edu), +Shriram Krishnamurthi (shriram@cs.rice.edu), Cormac Flanagan +(cormac@cs.rice.edu), Matthew Flatt (mflatt@cs.rice.edu), +and Paul Steckler (steck@cs.rice.edu). +.SH SEE ALSO +.BR drscheme(1), +.BR mred(1), +.BR mzscheme(1) diff --git a/man/man1/drscheme.1 b/man/man1/drscheme.1 new file mode 100644 index 00000000..c40a8f84 --- /dev/null +++ b/man/man1/drscheme.1 @@ -0,0 +1,60 @@ +.\" dummy line +.TH DRSCHEME 1 "28 October 1999" +.UC 4 +.SH NAME +drscheme \- The PLT Scheme programming environment +.SH SYNOPSIS +.B drscheme +[ +.I Xflag ... +] +[ +.I file ... +] +.SH DESCRIPTION +.I DrScheme +is the PLT Scheme +programming environment. A text-only version, +.I DrScheme Jr, +is also available. +.PP +.I DrScheme +opens the files given as command-line arguments. +.pp +For further information on +.I DrScheme, +please consult the on-line +documentation and other information available at +.PP +.ce 1 +http://www.cs.rice.edu/CS/PLT/packages/drscheme/ +.SH FILES +.I DrScheme +looks for its libraries using the environment variables +PLTHOME and PLTCOLLECTS. If this variable is not defined, +the installation directory is assumed (usually +"/usr/local/lib/plt/"). See the documentation for details. +.PP +Please consult your local administrator to determine whether +the on-line documentation has been installed locally. +.SH BUGS +Submit bug reports via +.ce 1 +Help Desk (encouraged), +or via the web +.ce 1 +http://www.cs.rice.edu/CS/PLT/Bugs/ (discouraged) +or by e-mail to +.ce 1 +plt-bugs@cs.rice.edu (discouraged) +.SH AUTHOR +.I DrScheme +was implemented by Robby Findler (robby@cs.rice.edu), +Shriram Krishnamurthi (shriram@cs.rice.edu), +John Clements (clements@cs.rice.edu), Cormac Flanagan +(cormac@cs.rice.edu), Matthew Flatt (mflatt@cs.utah.edu), +and Paul Steckler (steck@cs.rice.edu). +.SH SEE ALSO +.BR drscheme-jr(1), +.BR mred(1), +.BR mzscheme(1) diff --git a/notes/COPYING.LIB b/notes/COPYING.LIB new file mode 100644 index 00000000..eb685a5e --- /dev/null +++ b/notes/COPYING.LIB @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/notes/drscheme/HISTORY b/notes/drscheme/HISTORY new file mode 100644 index 00000000..b0fe0c84 --- /dev/null +++ b/notes/drscheme/HISTORY @@ -0,0 +1,596 @@ +Version 102: + +102d9: + + NEW DIRECTORY: plt/collects/defaults + + be sure to get the new directory with: + + cvs update -d plt/collects/defaults + + or DrScheme will fail to start up. + + WARNINGS: + - this release breaks the stepper. + - the "create launcher" menu item is + not yet fully functional, so use at your + own risk. + + PRS: 1424, 1437 + + FUNCTIONALITY CHANGES + + - drscheme-jr now supports teachpacks + (those that don't use GUIs, like htdp/dir.ss) + + - the graphics library (sometimes known as sixlib) no longer + accepts any scaling arguments. + + - drscheme:rep:process-text/zodiac and + drscheme:rep:process-text/no-zodiac + are now called drscheme:load-handler:process-text/zodiac and + drscheme:load-handler:process-text/no-zodiac. + + - Windows and unix launchers can now be run from any directory. + They do not need to be saved in a particular place (this has been + true for some time, but it is officially true now.). + + - the debug full scheme languages now allow loading of files + that contain graphics. + + - the framework's preferences system now requires you to + set the marshall/unmarshalling functions (if any) before + setting the default preference. + + - drscheme now supports site-specific default preferences. + To use, create a file prefs.ss in the defaults collection + that is a copy of the preferences file that you want to + be the defaults. Then, if the user-specific preferences file + doesn't exist (or the preferences in it are from an old version), + the contents of the prefs.ss file in the defaults collection is + used as the preferences. + + - drscheme now wraps uses with-handlers so that if a tool + signals an error when it is loaded or invoked, it just + puts a window with the error message and continues, instead + of keeping drscheme from starting up. + + - the .plt installer no longer automatically deletes compiled + files when installing a .plt file. + + - setup-plt now uses the 'clean flag in info.ss to determine + the files to be deleted when --clean-ing a collection. It + defaults to the files in the "compiled" sub-collection of a + collection. + + - setup-plt no longer automatically runs --clean when installing + a .plt file. + + MINOR CHANGES AND BUG FIXES + + - the searching dialog now has two-line find and replace editors. + + - #! is treated like a comment when executing the defintions window, + if it is the first two characters in the definitions window. + + - constructing the project manager's "collection projects" menu + was adding something like a 25% overhead to drscheme's startup, + so that menu is gone (I doubt anyone really used it anyway...) + + - rarely used save menu items relegated to sub-menu. + + - wrap text is now a checkable item that is checked when the editor + is wrapped. + + - drscheme-jr now has a doc.txt file that explains its implementation. + The implementation was factored so that DrScheme's new launchers + can re-use drscheme-jr's implementation. So, if you change + drscheme-jr, be aware that you might affecting these launchers. + +102d8 + + PRS: 1358, 1344, 1341, 1329, 1322, 1242 (docs not yet built), 1235 + + FUNCTIONALITY CHANGES + + - added a "keymap" menu to the edit menu (shortcut: k) + that opens a window where you can see all of the key + bindings' names and short cuts, and you can choose one + to invoke. + + - framework: + - added canonicalize-keybinding-string + - added aug-keymap%, aug-keymap<%> + - editor:basic now sets it's keymap to an + aug-keymap<%> during initialization. + + MINOR CHANGES AND BUG FIXES + + - added a "Kill" menu item that kills all computation and reclaims + all resources from the program that drscheme is executing. + This is useful for multi-threaded apps that get out of hand. + + - improved the look of the "(define" (now "(define ...)") and + filename buttons on the left in drscheme's toolbar + + - if ``#!'' appears at the beginning of the first line in the definitions + window, the first line is treated as a comment during execution + (this is only a change for the non-debug language levels -- the + teaching and debug language levels all already did this) + + - meta-control-d, meta-control-u, meta-shift-control-d, meta-shift-control-u + keybindings all restored. + + +102d7 + + - drscheme now has a little button on the bar that lets you hop + around between definitions in the program. It is approximate in + that it doesn't really know every detail about the lexical + structure of scheme, but it should still be quite useful. + +102d6 + + PRS: 1341 + + FUN INFO + + - DrScheme's rep class now exports a method with this type: + + ((((-> void) -> void) -> void) -> void) + 4 3 2 1 + + believe it or not. It is used to evaluate user expressions in the + repl. Arrow 1 sets up the repl (watch cursor and stuff) and then + calls arrow 2, which should loop, once for each expression (say in + the definitions window), calling arrow 3. Arrow 2 then calls arrow 3 + with arrow 4. Arrow 3 does a little before/after setup to get + breaking right and calls arrow 4 to actually evaluate each + expression. + + FUNCTIONALITY CHANGES + + - the framework's info frame mixins no longer require frame:editor<%> + as an input. Also, they are moved lower in the hierarchy of the + instantiated mixin classes in the framework. This affects all of the + frame:XX% classes. + + - project manager windows now have a repl. + The repl shows the values returned by loading each of the files + in the project. + + tools: + + - ensure-interactions-shown is now ensure-rep-shown + - do-many-buffer-evals is now do-many-text-evals + + teachpacks: + + - interactions window now shows the names of the teachpacks that + were installed at last execute. + - teachpack names are not in the area with the execute button, instead + they are now shown in the language menu. + - it is now an error to add the same teachpack twice. + + - GRAPHICAL_DEBUG is no longer supported. It was always wierd, becuase + it changed the semantics of require-library in a way that was + mostly the same, and keeping drscheme in the consistent + intersection of the two semantics was getting painful (not to + mention confusing...) + + MINOR CHANGES AND BUG FIXES + + - repl errors that are in some loaded file have little clickable + icons that open the file and show the error's source location in + the file. Icon suggestions welcome. To test them out, just replace + file.gif in the icons collection. + + - common file dialog keyboard navigation improved (typing letters now + may go backwards now -- before it only went fowards) + + - common file dialogs are now resizable. + + - common file dialogs now sort in case insensitive mode always + (typing letters doesn't make much sense otherwise) + + - lucky search now sets the focus to the html viewing canvas instead + of leaving the focus on the search text-field. + +102d5 + + PRS: 1334 + + FUNCTIONALITY CHANGES + + - THE FILE FORMAT FOR PROJECT FILES HAS CHANGED + + to update your old project files to the new format, use emacs or + something to insert a ' at the front of the file. Then open and + save the project in drscheme. + + - project files are now `load'able. That is, if you have the right + language settings, you can do + + mzscheme -qmvr myproj.proj + + and have the same effect as clicking execute on the project + window. For mred, you will need to do something like this: + + mred -qmvr myproj.proj -e "(yield (make-semaphore 0))" + + so that mred doesn't quit automatically. + + MINOR CHANGES AND BUG FIXES + + - typeset now uses scheme-mode editors for red boxes. + + - Help Desk now has a "feeling lucky" option ala google (menu + shortcut: l). It goes directly to the first item that would have + been found in a regular search. + + - Clicking on an error message link in drscheme now uses the "feeling + lucky" style search in help desk. + +102d4 + + minor bug fixes + +102d3 + + PRS: 1235 + + FUNCTIONALITY CHANGES + + - drscheme now allows multiple teachpacks. + + - added typeset-size to typeset utilities. Used to control the size + of the rendered text. + + - clever-file-format now symetrically changes the file's format to + 'standard. It used to rever the file format to 'text when there + were no more images in it. Now, it also changes back to non-'text + when images (and other non-string-snips) are added back. + + MINOR CHANGES AND BUG FIXES + + - clicking on the name in the topleft of the drscheme frame opens a + little window with the full path. + + - check syntax now shows its syntax errors in a separate window. + (PR 1235) + +102d2 + + PRS: 1297, 1306, 1171 + + FUNCTIONALITY CHANGES + + - the framework's gui-utils:get-snips/chars-from-buffer is now + gui-utils:get-snips/chars-from-text + + - zodiac now supports graphical expressions. If a snip implements + zodiac's expand<%> interface, zodiac calls a method of the snip to + expand it. Docs updated but not built. + + - the teaching languages now come with: + + make-posn, posn-x, posn-y, and posn? + + by default (no library required). + + - added typeset tool. To get, there are two new directories: + + plt/collects/typeset + plt/collects/drscheme/tools/typeset + + be sure to check those out. Search for Typeset in help desk for + more info. + + - teaching levels print exact numbers whose denominators are evenly + disivible by 2 and 5 as decimals. + + - teaching levels treat input decimals as exact numbers. + + MINOR CHANGES AND BUG FIXES + + - fixed a bug (PR 1297, steck submission) in a call to message-box + from the get-file dialog but was unable to repdoduce the bug. Paul, + can you see if the bug has gone away? Thanks. + + - changed the new version "welcome to drs" window back to something + much like the one in previous versions. + + - drscheme should now print with a fixed-width font. + + - in the main help-desk window, space does pgdn and backspace does + pgup, ala netscape. Also, typing return or enter while the cursor + is on a link follows the link. + +102d1 + + PRS: 1274, 1280, 1264, 1260, 1239, 1225, 1220, 1268, 1209, 1208, + 1196, 1180, 1096, 1088, 1043, 771, 752, 846 + + FUNCTIONALITY CHANGES + + - New project manager. The manual is not yet available, so + you will have to play with the Project menu yourself. I hope that + things are self-explanatory. There is no REPL support. Any repl + support that comes will be part of the debugger. + + *** WARNING: NEW DIRECTORY *** + + To get it, run these simple commands: + + % cd PLTHOME/collects/drscheme + % cvs update -r exp -d + + - added class/d macro. It's syntax is like that for a unit, but it + defines a class. Roughly: + + (class/d + super-expresion + init-args + ((public var ...) + (override var ...) + (inherit var ...) + (rename (var var) ...)) + + definitions-and-expressions ...) + + - the drscheme:get/extend:extend-* functions no longer haver %s at + the end of their names. + + MINOR CHANGES AND BUG FIXES + + - bug report form cleaned up. + + - improved the welcome window (merged with about box) + + +Version 101: + +General +------- + + - The teaching libraries are now called teachpacks. See the teachpack + release notes for more information. + + - DrScheme's languages have changed (again). The langauges are now: + + - Beginning Student + - Intermediate Student + - Advanced Student + - Full Scheme, which contains: + - Graphical Full Scheme (with and without debugging), and + - Textual Full Scheme (with and without debugging) + + - Help Desk now supports bug report submissions. Please use it in + favor of the web based form. To submit a bug, follow the "Sumbit a + Bug" link near the bottom of Help Desk's front page + + - On European keyboards, the backslash character + may not work properly in DrScheme. If you + experience this problem, comment out this line: + + (map-meta "\\" "remove-space") + + in PLTHOME/collects/framework/keymap.ss. + + - For tools, invoke-library is now called invoke-teachpack. + + - Renamed two files in the graphics collection: + graphic.ss is now graphics.ss + graphics.ss is now graphicss.ss + + - DrScheme's print menu now inserts the time, date and filename in the + header of the file to be printed. + + - comment/uncomment is improved. Now, it blindly adds a semicolon to the + front of each line (and doesn't add extra semicolons on following lines) + and aways removes one semicolon (if present) from the front of each line. + + - Parenthesis highlighting now turns unmatched parens red + in addition to turning matched parenthesis regions grey. + Also (now that the caret flashes) if the caret is between two + parens, both before and after parens will be highlighted, + not just the ones before. + + Thus, every time the cursor is next to an uncommented + paren, the programmer sees some feedback about the paren. + +Version 100: + +General +------- + + - DrScheme's languages have changed. The new languages are: + + - Beginner + - Intermediate + - Advanced + - MzScheme + - MrEd + + The first three languages are essentially the same as in version + 53, except that graphics primitives have been removed. (Instead, + domain-specific graphics commands can be loaded as libraries.) The + turtles remain in the advanced language. + + The MzScheme and MrEd languages match exactly the languages + provided by the MzScheme and MrEd executables. + + - A simple algebraic stepper, dubbed The Foot, is now available. The + Foot permits users to construct a source-level evaluation trace for + programs written in the Beginner language. It will be expanded in + future releases. + + - DrScheme's Help Desk provides online help for DrScheme, its + languages, and its libraries. + + - Graphics functions were removed from the teaching languages + (Beginner, Intermediate, and Advanced), except Turtles in + Advanced. To use graphics functions, you must select a library (and + the teaching libraries are not yet updated). + + - The old viewport-based graphics library can be loaded into the MrEd + Debug language via (require-library "graphic.ss" "graphics"). + + - I/O within DrScheme is substantially improved. + + - The library and tool interfaces for extended DrScheme have + changed. + + +Version 53: + +General +------- + + - view menu items now have accelerators + + - (<= exp) isn't allowed in beginner. (same for <, >, and >=) + + - print primitive is now setup correctly to print based on the language level + + - paren-matching in semi-colon comments is disabled + + - info panel "running" message is now aligned correctly + + - The check synatax and analyze buttons are now disabled during evaluation + + - library directory now starts in "MZLIB_COLLECTS_DIR/../../lib" + which is our best approximation to "PLTHOME/lib" + + - elevator library can now select more than one floor at a time + + +Version 52: + +General +------- + +- The words "running" or "not running" at the bottom of the + DrScheme frame indicate whether or not work is happening in the + user's program. + +- a "Windows" menu has been added which keeps track of the currently + open drscheme windows. + +- the source locations for "load"ed files now match the numbers + in the bottom of the drscheme window. + +- the thread that evaluations (including execution) take place on is + the same as the eventspace's main thread, unless the evaluation + thread is killed. In that case, the eventspace's main thread is + re-generated, but the execution thread does not. + +- The REPL implementation has been cleaned up. + +- the turtles window does not survive across executions anymore + +- the Quasi-R4RS language level has been renamed to R4RS+ + +DrScheme Tools/Libraries +------------------------ + +- new methods on rep:edit%: report-exception-error accepts an exception and + prints the error message in the console. + +- send-scheme is outdated. Use run-in-evaluation-thread instead + +- the drscheme:tool^ signature has changed. A new subunit, "basis" has + been aded and the process-finish struct is now in that subunit. So, + drscheme:language:process-finish? becomes + drscheme:basis:process-finish?, etc. + + The process-finish structure no longer has a boolean indicating sucess. + Instead, an exception is raised. + + +- the settings for the language have been re-aranged + - there are two new parameters, exported from the basis + subunit of drscheme:export^, current-setting and current-vocabulary + - current-vocabulary contains the vocabulary that zodiac uses to + perform macro expansion + - current-setting is bound to a setting struct, which encapsulates + all of the information about the language level + - the process-*/zodiac and process-*/no-zodiac proceudres + are no longer methods and their arguments have changed + + +Version 51: + +General +------- +- fixed error message for "eq?" and "cons" at beginner level. + +- check syntax does not work with an unitialized repl when: + the source contains define-macro. (won't be fixed in the release) + +- eval no longer loops forever in mred vocabulary + +- searching keybindings have changed. There are four distinct actions: + action1: move keyboard focus to the searching window, opening it if necessary, + or if already there search forward + action2: move keyboard focus to the searching window, opening it if necessary, + or if already there search backward. + action3: search again, in the same direction + action4: move the focus between the main window, searching window and replacment window + action5: hide the searching window + +The actions are mapped to different keys, based on the platform. + +On unix: + action1 => control-s, meta-% + action2 => control-r + action3 => f3 + action4 => control-i + action5 => control-g + +On the macintosh: + action1 => command-f + action2 => command-r + action3 => command-g + action4 => command-o + action5 => command-. + +On windows: + action1 => control-f + action2 => control-r + action3 => f3, control-g + action4 => control-i + action5 => escape + +- turned off the file name printouts on splash screen + + evaluate: + (wx:write-resource "mred" "splashMessages" 1 (wx:find-path 'setup-file)) + to turn them back on. + +- fixed a bug that caused error messages to be displayed in message + boxes more often than neccessary. (as opposed to printing in the + repl) + +- parenthesis matching is improved + +- The empty list is now called "empty" instead of "null" with the + constructor style printer. + +- The analyze button puts up a dialog saying "please wait, loading", + now. + +- the fonts dialog now shows previews of the selected fonts. You + still need to restart to see the changes, unfortunately. + +DrScheme Tools/Libraries +------------------------ + +- tools must now import wx names explicitly, as a new first import. + +- the parameters interface has changed. Instead getting and setting + the class, the tool programmer must register a function that + accepts a class and returns a class. See the manual for more + details. + +- process/zodiac-finish has been renamed to process-finish diff --git a/notes/drscheme/OPENBUGS b/notes/drscheme/OPENBUGS new file mode 100644 index 00000000..d81a5022 --- /dev/null +++ b/notes/drscheme/OPENBUGS @@ -0,0 +1,19 @@ +Check Syntax alpha-renaming does not work with `define-struct'. + +The alpha-renaming feature of Check Syntax may miss some + identifiers. Check which identifiers will be renamed by moving the + mouse cursor over the *binding* occurrance of the variable you want + to rename. The arrows point to all known bound occurrances, which + are the identifiers that are renamed by alpha renaming. + +After breaking a long interaction several times, one of the breaks + may carry over to the next interaction. + +The yellow execute warning in the interactions window does not go away + if the user undoes all changes to the defintions window. + +Backup files don't preserve file permissions. + +For a more complete listing of known bugs, see our + +online bug report database \ No newline at end of file diff --git a/notes/mred/FONTS b/notes/mred/FONTS new file mode 100644 index 00000000..e89503d8 --- /dev/null +++ b/notes/mred/FONTS @@ -0,0 +1,410 @@ + +This file describes how to set up mappings for PostScript fonts and +complex X fonts for MrEd within a configuration file. However, you +will probably find that it's much easier to use the set-screen-name, +set-post-script-name, and set-afm-name methods provided by +the-font-name-directory. + +--------------------------------------------------- + 1. Welcome to the Weird World of MrEd Fonts +--------------------------------------------------- + +MrEd's font system is designed to appear to work gracefully across +platforms to a naive MrEd user. It is also designed to provide +complete configuration control to a knowledgeable user (this may be +especially necessary under X Windows). These are somewhat +contradictory goals, and they leave MrEd with a somewhat complex font +system. + +We'll develop terminology here to explain the working of the font +system, but don't expect these terms to be used by the MrEd +toolbox. The toolbox is designed to do what a programmer or user +probably wanted using names that a programmer or user would probably +understand intuitively. + +A "real font" is a device-speicific font used to draw or measure text +for a screen or a printer. MrEd handles three kinds of real fonts: + + * Screen fonts + * PostScript font names + * AFM font files + +An "abstract font" is a platform- and device-independent entity that +describes a font. MrEd uses 7 abstract fonts: + + * "Default" + * "Decorative" + * "Roman" + * "Script" + * "Swiss" + * "Modern" + * "System" + +The "System" abstract font is intended only for use with screen-based +controls. + +There are two basic problems: + + * Mapping abstract fonts to real fonts + * Specifying a real font without a corresponding abstract font + +The solution in the latter case is simply to let the user or +programmer invent new abstract fonts. However, the new abstract font +is associated with a core abstract font so that a suitable default +real font can be selected when no information about the new abstract +font is available. + +Abstract fonts are mapped to real fonts via the low-level setup +resource file read by MrEd at startup time. (Under X Windows, X +resources can be specified in any way, but specifying X resources +through the startup file is the preferred mechanism.) + +In the case of real fonts for an X Windows screen, it is necssary to +map not only an abstract font to a real font, but an abstract font +combined with a weight, style, and size to a real font --- hence the +insane complexity of MrEd's font system. + +--------------------------- + 1. Resource Entries +--------------------------- + +First, we consider the mechanism that maps abstract fonts to real +fonts in the case that the information is provided via resources. + +To find a font name in the resource, MrEd looks for a resource item +named by: + +