* Fixed bugs in slatex and quicksort benchmarks (library implementation)

* compiler benchmark now works (taking 10 seconds to compile on this
  machine).
This commit is contained in:
Abdulaziz Ghuloum 2007-11-04 17:00:11 -05:00
parent 8a45a5fe08
commit a1aa10fca9
7 changed files with 2322 additions and 93 deletions

20
benchmarks/benchall.ss Executable file
View File

@ -0,0 +1,20 @@
#!/usr/bin/env ikarus --r6rs-script
(import (ikarus))
(define all-benchmarks
'(ack array1 boyer browse cat compiler conform cpstak ctak dderiv
deriv destruc diviter divrec dynamic earley fft fib fibc fibfp
fpsum gcbench gcold graphs lattice matrix maze mazefun mbrot
nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2
triangl wc))
(for-each
(lambda (x)
(unless (zero? (system (format "ikarus --r6rs-script bench.ss ~a" x)))
(fprintf (standard-error-port) "ERROR: ~s failed\n" x)))
all-benchmarks)

View File

@ -1,12 +1,13 @@
(library (rnrs-benchmarks) (library (rnrs-benchmarks)
(export run-benchmark fatal-error include-source (export run-benchmark fatal-error include-source
call-with-output-file/truncate call-with-output-file/truncate fast-run
ack-iters ack-iters
array1-iters array1-iters
boyer-iters boyer-iters
browse-iters browse-iters
cat-iters cat-iters
compiler-iters
conform-iters conform-iters
cpstak-iters cpstak-iters
ctak-iters ctak-iters
@ -73,7 +74,7 @@
[(ctxt name) [(ctxt name)
(cons #'begin (cons #'begin
(with-input-from-file (with-input-from-file
(format "r6rs-benchmarks/~a" (syntax->datum #'name)) (format "rnrs-benchmarks/~a" (syntax->datum #'name))
(lambda () (lambda ()
(let f () (let f ()
(let ([x (read)]) (let ([x (read)])
@ -85,6 +86,8 @@
(define (fatal-error . args) (define (fatal-error . args)
(error 'fatal-error "~a" (error 'fatal-error "~a"
(apply (lambda (x) (format "~a" x)) args))) (apply (lambda (x) (format "~a" x)) args)))
(define fast-run (make-parameter #f))
(define (run-bench count run) (define (run-bench count run)
(unless (= count 0) (unless (= count 0)
@ -98,7 +101,9 @@
(let ([run (apply run-maker args)]) (let ([run (apply run-maker args)])
(let ([result (let ([result
(time-it name (time-it name
(lambda () (run-bench count run)))]) (if (fast-run)
run
(lambda () (run-bench count run))))])
(unless (ok? result) (unless (ok? result)
(error #f "*** wrong result ***"))))) (error #f "*** wrong result ***")))))

View File

@ -23,8 +23,7 @@
(scheme-global-eval (list 'set! var (list 'quote val)) fatal-err)) (scheme-global-eval (list 'set! var (list 'quote val)) fatal-err))
(define (scheme-global-eval expr err) (define (scheme-global-eval expr err)
;(eval expr) ;(eval expr)
(fatal-error "scheme-global-eval is no more") (fatal-error "scheme-global-eval is no more"))
)
(define (pinpoint-error filename line char) #t) (define (pinpoint-error filename line char) #t)
(define file-path-sep #\:) (define file-path-sep #\:)
(define file-ext-sep #\.) (define file-ext-sep #\.)
@ -677,8 +676,7 @@
(define ret-var-set (set-singleton ret-var)) (define ret-var-set (set-singleton ret-var))
(define closure-env-var (make-temp-var 'closure-env)) (define closure-env-var (make-temp-var 'closure-env))
(define empty-var (make-temp-var #f)) (define empty-var (make-temp-var #f))
(define make-global-environment #f) (define make-global-environment (lambda () (env-frame #f '())))
(set! make-global-environment (lambda () (env-frame #f '())))
(define (env-frame env vars) (vector (cons vars #f) '() '() env)) (define (env-frame env vars) (vector (cons vars #f) '() '() env))
(define (env-new-var! env name source) (define (env-new-var! env name source)
(let* ((glob (not (env-parent-ref env))) (let* ((glob (not (env-parent-ref env)))
@ -843,8 +841,10 @@
(cadr d) (cadr d)
(loop (cdr l)))) (loop (cdr l))))
(declaration-value name element default (env-parent-ref decls)))))) (declaration-value name element default (env-parent-ref decls))))))
(define namespace-sym (string->canonical-symbol "NAMESPACE")) (define namespace-sym
(define-namable-string-decl namespace-sym) (let ([s (string->canonical-symbol "NAMESPACE")])
(define-namable-string-decl s)
s))
(define (node-parent x) (vector-ref x 1)) (define (node-parent x) (vector-ref x 1))
(define (node-children x) (vector-ref x 2)) (define (node-children x) (vector-ref x 2))
(define (node-fv x) (vector-ref x 3)) (define (node-fv x) (vector-ref x 3))
@ -1162,16 +1162,21 @@
(define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS")) (define extended-bindings-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
(define safe-sym (string->canonical-symbol "SAFE")) (define safe-sym (string->canonical-symbol "SAFE"))
(define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED")) (define interrupts-enabled-sym (string->canonical-symbol "INTERRUPTS-ENABLED"))
(define-flag-decl ieee-scheme-sym 'dialect)
(define-flag-decl r4rs-scheme-sym 'dialect) (define dummy1
(define-flag-decl multilisp-sym 'dialect) (begin
(define-boolean-decl lambda-lift-sym) (define-flag-decl ieee-scheme-sym 'dialect)
(define-flag-decl block-sym 'compilation-strategy) (define-flag-decl r4rs-scheme-sym 'dialect)
(define-flag-decl separate-sym 'compilation-strategy) (define-flag-decl multilisp-sym 'dialect)
(define-namable-boolean-decl standard-bindings-sym) (define-boolean-decl lambda-lift-sym)
(define-namable-boolean-decl extended-bindings-sym) (define-flag-decl block-sym 'compilation-strategy)
(define-boolean-decl safe-sym) (define-flag-decl separate-sym 'compilation-strategy)
(define-boolean-decl interrupts-enabled-sym) (define-namable-boolean-decl standard-bindings-sym)
(define-namable-boolean-decl extended-bindings-sym)
(define-boolean-decl safe-sym)
(define-boolean-decl interrupts-enabled-sym)
#f))
(define (scheme-dialect decl) (define (scheme-dialect decl)
(declaration-value 'dialect #f ieee-scheme-sym decl)) (declaration-value 'dialect #f ieee-scheme-sym decl))
(define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl)) (define (lambda-lift? decl) (declaration-value lambda-lift-sym #f #t decl))
@ -3765,8 +3770,7 @@
(for-each remove-cascade! (queue->list (bbs-bb-queue bbs)))) (for-each remove-cascade! (queue->list (bbs-bb-queue bbs))))
(define (jump-lbl? branch) (define (jump-lbl? branch)
(let ((opnd (jump-opnd branch))) (if (lbl? opnd) (lbl-num opnd) #f))) (let ((opnd (jump-opnd branch))) (if (lbl? opnd) (lbl-num opnd) #f)))
(define put-poll-on-ifjump? #f) (define put-poll-on-ifjump? #t)
(set! put-poll-on-ifjump? #t)
(define (bbs-remove-dead-code! bbs) (define (bbs-remove-dead-code! bbs)
(let ((new-bb-queue (queue-empty)) (scan-queue (queue-empty))) (let ((new-bb-queue (queue-empty)) (scan-queue (queue-empty)))
(define (reachable ref bb) (define (reachable ref bb)
@ -4703,9 +4707,12 @@
(define generic-sym (string->canonical-symbol "GENERIC")) (define generic-sym (string->canonical-symbol "GENERIC"))
(define fixnum-sym (string->canonical-symbol "FIXNUM")) (define fixnum-sym (string->canonical-symbol "FIXNUM"))
(define flonum-sym (string->canonical-symbol "FLONUM")) (define flonum-sym (string->canonical-symbol "FLONUM"))
(define-namable-decl generic-sym 'arith) (define dummy2
(define-namable-decl fixnum-sym 'arith) (begin
(define-namable-decl flonum-sym 'arith) (define-namable-decl generic-sym 'arith)
(define-namable-decl fixnum-sym 'arith)
(define-namable-decl flonum-sym 'arith)
#f))
(define (arith-implementation name decls) (define (arith-implementation name decls)
(declaration-value 'arith name generic-sym decls)) (declaration-value 'arith name generic-sym decls))
(define (cf source target-name . opts) (define (cf source target-name . opts)
@ -4736,8 +4743,7 @@
(if (and info-port (not (eq? info-port (current-output-port)))) (if (and info-port (not (eq? info-port (current-output-port))))
(close-output-port info-port)) (close-output-port info-port))
result)) result))
(define wrap-program #f) (define wrap-program (lambda (program) program))
(set! wrap-program (lambda (program) program))
(define (compile-program program target-name opts module-name dest info-port) (define (compile-program program target-name opts module-name dest info-port)
(define (compiler-body) (define (compiler-body)
(if (not (valid-module-name? module-name)) (if (not (valid-module-name? module-name))
@ -5231,12 +5237,9 @@
(make-poll (make-poll
(or (poll-since-entry? poll) (poll-since-entry? other-poll)) (or (poll-since-entry? poll) (poll-since-entry? other-poll))
(max (poll-delta poll) (poll-delta other-poll)))) (max (poll-delta poll) (poll-delta other-poll))))
(define poll-period #f) (define poll-period 90)
(set! poll-period 90) (define poll-head 15)
(define poll-head #f) (define poll-tail 15)
(set! poll-head 15)
(define poll-tail #f)
(set! poll-tail 15)
(define (entry-context proc closed) (define (entry-context proc closed)
(define (empty-vars-list n) (define (empty-vars-list n)
(if (> n 0) (cons empty-var (empty-vars-list (- n 1))) '())) (if (> n 0) (cons empty-var (empty-vars-list (- n 1))) '()))
@ -6961,17 +6964,11 @@
(define ofile-nl char-newline) (define ofile-nl char-newline)
(define ofile-tab char-tab) (define ofile-tab char-tab)
(define ofile-asm? '()) (define ofile-asm? '())
(set! ofile-asm? '()) (define ofile-asm-bits? #f)
(define ofile-asm-bits? '()) (define ofile-asm-gvm? #f)
(set! ofile-asm-bits? #f)
(define ofile-asm-gvm? '())
(set! ofile-asm-gvm? #f)
(define ofile-stats? '()) (define ofile-stats? '())
(set! ofile-stats? '())
(define ofile-add-obj '()) (define ofile-add-obj '())
(set! ofile-add-obj '())
(define ofile-syms '()) (define ofile-syms '())
(set! ofile-syms '())
(define (ofile-word n) (define (ofile-word n)
(let ((n (modulo n 65536))) (let ((n (modulo n 65536)))
(if (and ofile-asm? ofile-asm-bits?) (if (and ofile-asm? ofile-asm-bits?)
@ -7142,6 +7139,7 @@
'fixnum) 'fixnum)
((and (inexact? (real-part obj)) ((and (inexact? (real-part obj))
(zero? (imag-part obj)) (zero? (imag-part obj))
;;; AZIZ: test looks wrong
(exact? (imag-part obj))) (exact? (imag-part obj)))
'flonum) 'flonum)
(else 'subtyped))) (else 'subtyped)))
@ -8657,8 +8655,7 @@
(define closure-alloc-trap 15) (define closure-alloc-trap 15)
(define intr-trap 24) (define intr-trap 24)
(define cache-line-length 16) (define cache-line-length 16)
(define polling-intermittency '()) (define polling-intermittency 10)
(set! polling-intermittency 10)
(define (stat-clear!) (set! *stats* (cons 0 '()))) (define (stat-clear!) (set! *stats* (cons 0 '())))
(define (stat-dump!) (emit-stat (cdr *stats*))) (define (stat-dump!) (emit-stat (cdr *stats*)))
(define (stat-add! bin count) (define (stat-add! bin count)
@ -10434,6 +10431,8 @@
(if (or fix-safe? (not (safe? decls))) fix-spec proc)) (if (or fix-safe? (not (safe? decls))) fix-spec proc))
((eq? arith flonum-sym) (if (not (safe? decls)) flo-spec proc)) ((eq? arith flonum-sym) (if (not (safe? decls)) flo-spec proc))
(else proc))))))) (else proc)))))))
(define dummy3
(begin
(define-apply "##TYPE" #f (lambda (opnds loc sn) (gen-type opnds loc sn))) (define-apply "##TYPE" #f (lambda (opnds loc sn) (gen-type opnds loc sn)))
(define-apply (define-apply
"##TYPE-CAST" "##TYPE-CAST"
@ -11136,57 +11135,57 @@
(let ((targ (make-target 4 'm68000))) (let ((targ (make-target 4 'm68000)))
(target-begin!-set! targ (lambda (info-port) (begin! info-port targ))) (target-begin!-set! targ (lambda (info-port) (begin! info-port targ)))
(put-target targ)) (put-target targ))
)) ; dummy3
(define input-source-code ' (define input-source-code '
(begin (begin
(declare (standard-bindings) (fixnum) (not safe) (block)) (declare (standard-bindings) (fixnum) (not safe) (block))
(define (fib n)
(define (fib n) (if (< n 2)
(if (< n 2) n
n (+ (fib (- n 1))
(+ (fib (- n 1)) (fib (- n 2)))))
(fib (- n 2)))))
(define (tak x y z)
(define (tak x y z) (if (not (< y x))
(if (not (< y x)) z
z (tak (tak (- x 1) y z)
(tak (tak (- x 1) y z) (tak (- y 1) z x)
(tak (- y 1) z x) (tak (- z 1) x y))))
(tak (- z 1) x y))))
(define (ack m n)
(define (ack m n) (cond ((= m 0) (+ n 1))
(cond ((= m 0) (+ n 1)) ((= n 0) (ack (- m 1) 1))
((= n 0) (ack (- m 1) 1)) (else (ack (- m 1) (ack m (- n 1))))))
(else (ack (- m 1) (ack m (- n 1))))))
(define (create-x n)
(define (create-x n) (define result (make-vector n))
(define result (make-vector n)) (do ((i 0 (+ i 1)))
(do ((i 0 (+ i 1))) ((>= i n) result)
((>= i n) result) (vector-set! result i i)))
(vector-set! result i i)))
(define (create-y x)
(define (create-y x) (let* ((n (vector-length x))
(let* ((n (vector-length x)) (result (make-vector n)))
(result (make-vector n))) (do ((i (- n 1) (- i 1)))
(do ((i (- n 1) (- i 1))) ((< i 0) result)
((< i 0) result) (vector-set! result i (vector-ref x i)))))
(vector-set! result i (vector-ref x i)))))
(define (my-try n)
(define (my-try n) (vector-length (create-y (create-x n))))
(vector-length (create-y (create-x n))))
(define (go n)
(define (go n) (let loop ((repeat 100)
(let loop ((repeat 100) (result 0))
(result 0)) (if (> repeat 0)
(if (> repeat 0) (loop (- repeat 1) (my-try n))
(loop (- repeat 1) (my-try n)) result)))
result)))
(+ (fib 20)
(+ (fib 20) (tak 18 12 6)
(tak 18 12 6) (ack 3 9)
(ack 3 9) (go 200000))
(go 200000)) ))
))
(define output-expected '( (define output-expected '(
"|------------------------------------------------------" "|------------------------------------------------------"

View File

@ -3,7 +3,7 @@
(library (rnrs-benchmarks quicksort) (library (rnrs-benchmarks quicksort)
(export main) (export main)
(import (rnrs) (rnrs mutable-pairs) (rnrs-benchmarks)) (import (except (rnrs) partition) (rnrs mutable-pairs) (rnrs-benchmarks))
(define (quick-1 v less?) (define (quick-1 v less?)

View File

@ -0,0 +1,547 @@
% slatex.sty
% SLaTeX v. 2.2
% style file to be used in (La)TeX when using SLaTeX
% (c) Dorai Sitaram, Rice U., 1991, 1994
% 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, slatex-d.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\def\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{\leavevmode\hbox\bgroup\vbox\bgroup
\def\={\cleartabs&} \def\>{&} \def\\{\cr\tabalign} \tabalign}
\def\endlat@xtabbing{\cr\egroup\egroup}
%new
\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
\def\checkfollpar{\futurelet\next\checkfollparII}
\def\checkfollparII{\ifx\next\par\let\next\relax
\else\par\noindent\let\next\ignorespaces\fi\next}
% 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}}
\def\schemecodehook{}
%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
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\def\lat@xtabbingleftmost{\hskip\leftcodeskip\relax}%
\lat@xtabbing}
\def\endZZZZschemeprogram{\endlat@xtabbing
\endgroup
\vskip\belowcodeskip
\ifusinglatex\let\next\@endparenv
\else\let\next\checkfollpar\fi\next}
\def\ZZZZschemeprogramII{\vskip\abovecodeskip
\begingroup
\noindent
%\schemecodehook %\ZZZZschemebox already has it
\hskip\leftcodeskip
\ZZZZschemebox}
\def\endZZZZschemeprogramII{\endZZZZschemebox
\hskip\rightcodeskip
\endgroup
\vskip\belowcodeskip
\ifusinglatex\let\next\@endparenv
\else\let\next\checkfollpar\fi\next}
%
\def\ZZZZschemebox{%
\leavevmode\hbox\bgroup\vbox\bgroup
\schemecodehook
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\lat@xtabbing}
\def\endZZZZschemebox{\endlat@xtabbing
\egroup\egroup\ignorespaces}
%in-text
\def\ZZZZschemecodeintext{\begingroup
\let\sy\keywordfont \let\cn\constantfont
\let\va\variablefont \let\dt\datafont}
\def\endZZZZschemecodeintext{\endgroup\ignorespaces}
\def\ZZZZschemeresultintext{\begingroup
\let\sy\datafont \let\cn\constantfont
\let\va\datafont \let\dt\datafont}
\def\endZZZZschemeresultintext{\endgroup\ignorespaces}
% \comm@nt<some-char>...text...<same-char> comments out
% TeX source analogous to
% \verb<some-char>...text...<same-char>. 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
% input file if possible, else relax
\def\inputifpossible#1{%
\immediate\openin0=#1\relax%
\ifeof0\relax\else\input#1\relax\fi%
\immediate\closein0}
\def\ZZZZinput#1{\input#1\relax}
% you may replace the above by
%
% \def\ZZZZinput#1{\inputifpossible{#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[%
|global|advance|sch@mefilenamecount by 1|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemedisplaytoken{schemedisplay}
\def\undefschemedisplaytoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% \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\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
\comm@nt}}
\defschemetoken{scheme}
\def\undefschemetoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% \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}...}
\def\defschemeresulttoken#1{%
\long\expandafter\def\csname#1\endcsname{%
\global\advance\sch@mefilenamecount by 1\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
\comm@nt}}
\defschemeresulttoken{schemeresult}
\def\undefschemeresulttoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% 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|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemeboxtoken{schemebox}
\def\undefschemeboxtoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% for wholesale dumping of all-Scheme files into TeX (converting
% .scm files to .tex),
% use
% \schemeinput{<filename>}
% .scm, .ss, .s extensions optional
\def\defschemeinputtoken#1{%
\long\expandafter\gdef\csname#1\endcsname##1{%
\global\advance\sch@mefilenamecount by 1\relax%
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}}
\defschemeinputtoken{schemeinput}
\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
\begingroup\catcode`\|=0\catcode`\[=1\catcode`\]=2%
\catcode`\{=12\catcode`\}=12\catcode`\\=12%
|gdef|defschemeregiontoken#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|relax%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\defschemeregiontoken{schemeregion}
\def\undefschemeregiontoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% 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
% \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
\inputifpossible{xZfilhid.tex}
% @ is no longer a letter for TeX
\ifusinglatex\relax\else
\catcode`@\atcatcodebeforeslatex
\fi
\message{*** Check: Are you sure you called SLaTeX? ***}

File diff suppressed because it is too large Load Diff

View File

@ -10,7 +10,7 @@
(rnrs) (rnrs)
(rnrs unicode) (rnrs unicode)
(rnrs mutable-pairs) (rnrs mutable-pairs)
(rnrs i/o simple) (rnrs io simple)
(rnrs-benchmarks)) (rnrs-benchmarks))
(define *op-sys* 'unix) (define *op-sys* 'unix)