suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Split almost everything else from the main repository.

Browse Source 
The source to the split packages is in repositories under the
`racket` organization on GitHub. The repositories are all named
according to the pkg name, except for multiple-package
repositories such as `racket/compiler` which is named based on the
old directory name without the `-pkgs` suffix. Thus

   `pkgs/compiler-pkgs` -> https://github.com/racket/compiler

The Makefile has also been adjusted to pull packages from the
catalog when you type `make`. This currently relies on some tricks
that will break if you try to specify a particular set of `PKGS` on
the command line. We plan to improve this soon.

The packages in `pkgs/racket-pkgs` and `pkgs/base` are staying in
the repository, since they logically belong with the core code.

The `plt-services` package is still in the repository, but will
move out soon.
This commit is contained in:
Sam Tobin-Hochstadt 2014-12-04 00:34:49 -05:00
parent f3dba3eb6b
commit 2987338218
7317 changed files with 21 additions and 992171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Makefile
View File

@ -21,7 +21,9 @@
# Packages (separated by spaces) to link in development mode or
# to include in a distribution:
PKGS = main-distribution plt-services
PKGS = base racket-lib # plt-services
LINK_PKGS = $(PKGS) racket-doc at-exp-lib racket-test racket-benchmarks racket-index
INSTALL_PKGS = main-distribution main-distribution-test
# ------------------------------------------------------------
# In-place build
@ -29,6 +31,10 @@ PKGS = main-distribution plt-services
PLAIN_RACKET = racket/bin/racket
WIN32_PLAIN_RACKET = racket\racket
PLAIN_RACO = racket/bin/racket -N raco -l- raco
WIN32_PLAIN_RACO = racket\racket -N raco -l- raco
MACOSX_CHECK_ARGS = -I racket/base -e '(case (system-type) [(macosx) (exit 0)] [else (exit 1)])'
MACOSX_CHECK = $(PLAIN_RACKET) -G build/config $(MACOSX_CHECK_ARGS)
@ -46,6 +52,7 @@ cpus-in-place:
# Explicitly propagate variables for non-GNU `make's:
PKG_LINK_COPY_ARGS = PKGS="$(PKGS)" LINK_MODE="$(LINK_MODE)"
PKG_LINK_COPY_EXTRA_ARGS = PKGS="$(LINK_PKGS)" LINK_MODE="$(LINK_MODE)"
LIBSETUP = -N raco -l- raco setup
plain-in-place:
@ -53,6 +60,9 @@ plain-in-place:
if $(MACOSX_CHECK) ; then $(MAKE) native-from-git ; fi
$(MAKE) pkg-links $(PKG_LINK_COPY_ARGS)
$(PLAIN_RACKET) $(LIBSETUP) $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
$(MAKE) pkg-extra-links $(PKG_LINK_COPY_EXTRA_ARGS) # NOTE: no setup after this step
$(PLAIN_RACO) pkg install $(JOB_OPTIONS) --scope installation \
--deps search-auto $(INSTALL_PKGS)
# For Windows: set up the following collections first, so that native
# libraries are in place for use by a full setup:
@ -63,6 +73,8 @@ win32-in-place:
$(MAKE) win32-pkg-links $(PKG_LINK_COPY_ARGS)
$(WIN32_PLAIN_RACKET) $(LIBSETUP) -nxiID $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS) $(LIB_PRE_COLLECTS)
$(WIN32_PLAIN_RACKET) $(LIBSETUP) $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
$(WIN32_PLAIN_RACO) pkg install $(JOB_OPTIONS) --scope installation \
--deps search-auto $(INSTALL_PKGS)
again:
$(MAKE) LINK_MODE="--restore"
@ -96,6 +108,7 @@ plain-unix-style:
$(MAKE) local-catalog-maybe-native RACKET="$(DESTDIR)$(PREFIX)/bin/racket"
"$(DESTDIR)$(PREFIX)/bin/raco" pkg install $(UNIX_RACO_ARGS) $(REQUIRED_PKGS) $(PKGS)
cd racket/src/build; $(MAKE) fix-paths
"$(DESTDIR)$(PREFIX)/bin/raco" pkg install $(JOB_OPTIONS) -i --dep search-auto $(INSTALL_PKGS)
error-need-prefix:
: ================================================================
@ -302,6 +315,9 @@ LINK_ALL = -U -G build/config racket/src/link-all.rkt ++dir pkgs ++dir native-pk
pkg-links:
$(PLAIN_RACKET) $(LINK_ALL) $(LINK_MODE) $(PKGS) $(REQUIRED_PKGS)
pkg-extra-links:
$(PLAIN_RACKET) $(LINK_ALL) $(LINK_MODE) $(LINK_PKGS) $(REQUIRED_PKGS)
win32-pkg-links:
IF NOT EXIST native-pkgs\racket-win32-i386 $(MAKE) complain-no-submodule
$(MAKE) pkg-links PLAIN_RACKET="$(WIN32_PLAIN_RACKET)" LINK_MODE="$(LINK_MODE)" PKGS="$(PKGS)"

11
pkgs/algol60/LICENSE.txt
View File

@ -1,11 +0,0 @@
algol60
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

55
pkgs/algol60/algol60.rkt
View File

@ -1,55 +0,0 @@
#cs(module algol60 mzscheme
(require-for-syntax "parse.rkt"
;; Parses to generate an AST. Identifiers in the AST
;; are represented as syntax objects with source location.
"simplify.rkt"
;; Desugars the AST, transforming `for' to `if'+`goto',
;; and flattening `if' statements so they are always
;; of the for `if <exp> then goto <label> else goto <label>'
"compile.rkt"
;; Compiles a simplified AST to Scheme.
mzlib/file)
;; By using #'here for the context of identifiers
;; introduced by compilation, the identifiers can
;; refer to runtime functions and primitives, as
;; well as mzscheme:
(require "runtime.rkt" "prims.rkt")
(provide include-algol literal-algol)
(define-syntax (include-algol stx)
(syntax-case stx ()
[(_ str)
(string? (syntax-e (syntax str)))
(compile-simplified
(simplify
(parse-a60-file
(normalize-path (syntax-e (syntax str))
(or
(current-load-relative-directory)
(current-directory))))
#'here)
#'here)]))
(define-syntax (literal-algol stx)
(syntax-case stx ()
[(_ strs ...)
(andmap (λ (x) (string? (syntax-e x)))
(syntax->list (syntax (strs ...))))
(compile-simplified
(simplify
(parse-a60-port
(open-input-string
(apply
string-append
(map syntax-e (syntax->list #'(strs ...)))))
(syntax-source stx))
#'here)
#'here)])))

90
pkgs/algol60/algol60.scrbl
View File

@ -1,90 +0,0 @@
#lang scribble/doc
@(require scribble/manual
(for-label algol60/algol60))
@title{Algol 60}
@section{Implementation}
The ``Algol 60'' language for DrRacket implements the language defined
by the ``Revised Report on the Algorithmic Language Algol 60,'' edited
by Peter Naur.
@section{Including Algol 60 Programs}
Although Algol 60 is mainly provided as a DrRacket language,
@racket[include-algol] supports limited use of Algol 60 programs in
larger programs.
@defmodule[algol60/algol60]
@defform[(include-algol path-string)]{
Includes the Algol 60 program indicated by @racket[path-string] as an
expression in a Racket program. The included Algol 60 program is
closed (i.e., it doesn't see any bindings in the included context),
and the result is always @|void-const|.}
@defform[(literal-algol string ...)]{
Evaluates the Algol 60 program indicated by the literal @racket[string]s
as an expression in a Racket program. The Algol 60 program is
closed (i.e., it doesn't see any bindings in the included context),
and the result is always @|void-const|.
This is generally useful when combined with the @racketmodname[at-exp] reader,
e.g.,
@codeblock|{
#lang at-exp racket
@literal-algol{
begin
printsln (`hello world')
end
}
}|
}
@section{Language}
The DrRacket and @racket[include-algol] implementation departs from
the Algol 60 specification in the following minor ways:
@(itemize (item "Strings are not permitted to contain nested quotes.")
(item "Identifiers cannot contain whitespace.")
(item "Argument separators are constrained to be identifiers (i.e., they
cannot be keywords, and they cannot consist of multiple
identifiers separated by whitespace.)")
(item "Numbers containing exponents (using the ``10'' subscript) are not
supported."))
Identifiers and keywords are case-sensitive. The boldface/underlined
keywords of the report are represented by the obvious character
sequence, as are most operators. A few operators do not fit into
ASCII, and they are mapped as follows:
@(verbatim
" times *
quotient div
exponential ^
less or equal <=
greater or equal >=
not equal !=
equivalence ==
implication =>
and &
or |
negation !")
In addition to the standard functions, the following output functions
are supported:
@(verbatim
" prints(E) prints the string E
printsln(E) prints the string E followed by a newline
printn(E) prints the number E
printnln(E) prints the number E followed by a newline")
A prompt in DrRacket's interactions area accepts whole programs only
for the Algol 60 language.

10
pkgs/algol60/base.rkt
View File

@ -1,10 +0,0 @@
(module base mzscheme
(require "prims.rkt"
"runtime.rkt")
(define base-importing-stx #'here)
(provide (all-from mzscheme)
(all-from "prims.rkt")
(all-from "runtime.rkt")
base-importing-stx))

35
pkgs/algol60/bd-tool.rkt
View File

@ -1,35 +0,0 @@
#lang s-exp framework/private/decode
jVTJbtswEL3rK6YujJBFmbhGFyBAF/TUc69BAlDiWGJCkSpJ2/HfdyhKka04TXmwoZk3bxa+Y
c E 8 / t l q j
9 \ B \ \ \ \ \6V\ \ \ \ \OB\ \l9\ \ \ \ \YD\xq\jI\yh\ P
F j a 3 U E 5 Y e v 6 J z h R c
EUb\rRF \8K\4s\ \ D6J\U8v \C9\AG\ \AGI 7AbB \ \ \ \ S xg5\awK
4 p u S E Y F V W + / R R j
G \YO\b/\ lBK\cA\ \ \ \aQ\ \ \n8\ \ \ FVi\Ci\db\Z2\ \ID\i8\ I
V P R q J O p j W n M +
Utd\S3\ \ \ \ \ \ \Kt\hg\YTqvo\D2\vl\Aw\pX\ 3mM\VC\ \R1\b2\ S 1
H H 3 n L r T Z K d J
L \yscoZ\Qyjtb\DY\sp\Km\d+\ \ \ \bxacF\iU\ \ \ 6 \vK\+q\ \ \ x
e n y Y 2 O 0 e A r + W k U
7 \ \ 2 \ \gW\Zf\tK\KU\eH\ \ \ \Xa\ \ X \ BEV\/u\ \ \ \ D
m q M Y q 9 V b D h 8 5 P 8 d 0
aCum5h\ \C+O0s\ 6EZ\V5\6o\Rq\lp\ \ \ \C2Y \ \6Xk \ \ p \ l 7
W s I H o g y V N A i r y / W
n /uc\cT\ \ H \ \m5F5lu \ LGY\ \Fq\5c\IB\+Db \ \ \ \ z \ R
G A C u i H 3 H m 3 0 w
ohK\e3\HNHWR\ \ dFh\ka\ \ \wF\ \Mt\53\ z \ \ \ \SZ\eh\arDF6\ 2
S / I z a G j 8 8 d
I \ht\DDxgusWt\kw\A+\ w \c1\rN\re\ u \5N\c/\M4r4v\Qm\y8\ \ \bH\EJY
d u h X / Y d s
L \wx\2Z\Jb\Yto26\Gl\10\p2U2x\ \ \h7\ \ \eV\k0Q8u\sB\ w ttQ5Q2\ 6
n 5 N + O j L e Y f Z 5
ODhg \ \ \ \x0HZM\8kJnas \zN\H2\ \Qv6 \ \ \ \ \ \ Mly\2p\Nq1
D 8 g P u 4 o n O p n 0 +
F \o3S \0rh6C\ Ytf\su\ \ s \ \O8\ \FP\72J D03\8P\vt\AZ\vFula\ b
2 d 6 P S F o M Q R Z 0 w Q H
o \ \ah\ \ \ \ \/g\Yc\ \ e \ \59\ \ \ \ mekqmzi \ zHvD 5
C P C o T Q u H 2 q 8 f x K
5 \XP\BSucV\ \ \+j\no\lC\P2\ \ \78\Lk\iw\da\kw\u6\ \ \PZ\ob\ q s
m Z o 5 7
fBFSNtDWKqqHXiB7IqWDy0btkw9A+GJ7Z2L4h2Oy9YU9ipwxX+Bgp23X+OxIsnBVxmgMv/gI=

BIN
pkgs/algol60/bd.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 1.3 KiB

7
pkgs/algol60/cfg-parser.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
;; Legacy module. cfg-parser used to live in the algol60 collection.
;; This module re-exports its contents for backwards compatibility.
(require parser-tools/cfg-parser)
(provide (all-from-out parser-tools/cfg-parser))

536
pkgs/algol60/compile.rkt
View File

@ -1,536 +0,0 @@
#cs(module compile mzscheme
(require "parse.rkt"
mzlib/match
mzlib/list)
(provide compile-simplified)
;; The compiler generates references to "prims.rkt" and
;; "runtime.rkt" exports, as well as Racket forms
;; and functions. The `ctx' argument provides
;; an appropriate context for those bindings (in
;; the form of a syntax object to use with d->s-o).
(define (compile-simplified stmt ctx)
(datum->syntax-object
ctx
(parameterize ([current-compile-context ctx])
(compile-a60 stmt 'void (empty-context) #t))))
(define current-compile-context (make-parameter #f))
(define (compile-a60 stmt next-label context add-to-top-level?)
(match stmt
[($ a60:block decls statements)
(compile-block decls statements next-label context add-to-top-level?)]
[else
(compile-statement stmt next-label context)]))
(define (compile-block decls statements next-label context add-to-top-level?)
(let* ([labels-with-numbers (map car statements)]
[labels (map (lambda (l)
(if (stx-number? l)
(datum->syntax-object
l
(string->symbol (format "~a" (syntax-e l)))
l
l)
l))
labels-with-numbers)]
;; Build environment by adding labels, then decls:
[context (foldl (lambda (decl context)
(match decl
[($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
(add-procedure context var result-type arg-vars by-value-vars arg-specs)]
[($ a60:type-decl type ids)
(add-atoms context ids type)]
[($ a60:array-decl type arrays)
(add-arrays context
(map car arrays) ; names
(map cdr arrays) ; dimensions
type)]
[($ a60:switch-decl name exprs)
(add-switch context name)]))
(add-labels
context
labels)
decls)])
;; Generate bindings and initialization for all decls,
;; plus all statements (thunked):
(let ([bindings
(append
(apply
append
;; Decls:
(map (lambda (decl)
(match decl
[($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
(let ([code
`(lambda (kont . ,arg-vars)
;; Extract by-value variables
(let ,(map (lambda (var)
`[,var (get-value ,var)])
by-value-vars)
;; Set up the result variable and done continuation:
,(let ([result-var (gensym 'prec-result)]
[done (gensym 'done)])
`(let* ([,result-var undefined]
[,done (lambda () (kont ,result-var))])
;; Include the compiled body:
,(compile-a60 body done
(add-settable-procedure
(add-bindings
context
arg-vars
by-value-vars
arg-specs)
var
result-type
result-var)
#f)))))])
(if add-to-top-level?
`([,var
(let ([tmp ,code])
(namespace-set-variable-value! ',var tmp)
tmp)])
`([,var
,code])))]
[($ a60:type-decl type ids)
(map (lambda (id) `[,id undefined]) ids)]
[($ a60:array-decl type arrays)
(map (lambda (array)
`[,(car array) (make-array
,@(apply
append
(map
(lambda (bp)
(list
(compile-expression (car bp) context 'num)
(compile-expression (cdr bp) context 'num)))
(cdr array))))])
arrays)]
[($ a60:switch-decl name exprs)
`([,name (make-switch ,@(map (lambda (e) `(lambda () ,(compile-expression e context 'des)))
exprs))])]
[else (error "can't compile decl")]))
decls))
;; Statements: most of the work is in `compile-statement', but
;; we provide the continuation label:
(cdr
(foldr (lambda (stmt label next-label+compiled)
(cons label
(cons
`[,label
(lambda ()
,(compile-statement (cdr stmt)
(car next-label+compiled)
context))]
(cdr next-label+compiled))))
(cons next-label null)
statements
labels)))])
;; Check for duplicate bindings:
(let ([dup (check-duplicate-identifier (filter identifier? (map car bindings)))])
(when dup
(raise-syntax-error
#f
"name defined twice"
dup)))
;; Generate code; body of leterec jumps to the first statement label.
`(letrec ,bindings
(,(caar statements))))))
(define (compile-statement statement next-label context)
(match statement
[($ a60:block decls statements)
(compile-block decls statements next-label context #f)]
[($ a60:branch test ($ a60:goto then) ($ a60:goto else))
`(if (check-boolean ,(compile-expression test context 'bool))
(goto ,(check-label then context))
(goto ,(check-label else context)))]
[($ a60:goto label)
(at (expression-location label)
`(goto ,(compile-expression label context 'des)))]
[($ a60:dummy)
`(,next-label)]
[($ a60:call proc args)
(at (expression-location proc)
`(,(compile-expression proc context 'func)
(lambda (val)
(,next-label))
,@(map (lambda (arg) (compile-argument arg context))
args)))]
[($ a60:assign vars val)
;; >>>>>>>>>>>>>>> Start clean-up here <<<<<<<<<<<<<<<<<
;; Lift out the spec-finding part, and use it to generate
;; an expected type that is passed to `compile-expression':
`(begin
(let ([val ,(compile-expression val context 'numbool)])
,@(map (lambda (avar)
(let ([var (a60:variable-name avar)])
(at var
(cond
[(null? (a60:variable-indices avar))
(cond
[(call-by-name-variable? var context)
=> (lambda (spec)
`(set-target! ,var ',var (coerce ',(spec-coerce-target spec null) val)))]
[(procedure-result-variable? var context)
`(set! ,(procedure-result-variable-name var context)
(coerce ',(spec-coerce-target (procedure-result-spec var context) null) val))]
[(or (settable-variable? var context)
(array-element? var context))
=> (lambda (spec)
`(,(if (own-variable? var context) 'set-box! 'set!)
,var
(coerce ',(spec-coerce-target spec null) val)))]
[else (raise-syntax-error #f "confused by assignment" (expression-location var))])]
[else
(let ([spec (or (array-element? var context)
(call-by-name-variable? var context))])
`(array-set! ,(compile-expression (make-a60:variable var null) context 'numbool)
(coerce ',(spec-coerce-target spec null) val)
,@(map (lambda (e) (compile-expression e context 'num))
(a60:variable-indices avar))))]))))
vars))
(,next-label))]
[else (error "can't compile statement")]))
(define (compile-expression expr context type)
(match expr
[(? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n)
(if (eq? type 'des)
;; Need a label:
(check-label (datum->syntax-object expr
(string->symbol (number->string (syntax-e expr)))
expr
expr)
context)
;; Normal use of a number:
(begin
(check-type 'num type expr)
(as-builtin n)))]
[(? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n) (check-type 'bool type expr) (as-builtin n)]
[(? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n) (check-type 'string type expr) (as-builtin n)]
[(? identifier? i) (compile-expression (make-a60:variable i null) context type)]
[(? symbol? i) ; either a generated label or 'val:
(unless (eq? expr 'val)
(check-type 'des type expr))
(datum->syntax-object #f i)]
[($ a60:subscript array index)
;; Maybe a switch index, or maybe an array reference
(at array
(cond
[(array-element? array context)
`(array-ref ,array ,(compile-expression index context 'num))]
[(switch-variable? array context)
`(switch-ref ,array ,(compile-expression index context 'num))]
[else (raise-syntax-error
#f
"confused by variable"
array)]))]
[($ a60:binary t argt op e1 e2)
(check-type t type expr)
(at op
`(,(as-builtin op) ,(compile-expression e1 context argt) ,(compile-expression e2 context argt)))]
[($ a60:unary t argt op e1)
(check-type t type expr)
(at op
`(,(as-builtin op) ,(compile-expression e1 context argt)))]
[($ a60:variable var subscripts)
(let ([sub (lambda (wrap v)
(wrap
(if (null? subscripts)
v
`(array-ref ,v ,@(map (lambda (e) (compile-expression e context 'num)) subscripts)))))])
(cond
[(call-by-name-variable? var context)
=> (lambda (spec)
(check-spec-type spec type var subscripts)
(sub (lambda (val) `(coerce ',(spec-coerce-target spec subscripts) ,val)) `(get-value ,var)))]
[(primitive-variable? var context)
=> (lambda (name)
(sub values
(datum->syntax-object
(current-compile-context)
name
var
var)))]
[(and (procedure-result-variable? var context)
(not (eq? type 'func)))
(unless (null? subscripts)
(raise-syntax-error "confused by subscripts" var))
(let ([spec (procedure-result-spec var context)])
(check-spec-type spec type var null)
(at var
`(coerce
',(spec-coerce-target spec null)
,(procedure-result-variable-name var context))))]
[(or (procedure-result-variable? var context)
(procedure-variable? var context)
(label-variable? var context)
(settable-variable? var context)
(array-element? var context))
=> (lambda (spec)
(let ([spec (if (or (procedure-result-variable? var context)
(procedure-variable? var context)
(and (array-element? var context)
(null? subscripts)))
#f ;; need just the proc or array...
spec)])
(check-spec-type spec type var subscripts)
(let ([target (spec-coerce-target spec subscripts)])
(sub (if target
(lambda (v) `(coerce ',target ,v))
values)
(if (own-variable? var context)
`(unbox ,var)
var)))))]
[else (raise-syntax-error
#f
"confused by expression"
(expression-location var))]))]
[($ a60:app func args)
(at (expression-location func)
`(,(compile-expression func context 'func)
values
,@(map (lambda (e) (compile-argument e context))
args)))]
[($ a60:if test then else)
`(if (check-boolean ,(compile-expression test context 'bool))
,(compile-expression then context type)
,(compile-expression else context type))]
[else (error 'compile-expression "can't compile expression ~a" expr)]))
(define (expression-location expr)
(if (syntax? expr)
expr
(match expr
[($ a60:subscript array index) (expression-location array)]
[($ a60:binary type argtype op e1 e2) op]
[($ a60:unary type argtype op e1) op]
[($ a60:variable var subscripts) (expression-location var)]
[($ a60:app func args)
(expression-location func)]
[else #f])))
(define (compile-argument arg context)
(cond
[(or (and (a60:variable? arg)
(not (let ([v (a60:variable-name arg)])
(or (procedure-variable? v context)
(label-variable? v context)
(primitive-variable? v context)))))
(a60:subscript? arg))
(let ([arg (if (a60:subscript? arg)
(make-a60:variable (a60:subscript-array arg)
(list (a60:subscript-index arg)))
arg)])
`(case-lambda
[() ,(compile-expression arg context 'any)]
[(val) ,(compile-statement (make-a60:assign (list arg) 'val) 'void context)]))]
[(identifier? arg)
(compile-argument (make-a60:variable arg null) context)]
[else `(lambda () ,(compile-expression arg context 'any))]))
(define (check-type got expected expr)
(or (eq? expected 'any)
(case got
[(num) (memq expected '(num numbool))]
[(bool) (memq expected '(bool numbool))]
[(des) (memq expected '(des))]
[(func) (memq expected '(func))]
[else #f])
(raise-syntax-error #f
(format "type mismatch (~a != ~a)" got expected)
expr)))
(define (check-spec-type spec type expr subscripts)
(let ([target (spec-coerce-target spec subscripts)])
(when target
(case (syntax-e target)
[(integer real) (check-type 'num type expr)]
[(boolean) (check-type 'bool type expr)]
[(procedure) (check-type 'func type expr)]))))
(define (check-label l context)
(if (or (symbol? l)
(label-variable? l context))
l
(raise-syntax-error
#f
"undefined label"
l)))
(define (at stx expr)
(if (syntax? stx)
(datum->syntax-object (current-compile-context) expr stx)
expr))
(define (as-builtin stx)
;; Preserve source loc, but change to reference to
;; a builtin operation by changing the context:
(datum->syntax-object
(current-compile-context)
(syntax-e stx)
stx
stx))
;; --------------------
(define (empty-context)
`(((sign prim sign)
(entier prim entier)
(sin prim a60:sin)
(cos prim a60:cos)
(acrtan prim a60:arctan)
(sqrt prim a60:sqrt)
(abs prim a60:abs)
(ln prim a60:ln)
(exp prim a60:exp)
(prints prim prints)
(printn prim printn)
(printsln prim printsln)
(printnln prim printnln))))
(define (add-labels context l)
(cons (map (lambda (lbl) (cons (if (symbol? lbl)
(datum->syntax-object #f lbl)
lbl)
'label)) l)
context))
(define (add-procedure context var result-type arg-vars by-value-vars arg-specs)
(cons (list (cons var 'procedure))
context))
(define (add-settable-procedure context var result-type result-var)
(cons (list (cons var `(settable-procedure ,result-var ,result-type)))
context))
(define (add-atoms context ids type)
(cons (map (lambda (id) (cons id type)) ids)
context))
(define (add-arrays context names dimensionses type)
(cons (map (lambda (name dimensions)
(cons name `(array ,type ,(length dimensions))))
names dimensionses)
context))
(define (add-switch context name)
(cons (list (cons name 'switch))
context))
(define (add-bindings context arg-vars by-value-vars arg-specs)
(cons (map (lambda (var)
(let ([spec (or (ormap (lambda (spec)
(and (ormap (lambda (x) (bound-identifier=? var x))
(cdr spec))
(car spec)))
arg-specs)
#'unknown)])
(cons var
(if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars)
spec
(list 'by-name spec)))))
arg-vars)
context))
;; var-binding : syntax context -> symbol
;; returns an identifier indicating where the var is
;; bound, or 'free if it isn't. The compiler inserts
;; top-level procedure definitions into the namespace; if
;; the variable is bound there, it is a procedure.
(define (var-binding var context)
(cond
[(null? context)
(let/ec k
(namespace-variable-value (syntax-e var)
#t
(lambda () (k 'free)))
'procedure)]
[else
(let ([m (var-in-rib var (car context))])
(or m (var-binding var (cdr context))))]))
(define (var-in-rib var rib)
(ormap (lambda (b)
(if (symbol? (car b))
;; primitives:
(and (eq? (syntax-e var) (car b))
(cdr b))
;; everything else:
(and (bound-identifier=? var (car b))
(cdr b))))
rib))
(define (primitive-variable? var context)
(let ([v (var-binding var context)])
(and (pair? v)
(eq? (car v) 'prim)
(cadr v))))
(define (call-by-name-variable? var context)
(let ([v (var-binding var context)])
(and (pair? v)
(eq? (car v) 'by-name)
(cadr v))))
(define (procedure-variable? var context)
(let ([v (var-binding var context)])
(eq? v 'procedure)))
(define (procedure-result-variable? var context)
(let ([v (var-binding var context)])
(and (pair? v)
(eq? (car v) 'settable-procedure)
(cdr v))))
(define (procedure-result-variable-name var context)
(let ([v (procedure-result-variable? var context)])
(car v)))
(define (procedure-result-spec var context)
(let ([v (procedure-result-variable? var context)])
(cadr v)))
(define (label-variable? var context)
(let ([v (var-binding var context)])
(eq? v 'label)))
(define (switch-variable? var context)
(let ([v (var-binding var context)])
(eq? v 'switch)))
(define (settable-variable? var context)
(let ([v (var-binding var context)])
(or (box? v)
(and (syntax? v)
(memq (syntax-e v) '(integer real boolean))
v))))
(define (own-variable? var context)
(let ([v (var-binding var context)])
(box? v)))
(define (array-element? var context)
(let ([v (var-binding var context)])
(and (pair? v)
(eq? (car v) 'array)
(or (cadr v)
#'unknown))))
(define (spec-coerce-target spec subscripts)
(cond
[(and (syntax? spec) (memq (syntax-e spec) '(string label switch real integer boolean unknown))) spec]
[(and (syntax? spec) (memq (syntax-e spec) '(unknown))) #f]
[(or (not spec) (not (pair? spec))) #f]
[(eq? (car spec) 'array) (if (null? subscripts) #'array (cadr spec))]
[(eq? (car spec) 'procedure) #'procedure]
[else #f]))
(define (stx-number? a) (and (syntax? a) (number? (syntax-e a)))))

35
pkgs/algol60/examples/euler.a60
View File

@ -1,35 +0,0 @@
#lang algol60
begin
procedure euler (fct,sum,eps,tim); value eps,tim; integer tim;
real procedure fct; real sum,eps;
comment euler computes the sum of fct(i) for i from zero up to
infinity by means of a suitably refined euler transformation. The
summation is stopped as soon as tim times in succession the absolute
value of the terms of the transformed series are found to be less than
eps. Hence, one should provide a function fct with one integer argument,
an upper bound eps, and an integer tim. The output is the sum sum. euler
is particularly efficient in the case of a slowly convergent or
divergent alternating series;
begin integer i,k,n,t; array m[0:15]; real mn,mp,ds;
i:=n:=t:=0; m[0]:=fct(0); sum:=m[0]/2;
nextterm: i:=i+1; mn:=fct(i);
for k:=0 step 1 until n do
begin mp:=(mn+m[k])/2; m[k]:=mn;
mn:=mp end;
if (abs(mn)<abs(m[n])) & (n<15) then
begin ds:=mn/2; n:=n+1; m[n]:=mn end
else ds:=mn;
sum:=sum+ds;
if abs(ds)<eps then t:=t+1 else t:=0;
if t<tim then goto nextterm
end;
procedure inv(v) ; inv := 1.0/((v+1)^2);
real result;
euler(inv, result, 0.00005, 10);
printnln(result);
end

16
pkgs/algol60/examples/jensen.a60
View File

@ -1,16 +0,0 @@
#lang algol60
begin
integer procedure SIGMA(x, i, n);
value n;
integer x, i, n;
begin
integer sum;
sum:=0;
for i:=1 step 1 until n do
sum:=sum+x;
SIGMA:=sum;
end;
integer q;
printnln(SIGMA(q*2-1, q, 7));
end

124
pkgs/algol60/examples/nqueen.a60
View File

@ -1,124 +0,0 @@
#lang algol60
begin
comment
-- From the NASE A60 distribution --
Find a solution for the `N queen problem.
(got the algorithm from a Modula program from
Martin Neitzel).
;
integer N, MAXN;
MAXN := 9; comment maximum size;
N := 2; comment current size;
tryNextN:
begin
integer array column [1 : N];
Boolean array empcol [1 : N];
Boolean array empup [-N+1 : N-1];
Boolean array empdo [2 : 2*N];
integer i;
procedure print;
comment
print the current solution in a chessboard alike
picture ;
begin
integer i, j;
procedure outframe;
begin
integer i;
for i := 1 step 1 until N do
prints (`+---');
printsln (`+')
end;
for j := 1 step 1 until N do begin
outframe;
prints (`|');
for i := 1 step 1 until N do begin
if N + 1 - j = column [i] then
prints (` Q |')
else
prints (` |')
end;
printsln (`')
end;
outframe;
end;
procedure set (x);
value x;
integer x;
begin
integer y;
for y := 1 step 1 until N do
begin
if empcol [ y ] & empup [ x-y ]
& empdo [ x+y ] then
begin
column [ y ] := x ;
empcol [ y ] := false ;
empup [ x-y ] := false ;
empdo [ x+y ] := false ;
if x = N then
goto gotone
else
set ( x + 1 ) ;
empdo [ x+y ] := true ;
empup [ x-y ] := true ;
empcol [ y ] := true ;
column [ y ] := 0
end
end
end;
comment
main program start
;
prints (`looking onto a ');
printn (N);
prints (` x ');
printn (N);
printsln (` chessboard...');
for i := 1 step 1 until N do
begin
column [ i ] := 0 ;
empcol [ i ] := true
end;
for i := -N+1 step 1 until N-1 do
empup [ i ] := true ;
for i := 2 step 1 until 2*N do
empdo [ i ] := true ;
set ( 1 ) ;
printsln (`NO SOLUTION.');
goto contN;
gotone:
printsln(`SOLVED');
print;
contN:
if N < MAXN then begin
N := N + 1;
goto tryNextN
end;
printsln (`done.')
end
end

69
pkgs/algol60/examples/primes.a60
View File

@ -1,69 +0,0 @@
#lang algol60
begin
comment
-- From the NASE A60 distribution --
calculation of the prime numbers between 2 and 200
;
integer NN;
NN := 200;
begin
comment first algorithm (check division in a loop) ;
Boolean procedure isprime (n);
value n;
integer n;
begin
Boolean procedure even (n);
value n; integer n;
even := entier (n / 2) * 2 = n;
integer i;
isprime := false;
if even (n) & n != 2 then
goto ret;
for i := 3 step 2 until n div 2 do
if entier (n / i) * i = n then
goto ret;
isprime := true;
ret:
end;
integer i;
printsln (`first:');
for i := 2 step 1 until NN do
if isprime (i) then
printnln (i);
printsln (`done.')
end;
begin
comment second algorithm (sieve) ;
Boolean array arr [2 : NN];
integer i, j;
printsln (`second:');
for i := 2 step 1 until NN do
arr [i] := true;
for i := 2 step 1 until NN div 2 do
for j := 2 * i step i until NN do
arr [j] := false;
for i := 2 step 1 until NN do
if arr [i] then
printnln (i);
printsln (`done.')
end
end

24
pkgs/algol60/info.rkt
View File

@ -1,24 +0,0 @@
#lang info
(define collection "algol60")
(define build-deps '("at-exp-lib"
"rackunit-lib"
"racket-doc"
"scribble-doc"
"scribble-lib"
"drracket-plugin-lib"))
(define tools '(("tool.rkt")))
(define tool-names '("Algol 60"))
(define scribblings '(("algol60.scrbl" () (experimental 40))))
(define deps '("base"
"compatibility-lib"
"drracket-plugin-lib"
"errortrace-lib"
"gui-lib"
"parser-tools-lib"
"string-constants-lib"))
(define pkg-desc "An implementation of the Algol60 language")
(define pkg-authors '(mflatt robby))

8
pkgs/algol60/lang/algol60.rkt
View File

@ -1,8 +0,0 @@
#lang racket/base
(require "../runtime.rkt"
"../prims.rkt")
(provide (all-from-out racket/base)
(all-from-out "../prims.rkt")
(all-from-out "../runtime.rkt"))

48
pkgs/algol60/lang/reader.rkt
View File

@ -1,48 +0,0 @@
#lang s-exp syntax/module-reader
algol60/lang/algol60
#:read algol60-read
#:read-syntax algol60-read-syntax
#:info algol60-get-info
#:whole-body-readers? #t
(require "../parse.rkt"
;; Parses to generate an AST. Identifiers in the AST
;; are represented as syntax objects with source location.
"../simplify.rkt"
;; Desugars the AST, transforming `for' to `if'+`goto',
;; and flattening `if' statements so they are always
;; of the for `if <exp> then goto <label> else goto <label>'
"../compile.rkt"
;; Compiles a simplified AST to Scheme.
mzlib/file
syntax/strip-context)
(define (algol60-read in)
(map syntax->datum (algol60-read-syntax #f in)))
(define (algol60-read-syntax src in)
(define parsed (parse-a60-port in src))
(define simplified (simplify parsed #'here))
(define compiled (compile-simplified simplified #'here))
(define stripped (strip-context compiled))
(list stripped))
;; Extension: cooperate with DrRacket and tell it to use the default,
;; textual lexer and color scheme when editing algol programs.
(define (algol60-get-info key default default-filter)
(case key
[(color-lexer)
(dynamic-require 'syntax-color/default-lexer
'default-lexer)]
[else
(default-filter key default)]))

413
pkgs/algol60/parse.rkt
View File

@ -1,413 +0,0 @@
#cs(module parse mzscheme
(require parser-tools/lex
(prefix : parser-tools/lex-sre)
"cfg-parser.rkt"
parser-tools/yacc
syntax/readerr
"prims.rkt")
(define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))]
[lex:digit (:/ #\0 #\9)]
[lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)]
[lex:comment (:: (:* lex:whitespace) "comment" (:* (:~ #\;)) #\;)])
(define-tokens non-terminals (<logical-value>
<type> <identifier>
<unsigned-integer> <unsigned-float> <string>
GOTO IF THEN ELSE FOR DO STEP UNTIL WHILE
OWN ARRAY STRING PROCEDURE SWITCH LABEL VALUE
BEGIN END
POWER PLUS MINUS TIMES SLASH DIVIDE
LESS LESS-OR-EQUAL EQUAL GREATER-OR-EQUAL GREATER NOT-EQUAL ASSIGN
NEGATE AND OR IMPLIES EQUIV
COMMA COLON SEMICOLON
OPEN CLOSE OPENSQ CLOSESQ
EOF
UNPARSEABLE))
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
(define-syntax (token stx)
(syntax-case stx ()
[(_ name val)
(identifier? (syntax name))
(let ([name (syntax name)])
(with-syntax ([token-name (datum->syntax-object
name
(string->symbol
(format "token-~a" (syntax-e name))))]
[source-name (datum->syntax-object name 'source-name)]
[start-pos (datum->syntax-object name 'start-pos)]
[end-pos (datum->syntax-object name 'end-pos)])
(syntax
(token-name
(datum->syntax-object #f val
(list
source-name
(position-line start-pos)
(position-col start-pos)
(position-offset start-pos)
(- (position-offset end-pos)
(position-offset start-pos)))
stx-for-original-property)))))]))
(define-syntax (ttoken stx)
(syntax-case stx ()
[(_ name)
(identifier? (syntax name))
(syntax (token name 'name))]))
(define (lex source-name)
(lexer
[(:+ lex:whitespace) (void)]
["true" (token <logical-value> #t)]
["false" (token <logical-value> #f)]
["real" (token <type> 'real)]
["integer" (token <type> 'integer)]
["Boolean" (token <type> 'boolean)]
["goto" (ttoken GOTO)]
["if" (ttoken IF)]
["then" (ttoken THEN)]
["else" (ttoken ELSE)]
["for" (ttoken FOR)]
["do" (ttoken DO)]
["step" (ttoken STEP)]
["until" (ttoken UNTIL)]
["while" (ttoken WHILE)]
["own" (ttoken OWN)]
["array" (ttoken ARRAY)]
["string" (ttoken STRING)]
["procedure" (ttoken PROCEDURE)]
["switch" (ttoken SWITCH)]
["label" (ttoken LABEL)]
["value" (ttoken VALUE)]
[(:: "begin" lex:comment) (ttoken BEGIN)]
["begin" (ttoken BEGIN)]
[(:: "end" lex:comment) (ttoken BEGIN)]
["end" (ttoken END)]
["^" (token POWER 'expt)]
["+" (token PLUS '+)]
["-" (token MINUS '-)]
["*" (token TIMES '*)]
["/" (token SLASH '/)]
["div" (token DIVIDE 'quotient)]
["<" (token LESS '<)]
["<=" (token LESS-OR-EQUAL '<=)]
["=" (token EQUAL '=)]
[">" (token GREATER '>)]
[">=" (token GREATER-OR-EQUAL '>=)]
["!=" (token NOT-EQUAL '!=)]
["!" (token NEGATE '!)]
["&" (token AND '&)]
["|" (token OR '\|)]
["=>" (token IMPLIES '==>)]
["==" (token EQUIV '==)]
[":=" (ttoken ASSIGN)]
["," (ttoken COMMA)]
[":" (ttoken COLON)]
[(:: ";" lex:comment) (ttoken SEMICOLON)]
[";" (ttoken SEMICOLON)]
["(" (ttoken OPEN)]
[")" (ttoken CLOSE)]
["[" (ttoken OPENSQ)]
["]" (ttoken CLOSESQ)]
[(:: lex:letter (:* (:or lex:letter lex:digit))) (token <identifier> (string->symbol lexeme))]
[(:+ lex:digit) (token <unsigned-integer> (string->number lexeme))]
[(:or (:: (:+ lex:digit) #\. (:* lex:digit))
(:: (:* lex:digit) #\. (:+ lex:digit))) (token <unsigned-float> (string->number lexeme))]
[(:: #\` (:* (:~ #\' #\`)) #\') (let ([s lexeme])
(token <string> (substring s 1 (sub1 (string-length s)))))]
[(eof) (ttoken EOF)]
[any-char (token UNPARSEABLE (string->symbol lexeme))]))
(define parse
(cfg-parser
(tokens non-terminals)
(start <program>)
(end EOF)
(error (lambda (_ name stx start end)
(raise-read-error (format "parse error near ~a" name)
(syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))
(suppress)
(grammar
;; ==================== Expressions ====================
(<expression> [(<arithmetic-expression>) $1]
[(<Boolean-expression>) $1]
[(<designational-expression>) $1])
;; -------------------- Numbers --------------------
(<arithmetic-expression> [(<simple-arithmetic-expression>) $1]
[(IF <Boolean-expression>
THEN <simple-arithmetic-expression>
ELSE <arithmetic-expression>)
(make-a60:if $2 $4 $6)])
(<simple-arithmetic-expression> [(<term>) $1]
[(<adding-operator> <term>) (make-a60:unary 'num 'num $1 $2)]
[(<simple-arithmetic-expression> <adding-operator> <term>)
(make-a60:binary 'num 'num $2 $1 $3)])
(<term> [(<factor>) $1]
[(<term> <multiplying-operator> <factor>) (make-a60:binary 'num 'num $2 $1 $3)])
(<factor> [(<primary>) $1]
[(<factor> POWER <primary>) (make-a60:binary 'num 'num $2 $1 $3)])
(<adding-operator> [(PLUS) $1]
[(MINUS) $1])
(<multiplying-operator> [(TIMES) $1]
[(SLASH) $1]
[(DIVIDE) $1])
(<primary> [(<unsigned-integer>) $1]
[(<unsigned-float>) $1]
[(<variable>) $1]
[(<function-designator>) $1]
[(OPEN <arithmetic-expression> CLOSE) $2])
;; -------------------- Booleans --------------------
(<relational-operator> [(LESS) $1]
[(LESS-OR-EQUAL) $1]
[(EQUAL) $1]
[(GREATER-OR-EQUAL) $1]
[(GREATER) $1]
[(NOT-EQUAL) $1])
(<relation> [(<simple-arithmetic-expression> <relational-operator> <simple-arithmetic-expression>)
(make-a60:binary 'bool 'num $2 $1 $3)])
(<Boolean-primary> [(<logical-value>) $1]
[(<variable>) $1]
[(<function-designator>) $1]
[(<relation>) $1]
[(OPEN <Boolean-expression> CLOSE) $2])
(<Boolean-secondary> [(<Boolean-primary>) $1]
[(NEGATE <Boolean-primary>) (make-a60:unary 'bool 'bool $1 $2)])
(<Boolean-factor> [(<Boolean-secondary>) $1]
[(<Boolean-factor> AND <Boolean-secondary>) (make-a60:binary 'bool 'bool $2 $1 $3)])
(<Boolean-term> [(<Boolean-factor>) $1]
[(<Boolean-term> OR <Boolean-factor>) (make-a60:binary 'bool 'bool $2 $1 $3)])
(<implication> [(<Boolean-term>) $1]
[(<implication> IMPLIES <Boolean-term>) (make-a60:binary 'bool 'bool $2 $1 $3)])
(<simple-Boolean> [(<implication>) $1]
[(<simple-Boolean> EQUIV <implication>) (make-a60:binary 'bool 'bool $2 $1 $3)])
(<Boolean-expression> [(<simple-Boolean>) $1]
[(IF <Boolean-expression>
THEN <simple-Boolean>
ELSE <Boolean-expression>)
(make-a60:if $2 $4 $6)])
;; -------------------- Designationals --------------------
(<label> [(<identifier>) $1]
[(<unsigned-integer>) $1])
(<switch-identifier> [(<identifier>) $1])
(<switch-designator> [(<switch-identifier> OPENSQ <arithmetic-expression> CLOSESQ)
(make-a60:subscript $1 $3)])
(<simple-designational-expression> [(<label>) $1]
[(<switch-designator>) $1]
[(OPEN <designational-expression> CLOSE) $2])
(<designational-expression> [(<simple-designational-expression>) $1]
[(IF <Boolean-expression>
THEN <simple-designational-expression>
ELSE <designational-expression>)
(make-a60:if $2 $4 $6)])
;; -------------------- Variables --------------------
(<subscript-list> [(<arithmetic-expression>) (list $1)]
[(<subscript-list> COMMA <arithmetic-expression>) (append $1 (list $3))])
(<subscripted-variable> [(<identifier> OPENSQ <subscript-list> CLOSESQ) (make-a60:variable $1 $3)])
(<variable> [(<identifier>) (make-a60:variable $1 null)]
[(<subscripted-variable>) $1])
;; -------------------- Function calls --------------------
(<function-designator> [(<identifier> <actual-parameter-part>) (make-a60:app $1 $2)])
;; ==================== Statements ====================
;; - - - - - - - - - - non-empty - - - - - - - - - -
(<unlabelled-basic-nonempty-statement> [(<assignment-statement>) $1]
[(<go-to-statement>) $1]
[(<procedure-statement>) $1])
(<basic-nonempty-statement> [(<unlabelled-basic-nonempty-statement>) $1]
[(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
(<unconditional-nonempty-statement> [(<basic-nonempty-statement>) $1]
[(<compound-statement>) $1]
[(<block>) $1])
(<nonempty-statement> [(<unconditional-nonempty-statement>) $1]
[(<conditional-statement>) $1]
[(<for-statement>) $1])
;; - - - - - - - - - - possibly empty - - - - - - - - - -
(<unlabelled-basic-statement> [(<unlabelled-basic-nonempty-statement>) $1]
[(<dummy-statement>) $1])
(<basic-statement> [(<unlabelled-basic-statement>) $1]
[(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
(<unconditional-statement> [(<basic-statement>) $1]
[(<unconditional-nonempty-statement>) $1])
(<statement> [(<unconditional-statement>) $1]
[(<nonempty-statement>) $1])
;; -------------------- block and compound --------------------
(<compound-tail> [(<statement> END) (list $1)]
[(<statement> SEMICOLON <compound-tail>) (cons $1 $3)])
(<block-head> [(BEGIN <declaration>) (list $2)]
[(<block-head> SEMICOLON <declaration>) (append $1 (list $3))])
(<unlabelled-block> [(<block-head> SEMICOLON <compound-tail>) (make-a60:block $1 $3)])
(<unlabelled-compound> [(BEGIN <compound-tail>) (make-a60:compound $2)])
(<compound-statement> [(<unlabelled-compound>) $1]
[(<label> COLON <compound-statement>) (make-a60:label $1 $3)])
(<block> [(<unlabelled-block>) $1]
[(<label> COLON <block>) (make-a60:label $1 $3)])
;; -------------------- assignment --------------------
(<left-part> [(<variable> ASSIGN) $1])
(<left-part-list> [(<left-part>) (list $1)]
[(<left-part-list> <left-part>) (append $1 (list $2))])
(<assignment-statement> [(<left-part-list> <arithmetic-expression>) (make-a60:assign $1 $2)]
[(<left-part-list> <Boolean-expression>) (make-a60:assign $1 $2)])
;; -------------------- goto --------------------
(<go-to-statement> [(GOTO <designational-expression>) (make-a60:goto $2)])
;; -------------------- dummy --------------------
(<dummy-statement> [() (make-a60:compound null)])
;; -------------------- conditional --------------------
(<conditional-statement> [(IF <Boolean-expression> THEN <unconditional-statement>)
(make-a60:branch $2 $4 (make-a60:compound null))]
[(IF <Boolean-expression> THEN <unconditional-statement> ELSE <statement>)
(make-a60:branch $2 $4 $6)]
[(IF <Boolean-expression> THEN <for-statement>)
(make-a60:branch $2 $4 (make-a60:compound null))]
[(<label> COLON <conditional-statement>) (make-a60:label $1 $3)])
;; -------------------- for --------------------
(<for-list-element> [(<arithmetic-expression>) (make-a60:for-number $1)]
[(<arithmetic-expression> STEP <arithmetic-expression> UNTIL <arithmetic-expression>)
(make-a60:for-step $1 $3 $5)]
[(<arithmetic-expression> WHILE <Boolean-expression>) (make-a60:for-while $1 $3)])
(<for-list> [(<for-list-element>) (list $1)]
[(<for-list> COMMA <for-list-element>) (append $1 (list $3))])
(<for-statement> [(FOR <variable> ASSIGN <for-list> DO <statement>)
(make-a60:for $2 $4 $6)]
[(<label> COLON <for-statement>) (make-a60:label $1 $3)])
;; -------------------- procedure statement --------------------
(<actual-parameter> [(<string>) $1]
[(<expression>) $1]
; [(<identifier>) $1] ; switch, array, or procedure
)
(<parameter-delimiter> [(COMMA) (void)]
[(CLOSE <identifier> COLON OPEN) (void)]) ;; <identifier> was <letter-string>!
(<actual-parameter-list> [(<actual-parameter>) (list $1)]
[(<actual-parameter-list> <parameter-delimiter> <actual-parameter>)
(append $1 (list $3))])
(<actual-parameter-part> [() null]
[(OPEN <actual-parameter-list> CLOSE) $2])
(<procedure-statement> [(<identifier> <actual-parameter-part>) (make-a60:call $1 $2)])
;; ==================== Declarations ====================
(<declaration> [(<type-declaration>) $1]
[(<array-declaration>) $1]
[(<switch-declaration>) $1]
[(<procedure-declaration>) $1])
;; -------------------- Simple --------------------
(<type-list> [(<identifier>) (list $1)]
[(<identifier> COMMA <type-list>) (cons $1 $3)])
(<local-or-own-type> [(<type>) $1]
[(OWN <type>) (box $2)]) ; box => own
(<type-declaration> [(<local-or-own-type> <type-list>) (make-a60:type-decl $1 $2)])
;; -------------------- Arrays --------------------
(<bound-pair> [(<arithmetic-expression> COLON <arithmetic-expression>) (cons $1 $3)])
(<bound-pair-list> [(<bound-pair>) (list $1)]
[(<bound-pair-list> COMMA <bound-pair>) (append $1 (list $3))])
(<array-segment> [(<identifier> OPENSQ <bound-pair-list> CLOSESQ) (list (cons $1 $3))]
[(<identifier> COMMA <array-segment>) (cons (cons $1 (cdar $3)) $3)])
(<array-list> [(<array-segment>) $1]
[(<array-list> COMMA <array-segment>) (append $1 $3)])
(<array-declaration> [(ARRAY <array-list>) (make-a60:array-decl #'unknown $2)]
[(<local-or-own-type> ARRAY <array-list>) (make-a60:array-decl $1 $3)])
;; -------------------- Switches --------------------
(<switch-list> [(<designational-expression>) (list $1)]
[(<switch-list> COMMA <designational-expression>) (append $1 (list $3))])
(<switch-declaration> [(SWITCH <switch-identifier> ASSIGN <switch-list>) (make-a60:switch-decl $2 $4)])
;; -------------------- Procedures --------------------
(<formal-parameter> [(<identifier>) $1])
(<formal-parameter-list> [(<formal-parameter>) (list $1)]
[(<formal-parameter-list> <parameter-delimiter> <formal-parameter>)
(append $1 (list $3))])
(<formal-parameter-part> [() null]
[(OPEN <formal-parameter-list> CLOSE) $2])
(<identifier-list> [(<identifier>) (list $1)]
[(<identifier-list> COMMA <identifier>) (append $1 (list $3))])
(<value-part> [(VALUE <identifier-list> SEMICOLON) $2]
[() null])
(<specifier> [(STRING) 'string]
[(<type>) $1]
[(ARRAY) '(array #'unknown)]
[(<type> ARRAY) `(array ,$1)]
[(LABEL) 'label]
[(SWITCH) 'switch]
[(PROCEDURE) '(procedure #'unknown)]
[(<type> PROCEDURE) `(procedure ,$1)])
(<nonempty-specification-part> [(<specifier> <identifier-list> SEMICOLON) (list (cons $1 $2))]
[(<nonempty-specification-part> <specifier> <identifier-list> SEMICOLON)
(append $1 (list (cons $2 $3)))])
(<specification-part> [() null]
[(<nonempty-specification-part>) $1])
(<procedure-heading> [(<identifier> <formal-parameter-part> SEMICOLON <value-part> <specification-part>)
(list $1 $2 $4 $5)])
(<procedure-body> [(<nonempty-statement>) $1])
(<procedure-declaration> [(PROCEDURE <procedure-heading> <procedure-body>)
(make-a60:proc-decl #'unknown (car $2) (cadr $2) (caddr $2) (cadddr $2) $3)]
[(<type> PROCEDURE <procedure-heading> <procedure-body>)
(make-a60:proc-decl $1 (car $3) (cadr $3) (caddr $3) (cadddr $3) $4)])
;; ==================== Program ====================
(<program> [(<block>) $1]
[(<compound-statement>) $1]))))
(define-syntax (define-a60-structs stx)
(syntax-case stx ()
[(_ (struct-name (field ...)) ...)
(with-syntax ([(a60:struct ...) (map (lambda (id)
(datum->syntax-object
id
(string->symbol
(format "a60:~a" (syntax-e id)))))
(syntax->list (syntax (struct-name ...))))])
(syntax (begin (define-struct a60:struct (field ...)) ...
(provide (struct a60:struct (field ...)) ...))))]))
(define-a60-structs
;; Expressions
(if (test then else))
(unary (type argtype op arg))
(binary (type argtype op arg1 arg2))
(subscript (array index))
(variable (name indices))
(app (func args))
;; plus numbers, strings, and booleans
;; Statements
(block (decls statements))
(compound (statements))
(assign (variables rhs))
(goto (target))
(branch (test then else))
(call (proc args))
(for (variable values body))
(dummy ())
(label (name statement))
;; for values
(for-number (value))
(for-step (start step end))
(for-while (value test))
;; declarations
(type-decl (type vars))
(array-decl (type vars))
(switch-decl (var cases))
(proc-decl (result-type var arg-vars by-value-vars arg-specs body)))
(define (parse-a60-port port file)
(let ([lexer (lex file)])
(port-count-lines! port)
(parse
(lambda ()
(let loop ()
(let ([v (lexer port)])
(if (void? v)
(loop)
v)))))))
(define (parse-a60-file file)
(with-input-from-file file
(lambda ()
(parse-a60-port (current-input-port)
(path->complete-path file)))))
(provide parse-a60-file parse-a60-port))

106
pkgs/algol60/prims.rkt
View File

@ -1,106 +0,0 @@
(module prims mzscheme
(provide != ! & \|
==> ==
sign entier
a60:sin
a60:cos
a60:arctan
a60:sqrt
a60:abs
a60:ln
a60:exp
prints printn
printsln printnln)
(define (!= a b)
(not (= a b)))
(define (! a)
(unless (boolean? a)
(raise-type-error '! "boolean" a))
(not a))
(define (& a b)
(unless (boolean? a)
(raise-type-error '& "boolean" 0 a b))
(unless (boolean? b)
(raise-type-error '& "boolean" 1 a b))
(and a b))
(define (\| a b)
(unless (boolean? a)
(raise-type-error '\| "boolean" 0 a b))
(unless (boolean? b)
(raise-type-error '\| "boolean" 1 a b))
(or a b))
(define (==> a b)
(unless (boolean? a)
(raise-type-error '=> "boolean" 0 a b))
(unless (boolean? b)
(raise-type-error '=> "boolean" 1 a b))
(or (not a) b))
(define (== a b)
(unless (boolean? a)
(raise-type-error '== "boolean" 0 a b))
(unless (boolean? b)
(raise-type-error '== "boolean" 1 a b))
(eq? a b))
(define (get-number who v)
(let ([v (v)])
(unless (number? v)
(raise-type-error who "number" v))
v))
(define (get-string who v)
(let ([v (v)])
(unless (string? v)
(raise-type-error who "string" v))
v))
(define (sign k v)
(k (let ([v (get-number 'sign v)])
(cond
[(< v 0) -1]
[(> v 0) 1]
[else 0]))))
(define (entier k v)
(k (inexact->exact (floor (get-number 'entier v)))))
(define (a60:abs k v)
(k (abs (get-number 'abs v))))
(define (a60:sqrt k v)
(k (sqrt (get-number 'sqrt v))))
(define (a60:sin k v)
(k (sin (get-number 'sin v))))
(define (a60:cos k v)
(k (cos (get-number 'cos v))))
(define (a60:exp k v)
(k (exp (get-number 'exp v))))
(define (a60:arctan k v)
(k (atan (get-number 'arctan v))))
(define (a60:ln k v)
(k (log (get-number 'ln v))))
(define (printsln k v)
(k (printf "~a\n" (get-string 'printsln v))))
(define (printnln k v)
(k (printf "~a\n" (get-number 'printnln v))))
(define (prints k v)
(k (printf "~a" (get-string 'prints v))))
(define (printn k v)
(k (printf "~a" (get-number 'printn v)))))

108
pkgs/algol60/runtime.rkt
View File

@ -1,108 +0,0 @@
(module runtime mzscheme
(require racket/undefined)
(provide (struct a60:array (vec dimens))
(struct a60:switch (choices))
undefined
check-boolean
goto
get-value
set-target!
make-array
array-ref
array-set!
make-switch
switch-ref
coerce)
(define-struct a60:array (vec dimens))
(define-struct a60:switch (choices))
(define (check-boolean b) b)
(define (goto f) (f))
(define (get-value v) (v))
(define (set-target! t name v)
(unless (procedure-arity-includes? t 1)
(error 'assignment "formal-argument variable ~a is assigned, but actual argument was not assignable"
name))
(t v))
(define (bad what v)
(error '|bad value| "expected a ~a, got ~e" what v))
(define (coerce type v)
(cond
[(eq? type 'integer)
(if (number? v)
(inexact->exact (floor v))
(bad 'number v))]
[(eq? type 'real)
(if (number? v)
(exact->inexact v)
(bad 'number v))]
[(eq? type 'boolean)
(if (boolean? v)
v
(bad 'boolean v))]
[else v]))
(define (make-array . dimens)
(make-a60:array
((let loop ([dimens dimens])
(if (null? dimens)
(lambda () undefined)
(let ([start (car dimens)]
[end (cadr dimens)])
(let ([build (loop (cddr dimens))])
(lambda ()
(let ([len (add1 (- end start))])
(let ([v (make-vector len)])
(let loop ([len len])
(unless (zero? len)
(vector-set! v (sub1 len) (build))
(loop (sub1 len))))
v))))))))
dimens))
(define (check-array a is who)
(unless (a60:array? a)
(error who "not an array: ~e" a))
(unless (= (length is) (/ (length (a60:array-dimens a)) 2))
(error who "array dimension ~a doesn't match the number of provided indices ~a"
(length is) (/ (length (a60:array-dimens a)) 2))))
(define (check-index who dimens indices)
(unless (and (number? (car indices))
(exact? (car indices))
(integer? (car indices)))
(error who "index is not an integer: ~e"
(car indices)))
(unless (<= (car dimens) (car indices) (cadr dimens))
(error who "index ~a out of range ~a:~a"
(car indices) (car dimens) (cadr dimens))))
(define (array-ref a . indices)
(check-array a indices 'array-reference)
(let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
(check-index 'array-reference dimens indices)
(let ([i (vector-ref v (- (car indices) (car dimens)))])
(if (null? (cdr indices))
i
(loop i (cdr indices) (cddr dimens))))))
(define (array-set! a val . indices)
(check-array a indices 'array-assignment)
(let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
(check-index 'array-assignment dimens indices)
(if (null? (cdr indices))
(vector-set! v (- (car indices) (car dimens)) val)
(loop (vector-ref v (- (car indices) (car dimens))) (cdr indices) (cddr dimens)))))
(define (make-switch . choices)
(make-a60:switch (list->vector choices)))
(define (switch-ref sw index)
(unless (and (number? index)
(integer? index)
(exact? index)
(<= 1 index (vector-length (a60:switch-choices sw))))
(error "bad switch index: " index))
((vector-ref (a60:switch-choices sw) (sub1 index)))))

169
pkgs/algol60/simplify.rkt
View File

@ -1,169 +0,0 @@
#cs(module simplify mzscheme
(require "parse.rkt"
"prims.rkt"
mzlib/match)
(provide simplify)
;; flatten/label-block : list-of-decl list-of-stmt -> block-stmt
;; Desugars `for', converts `if' so that it's always of the form
;; `if <test> then goto <label> else goto <label>', flattens
;; compound statements into the enclosing block, and gives every
;; statement exactly one label. The result usually has lots of
;; "dummy" statements that could easily be eliminated by merging
;; labels.
(define (flatten/label-block decls statements ->stx)
(define extra-decls null)
(define new-statements
(let loop ([l statements])
(if (null? l)
null
(match (car l)
[($ a60:block decls statements)
(cons (cons (gensym 'block) (flatten/label-block decls statements ->stx))
(loop (cdr l)))]
[($ a60:compound statements)
(loop (append statements (cdr l)))]
[($ a60:branch test then else)
(if (and (a60:goto? then) (a60:goto? else))
(cons (cons (gensym 'branch) (car l))
(loop (cdr l)))
(let ([then-label (gensym 'then)]
[else-label (gensym 'else)]
[cont-label (gensym 'if-cont)])
(loop
(list*
(make-a60:branch test (make-a60:goto then-label) (make-a60:goto else-label))
(make-a60:label then-label then)
(make-a60:goto cont-label)
(make-a60:label else-label else)
(make-a60:label cont-label (make-a60:dummy))
(cdr l)))))]
[($ a60:for variable val-exprs body)
(let ([body-label (gensym 'for-body)]
[cont-label (gensym 'for-cont)])
(letrec ([make-init+test+increment+loop
(lambda (value)
(match value
[($ a60:for-number value)
(values (make-a60:assign (list variable) (make-a60:binary 'num 'num
(->stx '+)
(->stx '0)
value)) ; +0 => number
(->stx #t)
(make-a60:dummy)
#f)]
[($ a60:for-step start step end)
(values (make-a60:assign (list variable) start)
(make-a60:binary 'bool 'num
(->stx '<=)
(make-a60:binary 'num 'num
(->stx '*)
(make-a60:binary 'num 'num (->stx '-) variable end)
(make-a60:app (->stx 'sign) (list step)))
(->stx '0))
(make-a60:assign (list variable) (make-a60:binary 'num 'num (->stx '+) variable step))
#t)]
[($ a60:for-while value test)
(values (make-a60:assign (list variable) value)
test
(make-a60:assign (list variable) value)
#t)]))])
(if (= 1 (length val-exprs))
(let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
(loop (list*
init
(make-a60:label body-label (make-a60:dummy))
(make-a60:branch test
(make-a60:compound
(list
body
inc
(if loop?
(make-a60:goto body-label)
(make-a60:dummy))))
(make-a60:dummy))
(cdr l))))
(let* ([stage-name (datum->syntax-object #f (gensym 'stage-number))]
[switch-name (datum->syntax-object #f (gensym 'stage-switch))]
[end-switch-name (datum->syntax-object #f (gensym 'stage-switch))]
[stage-var (make-a60:variable stage-name null)]
[start-labels (map (lambda (x) (gensym 'stage)) (append val-exprs (list 'extra)))]
[end-labels (map (lambda (x) (gensym 'stage)) val-exprs)])
(set! extra-decls (list* stage-name
(cons switch-name start-labels)
(cons end-switch-name end-labels)
extra-decls))
(loop
(append
(list (make-a60:assign (list stage-var) (->stx '0)))
(let loop ([start-labels start-labels][end-labels end-labels][val-exprs val-exprs])
(if (null? val-exprs)
(list (make-a60:label (car start-labels) (make-a60:dummy)))
(let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
(list*
(make-a60:label (car start-labels) (make-a60:dummy))
init
(make-a60:branch test
(make-a60:goto body-label)
(make-a60:compound
(list
(make-a60:assign (list stage-var) (make-a60:binary 'num 'num
(->stx '+)
(->stx '1)
stage-var))
(make-a60:goto (make-a60:subscript switch-name stage-var)))))
(make-a60:label (car end-labels) (make-a60:dummy))
inc
(if loop?
(make-a60:goto (car start-labels))
(make-a60:goto (cadr start-labels)))
(loop (cdr start-labels)
(cdr end-labels)
(cdr val-exprs))))))
(list
(make-a60:goto cont-label)
(make-a60:label body-label (make-a60:dummy))
body
(make-a60:goto (make-a60:subscript end-switch-name stage-var))
(make-a60:label cont-label (make-a60:dummy)))
(cdr l)))))))]
[($ a60:label name statement)
(cons (cons name (make-a60:dummy))
(loop (cons statement (cdr l))))]
[else
(cons (cons (gensym 'other) (car l))
(loop (cdr l)))]))))
(make-a60:block
(append
(map (lambda (decl)
(match decl
[($ a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
(make-a60:proc-decl result-type var arg-vars by-value-vars arg-specs
(simplify-statement body ->stx))]
[else decl]))
decls)
(map (lambda (extra)
(if (identifier? extra)
(make-a60:type-decl (->stx 'integer) (list extra))
(make-a60:switch-decl
(car extra)
(map (lambda (x)
(make-a60:variable (datum->syntax-object #f x)
null))
(cdr extra)))))
extra-decls))
(if (null? new-statements)
(list (cons (gensym 'other) (make-a60:dummy)))
new-statements)))
(define (simplify stmt ctx)
(simplify-statement stmt (lambda (x) (datum->syntax-object ctx x))))
(define (simplify-statement stmt ->stx)
(match stmt
[($ a60:block decls statements)
(flatten/label-block decls statements ->stx)]
[($ a60:compound statements)
(flatten/label-block null statements ->stx)]
[else stmt])))

61
pkgs/algol60/tests/test.rkt
View File

@ -1,61 +0,0 @@
#lang at-exp racket/base
(require algol60/algol60
rackunit
(for-syntax racket/base))
(define-syntax (capture-output stx)
(syntax-case stx ()
[(_ exp)
(with-handlers ((exn:fail?
(λ (exn)
#`(list 'expand
#,(exn-message exn)))))
(define expanded (local-expand #'exp 'expression #f))
#`(let ([op (open-output-string)]
[ep (open-output-string)])
(let/ec k
(parameterize ([current-output-port op]
[current-error-port ep]
[error-escape-handler (λ () (k (void)))])
#,expanded))
(list 'run
(get-output-string op)
(get-output-string ep))))]))
(check-equal?
(capture-output
@literal-algol{
begin
printsln (`hello world')
end
})
'(run "hello world\n" ""))
(check-pred
(λ (x) (and (eq? (list-ref x 0) 'expand)
(regexp-match #rx"parse error near BEGIN"
(list-ref x 1))))
(capture-output
@literal-algol{
begin
}))
(check-pred
(λ (x) (and (eq? (list-ref x 0) 'expand)
(regexp-match #rx"parse error near PROCEDURE"
(list-ref x 1))))
(capture-output
@literal-algol{
procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k);
value n, m; array a; integer n, m, i, k; real y;
begin integer p, q;
y := 0; i := k := 1;
for p:=1 step 1 until n do
for q:=1 step 1 until m do
if abs(a[p, q]) > y then
begin y := abs(a[p, q]);
i := p; k := q
end
end Absmax
}))

123
pkgs/algol60/tool.rkt
View File

@ -1,123 +0,0 @@
(module tool mzscheme
(require drscheme/tool
mred
mzlib/unit
mzlib/class
"parse.rkt"
"simplify.rkt"
"compile.rkt"
compiler/embed
string-constants
errortrace/errortrace-lib
(prefix bd: "bd-tool.rkt"))
(provide tool@)
(define base-importing-stx (dynamic-require 'algol60/base
'base-importing-stx))
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define-values/invoke-unit bd:tool@
(import drscheme:tool^)
(export (prefix bd: drscheme:tool-exports^)))
(define (phase1) (bd:phase1))
(define (phase2)
(bd:phase2)
(drscheme:language-configuration:add-language
(make-object (override-mrflow-methods
((drscheme:language:get-default-mixin)
lang%)))))
(define (override-mrflow-methods %)
(if (method-in-interface? 'render-value-set (class->interface %))
(class %
(inherit [super-render-value-set render-value-set]
[super-get-mrflow-primitives-filename get-mrflow-primitives-filename])
(define/override (render-value-set . x)
;; needs to be filled in!
(super-render-value-set . x))
(define/override (get-mrflow-primitives-filename)
(build-path (collection-path "mrflow")
"primitives"
"algol60.rkt"))
(super-instantiate ()))
%))
(define lang%
(class* object% (drscheme:language:language<%>)
(define/public (front-end/finished-complete-program settings) (void))
(define/public (extra-repl-information settings port) (void))
(define/public (get-reader-module) #f)
(define/public (get-metadata a b) #f)
(define/public (metadata->settings m) #f)
(define/public (get-metadata-lines) #f)
(define/public (capability-value s) (drscheme:language:get-capability-default s))
(define/public (first-opened) (void))
(define/public (config-panel parent)
(case-lambda
[() null]
[(x) (void)]))
(define/public (get-comment-character) (values "'COMMENT'" #\*))
(define/public (default-settings) null)
(define/public (default-settings? x) #t)
(define/private (front-end port settings)
(let ([name (object-name port)])
(lambda ()
(if (eof-object? (peek-char port))
eof
(compile-simplified
(simplify (parse-a60-port port name) base-importing-stx)
base-importing-stx)))))
(define/public (front-end/complete-program port settings) (front-end port settings))
(define/public (front-end/interaction port settings) (front-end port settings))
(define/public (get-style-delta) #f)
(define/public (get-language-position)
(list (string-constant experimental-languages)
"Algol 60"))
(define/public (get-language-name) "Algol 60")
(define/public (get-language-url) #f)
(define/public (get-language-numbers) (list 1000 10))
(define/public (get-teachpack-names) null)
(define/public (marshall-settings x) x)
(define/public (on-execute settings run-in-user-thread)
(dynamic-require 'algol60/base #f)
(let ([path ((current-module-name-resolver) 'algol60/base #f #f #t)]
[n (current-namespace)])
(run-in-user-thread
(lambda ()
(error-display-handler
(drscheme:debug:make-debug-error-display-handler (error-display-handler)))
(current-compile (make-errortrace-compile-handler))
(with-handlers ([void (lambda (x)
(printf "~a\n"
(exn-message x)))])
(namespace-attach-module n path)
(namespace-require path))))))
(define/public (render-value value settings port) (write value port))
(define/public (render-value/format value settings port width) (write value port))
(define/public (unmarshall-settings x) x)
(define/public (create-executable settings parent src-file)
(let ([dst-file (drscheme:language:put-executable
parent src-file #f #f
(string-constant save-a-mzscheme-stand-alone-executable))])
(when dst-file
(let ([code (compile-simplified (simplify (parse-a60-file src-file)
base-importing-stx)
base-importing-stx)])
(make-embedding-executable dst-file
#f #f
'((#f algol60/base))
null
(compile
`(module m algol60/base
,code))
(list "-mvqe" "(require m)"))))))
(define/public (get-one-line-summary) "Of historic interest")
(super-instantiate ()))))))

306
pkgs/cext-lib/compiler/commands/ctool.rkt
View File

@ -1,306 +0,0 @@
#lang scheme/base
(module test racket/base)
;; On error, exit with 1 status code
(error-escape-handler (lambda () (exit 1)))
(error-print-width 512)
(require (prefix-in compiler:option: compiler/option)
compiler/compiler
raco/command-name
racket/cmdline
dynext/file
dynext/compile
dynext/link
scheme/pretty
setup/pack
setup/getinfo
setup/dirs)
(define dest-dir (make-parameter #f))
(define ld-output (make-parameter #f))
(define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-U" "--")))
(define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-embedded-collects-dest (make-parameter #f))
(define exe-dir-add-collects-dirs (make-parameter null))
(define exe-dir-output (make-parameter #f))
(define mods-output (make-parameter #f))
(define default-plt-name "archive")
(define disable-inlining (make-parameter #f))
(define plt-output (make-parameter #f))
(define plt-name (make-parameter default-plt-name))
(define plt-files-replace (make-parameter #f))
(define plt-files-plt-relative? (make-parameter #f))
(define plt-files-plt-home-relative? (make-parameter #f))
(define plt-force-install-dir? (make-parameter #f))
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define stop-at-source (make-parameter #f))
(define (extract-suffix appender)
(bytes->string/latin-1
(subbytes (path->bytes (appender (bytes->path #"x"))) 1)))
(define ((add-to-param param) f v) (param (append (param) (list v))))
(define mzc-symbol (string->symbol (short-program+command-name)))
;; Returns (values mode files prefixes)
;; where mode is 'compile, 'make-zo, etc.
(define-values (mode source-files prefix)
(parse-command-line
(short-program+command-name)
(current-command-line-arguments)
`([help-labels
"-------------------------------- mode flags ---------------------------------"]
[once-any
[("--cc")
,(lambda (f) 'cc)
(,(format "Compile arbitrary file(s) for an extension: ~a -> ~a"
(extract-suffix append-c-suffix)
(extract-suffix append-object-suffix)))]
[("--ld")
,(lambda (f name) (ld-output name) 'ld)
(,(format "Link arbitrary file(s) to create <extension>: ~a -> ~a"
(extract-suffix append-object-suffix)
(extract-suffix append-extension-suffix))
"extension")]
[("-x" "--xform")
,(lambda (f) 'xform)
((,(format "Convert for 3m compilation: ~a -> ~a"
(extract-suffix append-c-suffix)
(extract-suffix append-c-suffix))
""))]
[("--c-mods")
,(lambda (f name) (mods-output name) 'c-mods)
((,(format "Write C-embeddable module bytecode to <file>") "")
"file")]]
[help-labels ""]
[once-any
[("--3m")
,(lambda (f) (compiler:option:3m #t))
(,(format "Compile/link for 3m~a"
(if (eq? '3m (system-type 'gc)) " [current default]" "")))]
[("--cgc")
,(lambda (f) (compiler:option:3m #f))
(,(format "Compile/link for CGC~a"
(if (eq? 'cgc (system-type 'gc)) " [current default]" "")))]]
[once-each
[("-n" "--name")
,(lambda (f name) (compiler:option:setup-prefix name))
("Use <name> as extra part of public low-level names" "name")]]
[once-any
[("-d" "--destination")
,(lambda (f d)
(unless (directory-exists? d)
(error mzc-symbol "the destination directory does not exist: ~s" d))
(dest-dir d))
("Output --cc/--ld/-x file(s) to <dir>" "dir")]]
[help-labels
"------------------- compiler/linker configuration flags ---------------------"]
[once-each
[("--tool")
,(lambda (f v)
(let ([v (string->symbol v)])
(use-standard-compiler v)
(use-standard-linker v)))
(,(format "Use pre-defined <tool> as C compiler/linker:~a"
(apply string-append
(apply append (map (lambda (t)
(list " " (symbol->string t)))
(get-standard-compilers)))))
"tool")]
[("--compiler")
,(lambda (f v) (current-extension-compiler v))
("Use <compiler-path> as C compiler" "compiler-path")]]
[multi
[("++ccf")
,(add-to-param current-extension-compiler-flags)
("Add C compiler flag" "flag")]
[("--ccf")
,(lambda (f v)
(current-extension-compiler-flags
(remove v (current-extension-compiler-flags))))
("Remove C compiler flag" "flag")]
[("--ccf-clear")
,(lambda (f) (current-extension-compiler-flags null))
("Clear C compiler flags")]
[("--ccf-show")
,(lambda (f)
(printf "C compiler flags: ~s\n"
(expand-for-link-variant (current-extension-compiler-flags))))
("Show C compiler flags")]]
[once-each
[("--linker")
,(lambda (f v) (current-extension-linker v))
("Use <linker-path> as C linker" "linker-path")]]
[multi
[("++ldf")
,(add-to-param current-extension-linker-flags)
("Add C linker flag" "flag")]
[("--ldf")
,(lambda (f v)
(current-extension-linker-flags
(remove v (current-extension-linker-flags))))
("Remove C linker flag" "flag")]
[("--ldf-clear")
,(lambda (f) (current-extension-linker-flags null))
("Clear C linker flags")]
[("--ldf-show")
,(lambda (f)
(printf "C linker flags: ~s\n"
(expand-for-link-variant (current-extension-linker-flags))))
("Show C linker flags")]
[("++ldl")
,(add-to-param current-standard-link-libraries)
("Add C linker library" "lib")]
[("--ldl-show")
,(lambda (f)
(printf "C linker libraries: ~s\n"
(expand-for-link-variant (current-standard-link-libraries))))
("Show C linker libraries")]]
[multi
[("++cppf")
,(add-to-param current-extension-preprocess-flags)
("Add C preprocess (xform) flag" "flag")]
[("--cppf")
,(lambda (f v)
(current-extension-preprocess-flags
(remove v (current-extension-preprocess-flags))))
("Remove C preprocess (xform) flag" "flag")]
[("--cppf-clear")
,(lambda (f) (current-extension-preprocess-flags null))
("Clear C preprocess (xform) flags")]
[("--cppf-show")
,(lambda (f)
(printf "C compiler flags: ~s\n"
(expand-for-link-variant (current-extension-preprocess-flags))))
("Show C preprocess (xform) flags")]]
[help-labels
"----------------------- C-embeddable module flags ---------------------------"]
[multi
[("++lib")
,(lambda (f l)
(exe-embedded-libraries (append (exe-embedded-libraries) (list l))))
("Embed <lib> in --c-mods output" "lib")]]
[help-labels
"-------------------------- miscellaneous flags ------------------------------"]
[once-each
[("-v")
,(lambda (f) (compiler:option:somewhat-verbose #t))
("Slightly verbose mode, including version banner and output files")]
[("--vv")
,(lambda (f) (compiler:option:somewhat-verbose #t) (compiler:option:verbose #t))
("Very verbose mode")]])
(lambda (accum . files)
(let ([mode (let ([l (filter symbol? accum)])
(if (null? l)
(error mzc-symbol "no mode flag specified")
(car l)))])
(values
mode
files
#f)))
(list "file")))
(when (compiler:option:somewhat-verbose)
(printf "~a v~a [~a], Copyright (c) 2004-2014 PLT Design Inc.\n"
(short-program+command-name)
(version)
(system-type 'gc)))
(if (compiler:option:3m)
(begin (link-variant '3m) (compile-variant '3m))
(begin (link-variant 'cgc) (compile-variant 'cgc)))
(define (compiler-warning)
(eprintf "Warning: ~a\n ~a\n"
"compilation to C is usually less effective for performance"
"than relying on the bytecode just-in-time compiler."))
(case mode
[(cc)
(for ([file source-files])
(let* ([base (extract-base-filename/c file mzc-symbol)]
[dest (append-object-suffix
(let-values ([(base name dir?) (split-path base)])
(build-path (or (dest-dir) 'same) name)))])
(when (compiler:option:somewhat-verbose)
(printf "\"~a\":\n" file))
(compile-extension (not (compiler:option:verbose)) file dest null)
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest))))]
[(ld)
(extract-base-filename/ext (ld-output) mzc-symbol)
;; (for ([file source-files]) (extract-base-filename/o file mzc-symbol))
(let ([dest (if (dest-dir)
(build-path (dest-dir) (ld-output))
(ld-output))])
(when (compiler:option:somewhat-verbose)
(printf "~a:\n" (let ([s (apply string-append
(map (lambda (n) (format " \"~a\"" n))
source-files))])
(substring s 1 (string-length s)))))
(link-extension (not (compiler:option:verbose))
source-files
dest)
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest)))]
[(xform)
(for ([file source-files])
(let* ([out-file (path-replace-suffix file ".3m.c")]
[out-file (if (dest-dir)
(build-path (dest-dir) out-file)
out-file)])
((dynamic-require 'compiler/xform 'xform)
(not (compiler:option:verbose))
file
out-file
(list (find-include-dir)))
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" out-file))))]
[(c-mods)
(let ([dest (mods-output)])
(let-values ([(in out) (make-pipe)])
(parameterize ([current-output-port out])
((dynamic-require 'compiler/embed 'write-module-bundle)
#:modules
(append (map (lambda (l) `(#f (file ,l))) source-files)
(map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries)))))
(close-output-port out)
(let ([out (open-output-file dest #:exists 'truncate/replace)])
(fprintf out "#ifdef MZ_XFORM\n")
(fprintf out "XFORM_START_SKIP;\n")
(fprintf out "#endif\n")
(fprintf out "static void declare_modules(Scheme_Env *env) {\n")
(fprintf out " static unsigned char data[] = {")
(let loop ([pos 0])
(let ([b (read-byte in)])
(when (zero? (modulo pos 20)) (fprintf out "\n "))
(unless (eof-object? b) (fprintf out "~a," b) (loop (add1 pos)))))
(fprintf out "0\n };\n")
(fprintf out " scheme_register_embedded_load(~a, (const char *)data);\n"
(file-position in))
(fprintf out " scheme_embedded_load(~a, (const char *)data, 1);\n"
(file-position in))
(fprintf out "}\n")
(fprintf out "#ifdef MZ_XFORM\n")
(fprintf out "XFORM_END_SKIP;\n")
(fprintf out "#endif\n")
(close-output-port out)))
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest)))]
[else (printf "bad mode: ~a\n" mode)])

4
pkgs/cext-lib/compiler/commands/info.rkt
View File

@ -1,4 +0,0 @@
#lang info
(define raco-commands
'(("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)))

28
pkgs/cext-lib/compiler/xform.rkt
View File

@ -1,28 +0,0 @@
#lang scheme/base
(require dynext/compile
setup/dirs
(prefix-in xform: compiler/private/xform))
(provide xform)
(define (xform quiet? src dest header-dirs #:keep-lines? [keep-lines? #f])
(let ([exe (current-extension-compiler)]
[flags (expand-for-compile-variant
(current-extension-preprocess-flags))]
[headers (apply append
(map (current-make-compile-include-strings)
(append
header-dirs
(list (find-include-dir)))))])
(xform:xform quiet?
(cons exe
(append flags headers))
src
dest
keep-lines?
#f #t #t
#f #f
#f #f
#f)))

19
pkgs/cext-lib/dynext/compile-sig.rkt
View File

@ -1,19 +0,0 @@
#lang racket/base
(require racket/unit)
(provide dynext:compile^)
(define-signature dynext:compile^
(compile-extension
preprocess-extension
current-extension-compiler
current-extension-compiler-flags
current-extension-preprocess-flags
current-make-compile-include-strings
current-make-compile-input-strings
current-make-compile-output-strings
use-standard-compiler
get-standard-compilers
compile-variant
expand-for-compile-variant))

300
pkgs/cext-lib/dynext/compile-unit.rkt
View File

@ -1,300 +0,0 @@
(module compile-unit racket/base
(require racket/unit
racket/system
"private/dirs.rkt"
"private/stdio.rkt"
"private/cmdargs.rkt")
(require "compile-sig.rkt")
(provide dynext:compile@)
(define-unit dynext:compile@
(import)
(export dynext:compile^)
(define (get-unix-compile)
(or (find-executable-path "gcc" #f)
(find-executable-path "cc" #f)))
(define (get-windows-compile)
(or (find-executable-path "cl.exe" #f)
(find-executable-path "gcc.exe" #f)
(find-executable-path "bcc32.exe" #f)))
(define current-extension-compiler
(make-parameter
(or (let ([p (or (getenv "MZSCHEME_DYNEXT_COMPILER")
(getenv "CC"))])
(and p
(if (absolute-path? p)
(string->path p)
(find-executable-path p #f))))
(case (system-type)
[(unix macosx) (get-unix-compile)]
[(windows) (get-windows-compile)]
[else #f]))
(lambda (v)
(when v
(if (path-string? v)
(unless (and (file-exists? v)
(memq 'execute (file-or-directory-permissions v)))
(error 'current-extension-compiler
"compiler not found or not executable: ~s" v))
(raise-type-error 'current-extension-compiler "path, valid-path string, or #f" v)))
v)))
(define win-gcc?
(let ([c (current-extension-compiler)])
(and c (regexp-match #"gcc.exe$" (path->bytes c)))))
(define win-borland?
(let ([c (current-extension-compiler)])
(and c (regexp-match #"bcc32.exe$" (path->bytes c)))))
(define unix-cc?
(let ([c (current-extension-compiler)])
(and c (regexp-match #"[^g]cc$" (path->bytes c)))))
(define (add-variant-flags l)
(append l (list (lambda ()
(if (eq? '3m (specific-compile-variant))
'("-DMZ_PRECISE_GC")
null)))))
(define gcc-cpp-flags
(add-variant-flags (case (string->symbol (path->string (system-library-subpath #f)))
[(parisc-hpux) '("-D_HPUX_SOURCE")]
[(ppc-macosx x86_64-macosx) '("-DOS_X")]
[(i386-macosx) '("-DOS_X" "-m32")]
[(ppc-darwin x86_64-darwin) '("-DOS_X" "-DXONX")]
[(i386-darwin) '("-DOS_X" "-DXONX" "-m32")]
[else null])))
(define gcc-compile-flags (append '("-c" "-O2" "-fPIC")
(case (string->symbol (path->string (system-library-subpath #f)))
[(i386-macosx i386-darwin) '("-m32" "-fno-common")]
[(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")]
[(win32\\i386) '("-DAS_MSVC_EXTENSION")]
[else null])
gcc-cpp-flags))
(define unix-cpp-flags
(add-variant-flags (case (string->symbol (path->string (system-library-subpath #f)))
[(parisc-hpux) '("-D_HPUX_SOURCE")]
[else gcc-cpp-flags])))
(define unix-compile-flags (case (string->symbol (path->string (system-library-subpath #f)))
[(parisc-hpux) (append '("-c" "-O2" "-Aa" "+z" "+e")
unix-cpp-flags)]
[else gcc-compile-flags]))
(define msvc-compile-flags
(add-variant-flags '("/c" "/MT" "/O2")))
(define (make-flags-guard who)
(lambda (l)
(unless (and (list? l) (andmap (lambda (s) (or (path-string? s)
(and (procedure? s) (procedure-arity-includes? s 0))))
l))
(raise-type-error who "list of paths/strings and thunks" l))
l))
(define (get-env-compile-flags)
(let ([v (or (getenv "MZSCHEME_DYNEXT_COMPILER_FLAGS")
(getenv "CFLAGS"))])
(if v
(split-command-line-args v)
null)))
(define current-extension-compiler-flags
(make-parameter
(append
(get-env-compile-flags)
(case (system-type)
[(unix macosx) (if unix-cc?
unix-compile-flags
gcc-compile-flags)]
[(windows) (if (or win-gcc? win-borland?)
gcc-compile-flags
msvc-compile-flags)]
[(macos) '()]))
(make-flags-guard 'current-extension-compiler-flags)))
(define current-extension-preprocess-flags
(make-parameter
(case (system-type)
[(unix macosx) (cons "-E" (if unix-cc?
unix-cpp-flags
gcc-cpp-flags))]
[(windows) (if (or win-gcc? win-borland?)
(cons "-E" gcc-cpp-flags)
'("/E"))]
[(macos) '()])
(make-flags-guard 'current-extension-preprocess-flags)))
(define compile-variant (make-parameter
'normal
(lambda (s)
(unless (memq s '(normal cgc 3m))
(raise-type-error 'compile-variant "'normal, 'cgc, or '3m" s))
s)))
(define (specific-compile-variant)
(let ([v (compile-variant)])
(if (eq? v 'normal)
(system-type 'gc)
v)))
(define (expand-for-compile-variant l)
(apply append (map (lambda (s) (if (path-string? s) (list s) (s))) l)))
(define current-make-extra-extension-compiler-flags
(make-parameter
(lambda () (case (specific-compile-variant)
[(3m) '("-DMZ_PRECISE_GC")]
[else null]))
(lambda (p)
(unless (and (procedure? p) (procedure-arity-includes? p 0))
(raise-type-error 'current-make-extra-extension-compiler-flags "procedure (arity 0)" p))
p)))
(define (path-string->string s)
(if (string? s) s (path->string s)))
(define unix-compile-include-strings (lambda (s)
(list (string-append "-I" (path-string->string s)))))
(define msvc-compile-include-strings (lambda (s)
(list (string-append "/I" (path-string->string s)))))
(define current-make-compile-include-strings
(make-parameter
(case (system-type)
[(unix macosx) unix-compile-include-strings]
[(windows) (if (or win-gcc? win-borland?)
unix-compile-include-strings
msvc-compile-include-strings)]
[(macos) unix-compile-include-strings])
(lambda (p)
(unless (procedure-arity-includes? p 1)
(raise-type-error 'current-make-compile-include-strings "procedure of arity 1" p))
p)))
(define current-make-compile-input-strings
(make-parameter
(lambda (s) (list (path-string->string s)))
(lambda (p)
(unless (procedure-arity-includes? p 1)
(raise-type-error 'current-make-compile-input-strings "procedure of arity 1" p))
p)))
(define unix-compile-output-strings (lambda (s) (list "-o" (path-string->string s))))
(define msvc-compile-output-strings (lambda (s) (list (string-append "/Fo" (path-string->string s)))))
(define current-make-compile-output-strings
(make-parameter
(case (system-type)
[(unix macosx) unix-compile-output-strings]
[(windows) (if (or win-gcc? win-borland?)
unix-compile-output-strings
msvc-compile-output-strings)]
[(macos) unix-compile-output-strings])
(lambda (p)
(unless (procedure-arity-includes? p 1)
(raise-type-error 'current-make-compile-output-strings "procedure of arity 1" p))
p)))
(define (get-standard-compilers)
(case (system-type)
[(unix macosx) '(gcc cc)]
[(windows) '(gcc msvc borland)]
[(macos) '(cw)]))
(define (use-standard-compiler name)
(define (bad-name name)
(error 'use-standard-compiler "unknown compiler: ~a" name))
(case (system-type)
[(unix macosx)
(case name
[(cc gcc) (let* ([n (if (eq? name 'gcc) "gcc" "cc")]
[f (find-executable-path n n)])
(unless f
(error 'use-standard-compiler "cannot find ~a" n))
(current-extension-compiler f))
(current-extension-compiler-flags (add-variant-flags
(if (eq? name 'gcc)
gcc-compile-flags
unix-compile-flags)))
(current-make-compile-include-strings unix-compile-include-strings)
(current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
(current-make-compile-output-strings unix-compile-output-strings)]
[else (bad-name name)])]
[(windows)
(case name
[(gcc) (let ([f (find-executable-path "gcc.exe" #f)])
(unless f
(error 'use-standard-compiler "cannot find gcc.exe"))
(current-extension-compiler f))
(current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
(current-make-compile-include-strings unix-compile-include-strings)
(current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
(current-make-compile-output-strings unix-compile-output-strings)]
[(borland) (let ([f (find-executable-path "bcc32.exe" #f)])
(unless f
(error 'use-standard-compiler "cannot find bcc32.exe"))
(current-extension-compiler f))
(current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
(current-make-compile-include-strings unix-compile-include-strings)
(current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
(current-make-compile-output-strings unix-compile-output-strings)]
[(msvc) (let ([f (find-executable-path "cl.exe" #f)])
(unless f
(error 'use-standard-compiler "cannot find MSVC's cl.exe"))
(current-extension-compiler f))
(current-extension-compiler-flags (add-variant-flags msvc-compile-flags))
(current-make-compile-include-strings msvc-compile-include-strings)
(current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
(current-make-compile-output-strings msvc-compile-output-strings)]
[else (bad-name name)])]
[(macos)
(case name
[(cw) (current-extension-compiler #f)
(current-extension-compiler-flags (add-variant-flags unix-compile-flags))
(current-make-compile-include-strings unix-compile-include-strings)
(current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
(current-make-compile-output-strings unix-compile-output-strings)]
[else (bad-name name)])]))
(define-values (my-process* stdio-compile)
(let-values ([(p* do-stdio) (get-stdio)])
(values
p*
(lambda (start-process quiet?)
(do-stdio start-process quiet? (lambda (s) (error 'compile-extension "~a" s)))))))
(define (make-compile-extension current-extension-compiler-flags)
(lambda (quiet? in out includes)
(let ([c (current-extension-compiler)])
(if c
(stdio-compile (lambda (quiet?)
(let ([command (append
(list c)
(expand-for-compile-variant
(current-extension-compiler-flags))
(apply append
(map
(lambda (s)
((current-make-compile-include-strings) s))
includes))
((current-make-compile-include-strings) (include-dir))
((current-make-compile-input-strings) in)
((current-make-compile-output-strings) out))])
(unless quiet?
(printf "compile-extension: ~a\n" command))
(apply my-process* command)))
quiet?)
(error 'compile-extension "can't find an installed C compiler")))))
(define compile-extension (make-compile-extension
current-extension-compiler-flags))
(define preprocess-extension (make-compile-extension
current-extension-compiler-flags))))

9
pkgs/cext-lib/dynext/compile.rkt
View File

@ -1,9 +0,0 @@
#lang racket/base
(require racket/unit)
(require "compile-sig.rkt"
"compile-unit.rkt")
(define-values/invoke-unit/infer dynext:compile@)
(provide-signature-elements dynext:compile^)

6
pkgs/cext-lib/dynext/dynext-sig.rkt
View File

@ -1,6 +0,0 @@
(module dynext-sig racket/base
(require "compile-sig.rkt" "link-sig.rkt")
(provide (all-from-out "compile-sig.rkt")
(all-from-out "link-sig.rkt")))

6
pkgs/cext-lib/dynext/dynext-unit.rkt
View File

@ -1,6 +0,0 @@
#lang racket/base
(require "compile-unit.rkt" "link-unit.rkt")
(provide (all-from-out "compile-unit.rkt")
(all-from-out "link-unit.rkt"))

7
pkgs/cext-lib/dynext/dynext.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require "compile.rkt" "link.rkt" dynext/file)
(provide (all-from-out "compile.rkt")
(all-from-out "link.rkt")
(all-from-out dynext/file))

17
pkgs/cext-lib/dynext/file-sig.rkt
View File

@ -1,17 +0,0 @@
#lang racket/base
(require racket/unit)
(provide dynext:file^)
(define-signature dynext:file^
(append-zo-suffix
append-c-suffix
append-constant-pool-suffix
append-object-suffix
append-extension-suffix
extract-base-filename/ss
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext))

7
pkgs/cext-lib/dynext/file-unit.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require racket/unit "file-sig.rkt" dynext/file)
(provide dynext:file@)
(define-unit-from-context dynext:file@ dynext:file^)

16
pkgs/cext-lib/dynext/link-sig.rkt
View File

@ -1,16 +0,0 @@
#lang racket/base
(require racket/unit)
(provide dynext:link^)
(define-signature dynext:link^
(link-extension
current-extension-linker
current-extension-linker-flags
current-make-link-input-strings
current-make-link-output-strings
current-standard-link-libraries
current-use-mzdyn
use-standard-linker
link-variant
expand-for-link-variant))

440
pkgs/cext-lib/dynext/link-unit.rkt
View File

@ -1,440 +0,0 @@
(module link-unit racket/base
(require racket/unit
racket/system
"private/dirs.rkt"
"private/stdio.rkt"
"private/cmdargs.rkt"
dynext/filename-version)
(require "link-sig.rkt")
(provide dynext:link@)
(define-unit dynext:link@
(import)
(export dynext:link^)
(define (path-string->string s)
(if (string? s) s (path->string s)))
;; ---- Find a linker for this platform --------------------
(define (get-windows-linker)
(or (find-executable-path "cl.exe" #f)
(find-executable-path "ld.exe" #f)
(find-executable-path "ilink32.exe" #f)))
(define (get-unix-linker)
(let ([l (case (string->symbol (path->string (system-library-subpath #f)))
[(sparc-solaris i386-solaris
sparc-sunos4
i386-freebsd-2.x
parisc-hpux
i386-cygwin)
'("ld")]
[else '("gcc" "cc")])])
(ormap (lambda (s)
(find-executable-path s #f))
l)))
(define (check-valid-linker-path v)
(unless (and (file-exists? v)
(memq 'execute (file-or-directory-permissions v)))
(error 'current-extension-linker
"linker not found or not executable: ~s" v)))
;; See manual:
(define current-extension-linker
(make-parameter
(or (let ([p (getenv "MZSCHEME_DYNEXT_LINKER")])
(and p
(if (absolute-path? p)
(string->path p)
(find-executable-path p #f))))
(case (system-type)
[(unix macosx) (get-unix-linker)]
[(windows) (get-windows-linker)]
[else #f]))
(lambda (v)
(when v
(if (path-string? v)
(check-valid-linker-path v)
(raise-type-error 'current-extension-linker "path, valid-path string, or #f" v)))
v)))
;; Helpers to tell us about the selected linker in Windows:
(define (still-win-gcc?)
(or (and (eq? 'windows (system-type))
(let ([c (current-extension-linker)])
(and c (regexp-match #"ld.exe$" (path-string->string c)))))
(and (eq? 'unix (system-type))
(string=? "i386-cygwin"
(path->string (system-library-subpath #f))))))
(define (still-win-borland?)
(and (eq? 'windows (system-type))
(let ([c (current-extension-linker)])
(and c (regexp-match #"ilink32.exe$" (path-string->string c))))))
(define win-gcc? (still-win-gcc?))
(define win-borland? (still-win-borland?))
;; ---- The right flags for this platform+linker --------------------
;; We need
;; 1) the basic flags
;; 2) a way to wrap inputs on the command line
;; 3) a way to wrap the output on the command line
;; 4) needed base libraries and objects
(define link-variant (make-parameter
'normal
(lambda (s)
(unless (memq s '(normal cgc 3m))
(raise-type-error 'link-variant "'normal, 'cgc, or '3m" s))
s)))
(define (specific-link-variant)
(let ([v (link-variant)])
(if (eq? v 'normal)
(system-type 'gc)
v)))
(define (wrap-3m s)
(lambda ()
(list (format s (if (eq? '3m (specific-link-variant)) "3m" "")))))
(define (drop-3m s)
(lambda ()
(if (eq? '3m (specific-link-variant))
null
(list s))))
(define (expand-for-link-variant l)
(apply append (map (lambda (s) (if (path-string? s) (list (path-string->string s)) (s))) l)))
(define current-use-mzdyn (make-parameter #t))
(define (mzdyn-maybe s)
(lambda ()
(if (current-use-mzdyn) (s) null)))
(define msvc-linker-flags (list "/LD"))
(define win-gcc-linker-flags (list "--dll"))
(define borland-linker-flags (list "/Tpd" "/c"))
(define mac-link-flags (list "-bundle" "-flat_namespace" "-undefined" "suppress"))
(define (get-unix-link-flags)
(case (string->symbol (path->string (system-library-subpath #f)))
[(sparc-solaris i386-solaris) (list "-G")]
[(sparc-sunos4) (list "-Bdynamic")]
[(i386-freebsd-2.x) (list "-Bshareable")]
[(rs6k-aix) (list "-bM:SRE"
"-brtl"
(lambda ()
(map (lambda (mz-exp)
(format "-bI:~a/~a" (include-dir) mz-exp))
((wrap-3m "mzscheme~a.exp"))))
(format "-bE:~a/ext.exp" (include-dir))
"-bnoentry")]
[(parisc-hpux) (list "-b")]
[(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) mac-link-flags]
[(i386-macosx i386-darwin) (append mac-link-flags '("-m32"))]
[(i386-cygwin) win-gcc-linker-flags]
[else (list "-fPIC" "-shared")]))
(define (get-env-link-flags)
(let ([v (or (getenv "MZSCHEME_DYNEXT_LINKER_FLAGS")
(getenv "LDFLAGS"))])
(if v
(split-command-line-args v)
null)))
;; See manual:
(define current-extension-linker-flags
(make-parameter
(append (get-env-link-flags)
(case (system-type)
[(unix macosx) (get-unix-link-flags)]
[(windows) (cond
[win-gcc? win-gcc-linker-flags]
[win-borland? borland-linker-flags]
[else msvc-linker-flags])]
[(macos) null]))
(lambda (l)
(unless (and (list? l) (andmap string? l))
(raise-type-error 'current-extension-linker-flags "list of strings" l))
l)))
;; See manual:
(define current-make-link-input-strings
(make-parameter
(lambda (s) (list (path-string->string s)))
(lambda (p)
(unless (procedure-arity-includes? p 1)
(raise-type-error 'current-make-link-input-strings "procedure of arity 1" p))
p)))
(define win-gcc-link-output-strings (lambda (s) (list "--base-file"
(path->string (make-win-gcc-temp "base"))
"-e" "_dll_entry@12"
"-o" (path-string->string s))))
(define msvc-link-output-strings (lambda (s) (list (string-append "/Fe" (path-string->string s)))))
(define borland-link-output-strings (lambda (s) (list* "," (path-string->string s)
"," "," "c0d32.obj" "cw32.lib" "import32.lib"
(if (current-use-mzdyn)
(list "," (path->string
(build-path (std-library-dir)
"bcc"
"mzdynb.def")))
null))))
;; See manual:
(define current-make-link-output-strings
(make-parameter
(case (system-type)
[(unix macosx)
(case (string->symbol (path->string (system-library-subpath #f)))
[(i386-cygwin) win-gcc-link-output-strings]
[else (lambda (s) (list "-o" (path-string->string s)))])]
[(windows) (cond
[win-gcc? win-gcc-link-output-strings]
[win-borland? borland-link-output-strings]
[else msvc-link-output-strings])]
[(macos) (lambda (s) (list "-o" (path-string->string s)))])
(lambda (p)
(unless (procedure-arity-includes? p 1)
(raise-type-error 'current-make-link-output-strings "procedure of arity 1" p))
p)))
(define (make-win-link-libraries win-gcc? win-borland? unix?)
(let* ([file (lambda (f)
(path->string
(build-path (std-library-dir)
(cond
[win-gcc? "gcc"]
[win-borland? "bcc"]
[else "msvc"])
f)))]
[dllfile (lambda (f)
(path->string
(build-path (std-library-dir) f)))]
[filethunk (lambda (f)
(lambda ()
(map file (f))))]
[wrap-xxxxxxx
(lambda (file f)
(lambda ()
(map (lambda (s)
(if (file-exists?
(file (format s filename-version-part)))
(file (format s filename-version-part))
(file (format s "xxxxxxx"))))
(f))))])
(cond
[win-gcc? (append
(if unix?
null
(list (wrap-xxxxxxx dllfile (wrap-3m "libracket~a~~a.dll"))
(wrap-xxxxxxx dllfile (drop-3m "libmzgc~a.dll"))))
(list
(mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))
(mzdyn-maybe (filethunk (wrap-3m
;; mzdyn.o is for Unix build, mzdynw.o for Windows
(format "mzdyn~a~~a.o"
(if unix? "" "w")))))
(file "init.o")
(file "fixup.o")))]
[win-borland? (map file (if (current-use-mzdyn)
(list "mzdynb.obj")
null))]
[else (list (wrap-xxxxxxx file (wrap-3m "libracket~a~~a.lib"))
(wrap-xxxxxxx file (drop-3m "libmzgc~a.lib"))
(mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp")))
(mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.obj"))))])))
(define (get-unix/macos-link-libraries)
(case (string->symbol (path->string (system-library-subpath #f)))
[(i386-cygwin)
(make-win-link-libraries #t #f #t)]
[else
(list (lambda ()
(if (current-use-mzdyn)
(map (lambda (mz.o)
(path->string (build-path (std-library-dir) mz.o)))
((wrap-3m "mzdyn~a.o")))
null)))]))
;; See manual:
(define current-standard-link-libraries
(make-parameter
(case (system-type)
[(unix macos macosx) (get-unix/macos-link-libraries)]
[(windows) (make-win-link-libraries win-gcc? win-borland? #f)])
(lambda (l)
(unless (and (list? l)
(andmap (lambda (s) (or (path-string? s)
(and (procedure? s) (procedure-arity-includes? s 0))))
l))
(raise-type-error 'current-stand-link-libraries "list of paths/strings and thunks" l))
l)))
;; ---- Function to install standard linker parameters --------------------
;; see manual
(define (use-standard-linker name)
(define (bad-name name)
(error 'use-standard-linker "unknown linker: ~a" name))
(case (system-type)
[(unix macosx)
(case name
[(cc gcc) (current-extension-linker (get-unix-linker))
(current-extension-linker-flags (get-unix-link-flags))
(current-make-link-input-strings (lambda (s) (list (path-string->string s))))
(current-make-link-output-strings (lambda (s) (list "-o" (path-string->string s))))
(current-standard-link-libraries (get-unix/macos-link-libraries))]
[else (bad-name name)])]
[(windows)
(case name
[(gcc) (let ([f (find-executable-path "ld.exe" #f)])
(unless f
(error 'use-standard-linker "cannot find gcc's ld.exe"))
(current-extension-linker f)
(current-extension-linker-flags win-gcc-linker-flags)
(current-make-link-input-strings (lambda (s) (list (path-string->string s))))
(current-make-link-output-strings win-gcc-link-output-strings)
(current-standard-link-libraries (make-win-link-libraries #t #f #f)))]
[(borland) (let ([f (find-executable-path "ilink32.exe" #f)])
(unless f
(error 'use-standard-linker "cannot find ilink32.exe"))
(current-extension-linker f)
(current-extension-linker-flags borland-linker-flags)
(current-make-link-input-strings (lambda (s) (list (path-string->string s))))
(current-make-link-output-strings borland-link-output-strings)
(current-standard-link-libraries (make-win-link-libraries #f #t #f)))]
[(msvc) (let ([f (find-executable-path "cl.exe" #f)])
(unless f
(error 'use-standard-linker "cannot find MSVC's cl.exe"))
(current-extension-linker f)
(current-extension-linker-flags msvc-linker-flags)
(current-make-link-input-strings (lambda (s) (list (path-string->string s))))
(current-make-link-output-strings msvc-link-output-strings)
(current-standard-link-libraries (make-win-link-libraries #f #f #f)))]
[else (bad-name name)])]
[(macos)
(case name
[(cw) (current-extension-linker #f)
(current-extension-linker-flags null)
(current-make-link-input-strings (lambda (s) (list (path-string->string s))))
(current-make-link-output-strings (lambda (s) (list "-o" (path-string->string s))))
(current-standard-link-libraries (get-unix/macos-link-libraries))]
[else (bad-name name)])]))
;; ---- The link driver for each platform --------------------
(define unix/windows-link
(lambda (quiet? in out)
(let ([c (current-extension-linker)])
(if c
(let* ([output-strings
((current-make-link-output-strings) out)]
[libs (expand-for-link-variant (current-standard-link-libraries))]
[command
(append
(list c)
(expand-for-link-variant (current-extension-linker-flags))
(apply append (map (lambda (s) ((current-make-link-input-strings) s))
in))
libs
output-strings)])
(unless quiet?
(printf "link-extension: ~a\n" command))
(stdio-link (lambda (quiet?)
(apply my-process* command))
quiet?)
;; Stange Cygwin system for relocatable DLLs: we run dlltool twice and
;; ld three times total
(when (still-win-gcc?)
(let ([dlltool (find-executable-path "dlltool.exe" "dlltool.exe")]
;; Find base-file name we already made up:
[basefile (let ([m (member "--base-file" output-strings)])
(and m (cadr m)))]
;; Make new exp file name:
[expfile (make-win-gcc-temp "exp")])
(when (and dlltool basefile)
(let* ([dll-command
;; Generate DLL link information
`("--dllname" ,(if (path? out) (path->string out) out)
,@(if (current-use-mzdyn)
`("--def" ,(path->string (build-path (std-library-dir) "gcc" "mzdyn.def")))
`())
"--base-file" ,basefile
"--output-exp" ,(path->string expfile))]
;; Command to link with new .exp, re-create .base:
[command1
(map (lambda (s)
(let ([s (if (path? s)
(path->string s)
s)])
(if (regexp-match "[.]exp$" s)
(path->string expfile)
s)))
command)]
;; Command to link with new .exp file, no .base needed:
[command2
(let loop ([l command1])
(cond
[(null? l) null]
[(and (string? (car l))
(string=? (car l) "--base-file"))
(cddr l)]
[else (cons (car l) (loop (cdr l)))]))])
(unless quiet?
(printf "link-extension, dlltool phase: ~a\n"
(cons dlltool dll-command)))
(stdio-link (lambda (quiet?)
(apply my-process* dlltool dll-command))
quiet?)
(unless quiet?
(printf "link-extension, re-link phase: ~a\n"
command1))
(stdio-link (lambda (quiet?)
(apply my-process* command1))
quiet?)
(unless quiet?
(printf "link-extension, re-dlltool phase: ~a\n"
(cons dlltool dll-command)))
(stdio-link (lambda (quiet?)
(apply my-process* dlltool dll-command))
quiet?)
(unless quiet?
(printf "link-extension, last re-link phase: ~a\n"
command2))
(stdio-link (lambda (quiet?)
(apply my-process* command2))
quiet?)
(delete-file basefile)
(delete-file expfile))))))
(error 'link-extension "can't find an installed linker")))))
(define link-extension
(case (system-type)
[(unix windows macosx) unix/windows-link]))
;; ---- some helpers:
(define-values (my-process* stdio-link)
(let-values ([(p* do-stdio) (get-stdio)])
(values
p*
(lambda (start-process quiet?)
(do-stdio start-process quiet? (lambda (s) (error 'link-extension "~a" s)))))))
(define (make-win-gcc-temp suffix)
(let ([d (find-system-path 'temp-dir)])
(let loop ([n 1])
(let ([f (build-path d (format "tmp~a.~a" n suffix))])
(if (file-exists? f)
(loop (add1 n))
f)))))))

9
pkgs/cext-lib/dynext/link.rkt
View File

@ -1,9 +0,0 @@
#lang racket/base
(require racket/unit)
(require "link-sig.rkt"
"link-unit.rkt")
(define-values/invoke-unit/infer dynext:link@)
(provide-signature-elements dynext:link^)

4
pkgs/cext-lib/dynext/main.rkt
View File

@ -1,4 +0,0 @@
#lang racket/base
(require "dynext.rkt")
(provide (all-from-out "dynext.rkt"))

32
pkgs/cext-lib/dynext/private/cmdargs.rkt
View File

@ -1,32 +0,0 @@
(module cmdargs racket/base
(provide split-command-line-args)
(define (split-command-line-args v)
(let loop ([v (strip-leading-spaces (strip-trailing-spaces v))])
(if (string=? v "")
null
(let-values ([(s v) (let loop ([v v])
(cond
[(string=? v "") (values "" "")]
[(regexp-match #rx"^[ \t\r\n]" v) (values "" v)]
[(regexp-match-positions #rx"^\"[^\"]*\"" v)
=> (combine v loop 1)]
[(regexp-match-positions #rx"^'[^']*'" v)
=> (combine v loop 1)]
[(regexp-match-positions #rx"^[^ \t\r\n]+" v)
=> (combine v loop 0)]))])
(cons s (loop (strip-leading-spaces v)))))))
(define (combine v loop inset)
(lambda (m)
(let-values ([(rest leftover) (loop (substring v (cdar m)))])
(values (string-append
(substring v (+ (caar m) inset) (- (cdar m) inset)))
leftover))))
(define (strip-leading-spaces v)
(regexp-replace #rx"^[\t \r\n]+" v ""))
(define (strip-trailing-spaces v)
(regexp-replace #rx"[\t \r\n]+$" v "")))

7
pkgs/cext-lib/dynext/private/dirs.rkt
View File

@ -1,7 +0,0 @@
#lang racket/base
(require setup/dirs)
(define include-dir find-include-dir)
(define std-library-dir find-lib-dir)
(provide include-dir std-library-dir)

56
pkgs/cext-lib/dynext/private/stdio.rkt
View File

@ -1,56 +0,0 @@
#lang racket/base
(require racket/system)
(provide get-stdio)
(define (get-stdio)
(values
(if (member (system-library-subpath) '("rs6k-aix" "parisc-hpux"))
(letrec ([pseudo-process*
(lambda (c . args)
(if (null? args)
(let ([r (process* "/usr/bin/csh" "-t")])
(display c (cadr r))
(newline (cadr r))
r)
(apply pseudo-process* (string-append c " " (car args)) (cdr args))))])
pseudo-process*)
process*)
(lambda (start-process quiet? error)
(let* ([l (start-process quiet?)]
[in (car l)]
[out (cadr l)]
[in-error (cadddr l)]
[control (cadddr (cdr l))]
[collect-output (box "")]
[make-collector
(lambda (in dest box)
(thread (lambda ()
(let loop ()
(let ([t (read-line in 'any)])
(unless (eof-object? t)
(unless quiet? (fprintf (dest) "~a\n" t))
(set-box! box (string-append (unbox box)
(string #\newline) t))
(loop)))))))]
[in-thread (make-collector in current-output-port collect-output)]
[in-error-thread (make-collector in-error current-error-port collect-output)])
(close-output-port out)
(control 'wait)
(thread-wait in-thread)
(thread-wait in-error-thread)
(close-input-port in)
(close-input-port in-error)
(unless (eq? (control 'status) 'done-ok)
(error (if quiet?
(unbox collect-output)
"command failed")))))))

10
pkgs/cext-lib/info.rkt
View File

@ -1,10 +0,0 @@
#lang info
(define collection 'multi)
(define deps '("base"
"compiler-lib"
"scheme-lib"
"rackunit-lib"))
(define pkg-desc "Tools for managing C extensions, such as `raco ctool`")
(define pkg-authors '(mflatt))

11
pkgs/compatibility-pkgs/compatibility-doc/LICENSE.txt
View File

@ -1,11 +0,0 @@
compatibility-doc
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

18
pkgs/compatibility-pkgs/compatibility-doc/info.rkt
View File

@ -1,18 +0,0 @@
#lang info
(define collection 'multi)
(define deps '("base"
"scribble-lib"
"compatibility-lib"
"pconvert-lib"
"sandbox-lib"
"compiler-lib"
"gui-lib"
"racket-doc"))
(define pkg-desc "documentation part of \"compatibility\"")
(define pkg-authors '(eli mflatt robby samth))
(define build-deps '("data-doc"
"mzscheme-doc"
"scheme-lib"))
(define update-implies '("compatibility-lib"))

3
pkgs/compatibility-pkgs/compatibility-doc/mzlib/info.rkt
View File

@ -1,3 +0,0 @@
#lang info
(define test-responsibles '((all mflatt)))

69
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/awk.scrbl
View File

@ -1,69 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/awk
scheme/contract))
@mzlib[#:mode title awk]
@defform/subs[
#:literals (after range / => :range range: :range: else)
(awk next-record-expr
(record field-id ...)
maybe-counter
((state-variable init-expr) ...)
maybe-continue
clause ...)
([maybe-counter code:blank
id]
[maybe-continue code:blank
id]
[clause (test body ...+)
(test => procedure-expr)
(/ regexp-str / (id-or-false ...+) body ...+)
(range excl-start-test excl-stop-test body ...+)
(:range incl-start-test excl-stop-test body ...+)
(range: excl-start-test incl-stop-test body ...+)
(:range: incl-start-test incl-stop-test body ...+)
(else body ...+)
(after body ...+)]
[test integer
regexp-string
expr]
[excl-start-test test]
[excl-stop-test test]
[incl-start-test test]
[incl-stop-test test]
[id-or-false id
#f])]{
The @racket[awk] macro from Scsh @cite["Shivers06"]. In addition to
@racket[awk], the Scsh-compatible procedures @racket[match:start],
@racket[match:end], @racket[match:substring], and @racket[regexp-exec]
are defined. These @racketidfont{match:} procedures must be used to
extract match information in a regular expression clause when using
the @racket[=>] form. }
@deftogether[(
@defproc[(match:start [rec ....]
[which exact-nonnegative-integer? 0])
exact-nonnegative-integer?]
@defproc[(match:end [rec ....]
[which exact-nonnegative-integer? 0])
exact-nonnegative-integer?]
@defproc[(match:substring
[rec ....]
[which exact-nonnegative-integer? 0])
string?]
)]{
Extracts a start position, end position, or substring corresponding to
a match. The first argument is the value supplied to the procedure
after @racket[=>] in a @racket[awk] clause or the result of
@racket[regexp-exec].}
@defproc[(regexp-exec [re (or/c string? regexp?)] [s string?])
(or/c .... false/c)]{
Matches a regexp to a string, returning a record compatible with
@racket[match:start], etc.}

40
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/cmdline.scrbl
View File

@ -1,40 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/cmdline))
@(define-syntax-rule (intro id)
(begin
(require (for-label racket/cmdline))
(define id (racket command-line))))
@(intro racket-command-line)
@mzlib[#:mode title cmdline]
@deprecated[@racketmodname[racket/cmdline]]{}
Provides a @racket[command-line] from that is similar to the one in
@racketmodname[racket/cmdline], but without using keywords. The
@racket[parse-command-line] procedure from
@racketmodname[racket/cmdline] is re-exported directly.
@defform/subs[
#:literals (multi once-each once-any final help-labels args =>)
(command-line program-name-expr argv-expr clause ...)
([clause (multi flag-spec ...)
(once-each flag-spec ...)
(once-any flag-spec ...)
(final flag-spec ...)
(help-labels string ...)
(args arg-formals body-expr ...+)
(=> finish-proc-expr arg-help-expr help-proc-expr
unknown-proc-expr)]
[flag-spec (flags id ... help-str ...+ body-expr ...+)
(flags => handler-expr help-expr)]
[flags flag-string
(flag-string ...+)]
[arg-formals id
(id ...)
(id ...+ . id)])]{
Like @racket-command-line from @racket[racket/cmdline], but without
keywords in the syntax.}

45
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/cml.scrbl
View File

@ -1,45 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/cml))
@mzlib[#:mode title cml]
The @racketmodname[mzlib/cml] library defines a number of procedures
that wrap Racket concurrency procedures. The wrapper procedures
have names and interfaces that more closely match those of Concurrent
ML @cite["Reppy99"].
@defproc[(spawn [thunk (-> any)]) thread?]{
Equivalent to @racket[(thread/suspend-to-kill thunk)].}
@defproc[(channel) channel?]{
Equivalent to @racket[(make-channel)].}
@defproc[(channel-recv-evt [ch channel?]) evt?]{
Equivalent to @racket[ch].}
@defproc[(channel-send-evt [ch channel?][v any/c]) evt?]{
Equivalent to @racket[(channel-put-evt ch v)].}
@defproc[(thread-done-evt [thd thread?]) any]{
Equivalent to @racket[(thread-dead-evt thread)].}
@defproc[(current-time) real?]{
Equivalent to @racket[(current-inexact-milliseconds)].}
@defproc[(time-evt [tm real?]) evt?]{
Equivalent to @racket[(alarm-evt tm)].}

24
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/common.rkt
View File

@ -1,24 +0,0 @@
#lang scheme/base
(require (for-syntax scheme/base)
scribble/manual
(for-label mzscheme
(only-in scheme/base exn:fail exn:fail:unsupported exn:fail:contract)))
(provide mzlib
(all-from-out scribble/manual)
(for-label (all-from-out mzscheme)
(all-from-out scheme/base)))
(define-syntax (mzlib stx)
(syntax-case stx ()
[(_ #:mode section name #:use-sources (src ...))
(with-syntax ([lib (string->symbol
(format "mzlib/~a" (syntax-e #'name)))])
#'(begin
(section #:style 'hidden (racket lib))
(defmodule lib #:use-sources (src ...))))]
[(_ #:mode section name)
#'(mzlib #:mode section name #:use-sources ())]
[(_ name)
#'(mzlib #:mode section name #:use-sources ())]))

98
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/compat.scrbl
View File

@ -1,98 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
scribble/eval
(for-label mzlib/compat))
@(define compat-eval (make-base-eval))
@interaction-eval[#:eval compat-eval (require mzlib/compat)]
@mzlib[#:mode title compat]
The @racketmodname[mzlib/compat] library defines a number of
procedures and syntactic forms that are commonly provided by other
Scheme implementations. Most of the procedures are aliases for
@racketmodname[mzscheme] procedures.
@deftogether[(
@defproc[(=? [n number?] ...+) boolean?]
@defproc[(<? [n real?] ...+) boolean?]
@defproc[(>? [n real?] ...+) boolean?]
@defproc[(<=? [n real?] ...+) boolean?]
@defproc[(>=? [n real?] ...+) boolean?]
)]{
Same as @racket[=], @racket[<], etc.}
@deftogether[(
@defproc[(1+ [n number?]) number?]
@defproc[(1- [n number?]) number?]
)]{
Same as @racket[add1] and @racket[sub1].}
@defproc[(gentmp [base (or/c string? symbol?) "g"]) symbol?]{
Same as @racket[gensym].}
@defproc[(flush-output-port [o output-port? (current-output-port)]) void?]{
Same as @racket[flush-output].}
@defproc[(real-time) exact-integer?]{
Same as @racket[current-milliseconds].}
@defproc[(atom? [v any/c]) any]{
Same as @racket[(not (pair? v))] (which does not actually imply an
atomic value).}
@defform*[[(define-structure (name-id field-id ...))
(define-structure (name-id field-id ...)
((init-field-id init-expr) ...))]]{
Like @racket[define-struct], except that the @racket[name-id] is moved
inside the parenthesis for fields. In addition,
@racket[init-field-id]s can be specified with automatic initial-value
expression.
The @racket[init-field-id]s do not have corresponding arguments for
the @racketidfont{make-}@racket[name-id] constructor. Instead, each
@racket[init-field-id]'s @racket[init-expr] is evaluated to obtain the
field's value when the constructor is called. The @racket[field-id]s
are bound in @racket[init-expr]s, but not other
@racket[init-field-id]s.
@examples[
#:eval compat-eval
(define-structure (add left right) ([sum (+ left right)]))
(add-sum (make-add 3 6))
]}
@deftogether[(
@defproc[(getprop [sym symbol?][property symbol?][default any/c #f]) any/c]
@defproc[(putprop [sym symbol?][property symbol?][value any/c]) void?]
)]{
The @racket[getprop] function gets a property value associated with
@racket[sym]. The @racket[property] argument names the property to be
found. If the property is not found, @racket[default] is returned.
The properties obtained with @racket[getprop] are the ones installed
with @racket[putprop].}
@defproc[(new-cafe [eval-handler (any/c . -> . any) #f]) any]{
Emulates Chez Scheme's @racket[new-cafe] by installing
@racket[eval-handler] into the @racket[current-eval] parameter while
running @racket[read-eval-print]. In addition, @racket[current-exit]
is set to escape from the call to @racket[new-cafe].}
@close-eval[compat-eval]

7
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/compile.scrbl
View File

@ -1,7 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label compiler/compile-file))
@mzlib[#:mode title compile]
Re-exports @racket[compile-file] from @racketmodname[compiler/compile-file].

13
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/contract-label.rkt
View File

@ -1,13 +0,0 @@
#lang racket/base
(require (for-label racket/contract)
scribble/manual)
(provide (all-defined-out))
;; this file establishes the right for-label
;; bindings so that I can link to racket/contract
;; combinators in the mzlib/contract docs
(define r:-> (racket ->))
(define r:->* (racket ->*))
(define r:->i (racket ->i))
(define r:->d (racket ->d))

294
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/contract.scrbl
View File

@ -1,294 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
scribble/struct
"contract-label.rkt"
(for-label mzlib/contract)
(for-label (prefix-in r: racket/contract)))
@(define-syntax-rule (twocolumns id ...)
(*twocolumns (list (racket id) ...)))
@(define (*twocolumns uneven-l)
(let* ([l (if (zero? (modulo (length uneven-l) 2)) uneven-l (append uneven-l (list #f)))]
[len (length l)]
[half (quotient len 2)]
[a (for/list ([i (in-range half)]
[e l])
e)]
[b (list-tail l half)]
[spacer (hspace 2)]
[to-flow (compose make-flow list make-paragraph list)])
(make-table #f
(map (lambda (a b)
(list (to-flow spacer)
(to-flow a)
(to-flow spacer)
(to-flow (or b ""))))
a b))))
@mzlib[#:mode title contract]
@deprecated[@racketmodname[racket/contract]]{
This library is designed as a backwards compatible library
for old uses of contracts. It should not be used for new
libraries.
}
The main differences: the function contract syntax is more
regular and function contracts now support keywords, and
@tt{union} is now @racket[or/c].
The @racketmodname[mzlib/contract] library re-exports many bindings
from @racketmodname[racket/contract]:
@twocolumns[
</c
<=/c
=/c
>/c
>=/c
and/c
any
any/c
between/c
box-immutable/c
build-compound-type-name
coerce-contract
cons/c
contract
contract-first-order-passes?
contract-violation->string
contract?
define-contract-struct
false/c
flat-contract
flat-contract-predicate
flat-contract?
flat-murec-contract
flat-named-contract
flat-rec-contract
guilty-party
integer-in
list/c
listof
make-none/c
make-proj-contract
natural-number/c
none/c
not/c
one-of/c
or/c
parameter/c
printable/c
promise/c
provide/contract
raise-contract-error
real-in
recursive-contract
string/len
symbols
syntax/c
vector-immutable/c
vector-immutableof]
It also provides the old version of the following contracts:
@defform[(define/contract id contract-expr init-value-expr)]{
Attaches the contract @racket[contract-expr] to
@racket[init-value-expr] and binds that to @racket[id].
The @racket[define/contract] form treats individual definitions as
units of blame. The definition itself is responsible for positive
(co-variant) positions of the contract and each reference to
@racket[id] (including those in the initial value expression) must
meet the negative positions of the contract.
Error messages with @racket[define/contract] are not as clear as those
provided by @racket[provide/contract], because
@racket[define/contract] cannot detect the name of the definition
where the reference to the defined variable occurs. Instead, it uses
the source location of the reference to the variable as the name of
that definition.}
@defproc[(box/c [c flat-contract?]) flat-contract?]{
Returns a flat contract that recognizes boxes. The content of the box
must match @racket[c].}
@defproc[(vectorof [c flat-contract?]) flat-contract?]{
Accepts a flat contract and returns a flat contract
that checks for vectors whose elements match the original contract.}
@defproc[(vector/c [c flat-contract?] ...) flat-contract?]{
Accepts any number of flat contracts and returns a
flat contract that recognizes vectors. The number of elements in the
vector must match the number of arguments supplied to
@racket[vector/c], and each element of the vector must match the
corresponding flat contract.}
@defform[(struct/c struct-id flat-contract-expr ...)]{
Produces a flat contract that recognizes instances of the structure
type named by @racket[struct-id], and whose field values match the
flat contracts produced by the @racket[flat-contract-expr]s.}
@defproc[(build-flat-contract [name symbol?] [predicate (-> any/c any)]) flat-contract?]{
Builds a flat contract out of @racket[predicate], giving it the name
@racket[name]. Nowadays, just using @racket[predicate] directly is preferred.
}
@defform*[((-> contract-dom-expr ... any)
(-> contract-dom-expr ... contract-rng-expr))]{
This is a restricted form of @racketmodname[racket/contract]'s
@r:-> contract that does not
handle keyword arguments or multiple
value results.
}
@defform*/subs[((->* (contract-dom-expr ...) ->*rng)
(->* (contract-dom-expr ...) contract-rest-expr ->*rng))
([->*rng (contract-rng-expr ...)
any])]{
The @racket[->*] form matches up to
@racketmodname[racket/contract]'s @r:-> and @r:->*, according
to the following rules; each equation on the
left refers to a @racketmodname[mzlib/contract] combinator;
on the right are the @racketmodname[racket/contract] equivalents.
@racketblock[(->* (contract-dom-expr ...) any) =
(#,r:-> contract-dom-expr ... any)]
@racketblock[(->* (contract-dom-expr ...) (contract-rng-expr ...)) =
(#,r:-> contract-dom-expr ... (values contract-rng-expr))]
@racketblock[(->* (contract-expr ...) contract-rest-expr any) =
(#,r:->* (contract-expr ...) #:rest contract-rest-expr any)]
@racketblock[(->* (contract-expr ...) contract-rest-expr (contract-rng-expr ...)) =
(#,r:->* (contract-expr ...)
#:rest contract-rest-expr
(values contract-rng-expr ...))]
}
@defform*[((opt-> (contract-req-expr ...) (contact-opt-expr ...) any)
(opt-> (contract-req-expr ...) (contact-opt-expr ...) contract-rng-expr))]{
The @racket[opt->] form is a simplified verison of @racketmodname[racket/contract]'s
@|r:->*| and appearances of @racket[opt->] can be simply replaced with @|r:->*|.
}
@defform*[((opt->* (contract-req-expr ...) (contact-opt-expr ...) any)
(opt->* (contract-req-expr ...) (contact-opt-expr ...) (contract-rng-expr ...)))]{
The @racket[opt->*] form matches up to
@racketmodname[racket/contract]'s @r:->*, according
to the following rules; each equation on the
left refers to a @racketmodname[mzlib/contract] combinator;
on the right are the @racketmodname[racket/contract] equivalents.
@racketblock[(opt->* (contract-req-expr ...) (contract-opt-expr ...) any) =
(#,r:->* (contract-req-expr ...) (contract-opt-expr ...) any)]
@racketblock[(opt->* (contract-req-expr ...)
(contract-opt-expr ...)
(contract-rng-expr ...)) =
(#,r:->* (contract-req-expr ...)
(contract-opt-expr ...)
(values contract-rng-expr ...))]
}
@defform[(->d contract-dom-expr ... contract-rng-fun-expr)]{
The @racket[->d] contract constructor is just like @racket[->],
except that the range position is expected to be a function
that accepts the actual arguments passed to the function,
and returns a contract for the range. For example, this
is one contract for @racket[sqrt]:
@racketblock[(->d real?
(λ (in)
(and/c real?
(λ (out)
(< (abs (- (sqr out) in))
0.01)))))]
It says that the input must be a real number, and so must the
result, and that the square of the result is within
@racket[0.01] of input.
}
@defform*[((->d* (contract-dom-expr ...) contract-rng-fun-expr)
(->d* (contract-dom-expr ...) contract-rest-expr contract-rng-fun-expr))]{
The @racket[->d*] contract constructor is a generalization of
@racket[->d] to support multiple values and rest arguments.
In the two sub-expression case, the first sequence of contracts
are contracts on the domain of the function and the second
subexpression is expected to evaluate to a function that accepts
as many arguments as there are expressions in the first position.
It should return multiple values: one contract for each result
of the function.
In the three sub-expression case, the first and last subexpressions
are just like the sub-expressions in the two sub-expression case;
the middle sub-expression si expected to evaluate to a contract on
the rest argument.
}
@defform*/subs[((->r ([dom-x contract-dom-expr] ...) rng)
(->r ([dom-x contract-dom-expr] ...) rest-x contract-rest-expr rng))
((rng any
(values contract-expr ...)
contract-expr))]{
The @racket[->r] form is a simplified version of @racketmodname[racket/contract]'s @|r:->i|, where
each @racket[contract-dom-expr] is parameterized over all of the @racket[dom-x] variables
(and does lax checking; see @r:->d for details).
}
@defform*[((->pp ([dom-x contract-dom-expr] ...) pre-cond-expr any)
(->pp ([dom-x contract-dom-expr] ...)
pre-cond-expr
(values [rng-x contract-rng-expr] ...)
post-cond-expr)
(->pp ([dom-x contract-dom-expr] ...)
pre-cond-expr
contract-rng-expr
rng-x
post-cond-expr))]{
The @racket[->pp] form, like @racket[->r] is a simplified version of @racketmodname[racket/contract]'s @|r:->i|, where
each @racket[contract-dom-expr] is parameterized over all of the @racket[dom-x] variables
(and does lax checking; see @racketmodname[racket/contract]'s @r:->d for details). Unlike @racket[->r], it also has pre- and post-condition
expressions; these expressions are also implicitly parameterized over all of the @racket[dom-x]
variables and the post-condition is also paramterized over @racket[rng-x], which is bound to the result
of the function.
}
@defform*[((->pp-rest ([dom-x contract-dom-expr] ...) rest-x rest-contract-expr pre-cond-expr any)
(->pp-rest ([dom-x contract-dom-expr] ...)
rest-x rest-contract-expr
pre-cond-expr
(values [rng-x contract-rng-expr] ...)
post-cond-expr)
(->pp-rest ([dom-x contract-dom-expr] ...)
rest-x rest-contract-expr
pre-cond-expr
contract-rng-expr
rng-x
post-cond-expr))]{
Like @racket[->pp], but with an additional contract for the rest arguments of the function.
}
@defform[(case-> mzlib/contract-arrow-contract-expr ...)]{
Builds a contract analogous to @racket[case-lambda],
where each case comes from one of the contract expression arguments
(tried in order).
}
@defform[(object-contract [id mzlib/contract-arrow-contract-expr] ...)]{
Builds a contract for objects where each @racket[id] is expected to be
a method on the object living up to the corresponding contract
}

274
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/etc.scrbl
View File

@ -1,274 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
scribble/eval
(for-label mzlib/etc
scheme/bool
scheme/local
setup/dirs
racket/block
(only-in scheme build-list build-string build-vector
symbol=?)))
@(define etc-eval (make-base-eval))
@interaction-eval[#:eval etc-eval (require mzlib/etc)]
@(begin
(define-syntax-rule (bind id else-id)
(begin
(require (for-label scheme/base))
(define id (racket lambda))
(define else-id (racket else))))
(bind base-lambda base-else))
@mzlib[#:mode title etc]
The @racketmodname[mzlib/etc] library re-exports the following from
@racketmodname[scheme/base] and other libraries:
@racketblock[
boolean=?
true
false
build-list
build-string
build-vector
compose
local
symbol=?
nand
nor
]
@defform[(begin-lifted expr ...+)]
Lifts the @racket[expr]s so that they are evaluated once at the ``top
level'' of the current context, and the result of the last
@racket[expr] is used for every evaluation of the
@racket[begin-lifted] form.
When this form is used as a run-time expression within a module, the
``top level'' corresponds to the module's top level, so that each
@racket[expr] is evaluated once for each invocation of the
module. When it is used as a run-time expression outside of a module,
the ``top level'' corresponds to the true top level. When this form is
used in a @racket[define-syntax], @racket[letrec-syntax],
etc. binding, the ``top level'' corresponds to the beginning of the
binding's right-hand side. Other forms may redefine ``top level''
(using @racket[local-expand/capture-lifts]) for the expressions that
they enclose.
@defform[(begin-with-definitions defn-or-expr ...)]{
The same as @racket[(block defn-or-expr ...)].}
@defform[(define-syntax-set (id ...) defn ...)]{
Similar to @racket[define-syntaxes], but instead of a single body
expression, a sequence of definitions follows the sequence of defined
identifiers. For each @racket[identifier], the @racket[defn]s should
include a definition for @racket[id]@racketidfont{/proc}. The value
for @racket[id]@racketidfont{/proc} is used as the (expansion-time)
value for @racket[id].
The @racket[define-syntax-set] form is useful for defining a set of
syntax transformers that share helper functions, though
@racket[begin-for-syntax] now serves essentially the same purposes.
@as-examples[
@racketblock[
(define-syntax-set (let-current-continuation
let-current-escape-continuation)
(define (mk call-id)
(lambda (stx)
(syntax-case stx ()
[(_ id body1 body ...)
(with-syntax ([call call-id])
(syntax (call (lambda (id) body1 body ...))))])))
(define let-current-continuation/proc
(mk (quote-syntax call/cc)))
(define let-current-escape-continuation/proc
(mk (quote-syntax call/ec))))
]]}
@defform*[#:literals (else)
[(evcase key-expr (value-expr body-expr ...) ...+)
(evcase key-expr (value-expr body-expr ...) ... [else body-expr ...])]]{
The @racket[evcase] form is similar to @racket[case], except that
expressions are provided in each clause instead of a sequence of
data. After @racket[key-expr] is evaluated, each @racket[value-expr]
is evaluated until a value is found that is @racket[eqv?] to the key
value; when a matching value is found, the corresponding
@racket[body-expr]s are evaluated and the value(s) for the last is the
result of the entire @racket[evcase] expression.
The @racket[else] literal is recognized either as unbound (like in the
@racketmodname[mzscheme] language) or bound as @|base-else| from
@racketmodname[scheme/base].}
@defproc[(identity [v any/c]) any/c]{
Returns @racket[v].}
@defform/subs[#:literals (val rec vals recs _ values)
(let+ clause body-expr ...+)
([clause (val target expr)
(rec target expr)
(vals (target ...) expr)
(recs (target expr) ...)
(_ expr ...)]
[target id
(values id ...)])]{
A binding construct that specifies scoping on a per-binding basis
instead of a per-expression basis. It helps eliminate rightward-drift
in programs. It looks similar to @racket[let], except each clause has
an additional keyword tag before the binding variables.
Each @racket[clause] has one of the following forms:
@itemize[
@item{@racket[(val target expr)] : Binds @racket[target]
non-recursively to @racket[expr].}
@item{@racket[(rec target expr)] : Binds @racket[target] recursively to
@racket[expr].}
@item{@racket[(vals (target expr) ...)] : The @racket[target]s are
bound to the @racket[expr]s. The environment of the @racket[expr]s is
the environment active before this clause.}
@item{@racket[(recs (target expr) ...)] : The @racket[targets]s are
bound to the @racket[expr]s. The environment of the @racket[expr]s
includes all of the @racket[targets]s.}
@item{@racket[(_ expr ...)] : Evaluates the @racket[expr]s without
binding any variables.}
]
The clauses bind left-to-right. When a @racket[target] is
@racket[(values id ...)], multiple values returned by the
corresponding expression are bound to the multiple variables.
@examples[
#:eval etc-eval
(let+ ([val (values x y) (values 1 2)])
(list x y))
(let ([x 1])
(let+ ([val x 3]
[val y x])
y))
]}
@defproc[(loop-until [start any/c] [done? (any/c . -> . any)]
[next (any/c . -> . any/c)]
[f (any/c . -> . any)])
void?]{
Repeatedly invokes the @racket[f] procedure until the @racket[done?]
procedure returns @racket[#t]:
@racketblock[
(define (loop-until start done? next f)
(let loop ([i start])
(unless (done? i)
(f i)
(loop (next i)))))
]}
@defproc[(namespace-defined? [sym symbol?]) boolean?]{
Returns @racket[#t] if @racket[namespace-variable-value] would return
a value for @racket[sym], @racket[#f] otherwise.}
@defform[(nand expr ...)]{
Same as @racket[(not (and expr ...))].}
@defform[(nor expr ...)]{
Same as @racket[(not (or expr ...))].}
@defform[(opt-lambda formals body ...+)]{
Supports optional (but not keyword) arguments like @base-lambda from
@racket[scheme/base].}
@defform[(recur id bindings body ...+)]{
Equivalent to @racket[(let id bindings body ...+)].}
@defform*[[(rec id value-expr)
(rec (id arg-id ...) expr)
(rec (id arg-id ... . rest-id) expr)]]{
Equivalent, respectively, to
@racketblock[
(letrec ([id value-expr]) id)
(letrec ([id (lambda (arg-id ...) value-expr)]) id)
(letrec ([id (lambda (arg-id ... . rest-id) value-expr)]) id)
]}
@defform*[[(this-expression-source-directory)
(this-expression-source-directory datum)]]{
@margin-note{See @racketmodname[scheme/runtime-path] for a definition form
that works better when creating executables.}
Expands to an expression that evaluates to the directory of the file
containing the source @racket[datum]. If @racket[datum] is not
supplied, then the entire @racket[(this-expression-source-directory)]
expression is used as @racket[datum].
If @racket[datum] has a source module, then the expansion attempts to
determine the module's run-time location. This location is determined
by preserving the lexical context of @racket[datum] in a syntax
object, extracting its source module path at run time, and then
resolving the module path.
Otherwise, @racket[datum]'s source file is determined through source
location information associated with @racket[datum], if it is
present. As a last resort, @racket[current-load-relative-directory] is
used if it is not @racket[#f], and @racket[current-directory] is used
if all else fails.
A directory path derived from source location is always stored in
bytes in the expanded code, unless the file is within the result of
@racket[find-collects-dir], in which case the expansion records the
path relative to @racket[(find-collects-dir)] and then reconstructs it
using @racket[(find-collects-dir)] at run time.}
@defform*[[(this-expression-file-name)
(this-expression-file-name datum)]]{
Similar to @racket[this-expression-source-directory], except that only
source information associated with @racket[datum] or
@racket[(this-expression-file-name)] is used to extract a filename. If
no filename is available, the result is @racket[#f].}
@defform[#:literals (quote unsyntax scheme)
(hash-table (#,(racket quote) flag) ... (key-expr val-expr) ...)]{
Creates a new hash-table providing the quoted flags (if any) to
@racket[make-hash-table], and then mapping each key to the
corresponding values.}
@close-eval[etc-eval]

66
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/file.scrbl
View File

@ -1,66 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/file
scheme/contract))
@mzlib[#:mode title file]
@deprecated[@racketmodname[racket/file]]{}
The @racketmodname[mzlib/file] library mostly re-exports from
@racketmodname[scheme/file]:
@racketblock[
find-relative-path
explode-path
normalize-path
filename-extension
file-name-from-path
path-only
delete-directory/files
copy-directory/files
make-directory*
make-temporary-file
get-preference
put-preferences
fold-files
find-files
pathlist-closure
]
@deftogether[(
@defproc[(call-with-input-file* [file path-string?]
[proc (input-port? -> any)]
[mode (one-of/c 'text 'binary) 'binary])
any]
@defproc[(call-with-output-file* [file path-string?]
[proc (output-port? -> any)]
[mode (one-of/c 'text 'binary) 'binary]
[exists (one-of/c 'error 'append 'update
'replace 'truncate 'truncate/replace) 'error])
any]
)]{
Like @racket[call-with-input-file]and @racket[call-with-output-file],
except that the opened port is closed if control escapes from the body
of @racket[proc].}
@deftogether[(
@defproc[(build-relative-path [base (or/c path-string?
(one-of/c 'up 'same))]
[sub (or/c (and/c path-string?
relative-path?)
(one-of/c 'up 'same))] ...)
(and/c path? relative-path?)]
@defproc[(build-absolute-path [base (or/c (and/c path-string?
(not/c relative-path?))
(one-of/c 'up 'same))]
[sub (or/c (and/c path-string?
(not/c complete-path?))
(one-of/c 'up 'same))] ...)
(and/c path? absolute-path?)]
)]{
Like @racket[build-path], but with extra constraints to ensure a
relative or absolute result.}

47
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/for.scrbl
View File

@ -1,47 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/for))
@mzlib[#:mode title for]
@deprecated[@racketmodname[racket/base]]{}
The @racketmodname[mzlib/for] library re-exports from
@racketmodname[scheme/base]:
@racketblock[
for/fold for*/fold
for for*
for/list for*/list
for/lists for*/lists
for/and for*/and
for/or for*/or
for/first for*/first
for/last for*/last
for/fold/derived for*/fold/derived
in-range
in-naturals
in-list
in-vector
in-string
in-bytes
in-input-port-bytes
in-input-port-chars
in-hash-table
in-hash-table-keys
in-hash-table-values
in-hash-table-pairs
in-parallel
stop-before
stop-after
in-indexed
sequence?
sequence-generate
define-sequence-syntax
make-do-sequence
:do-in]

70
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/include.scrbl
View File

@ -1,70 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/include))
@mzlib[#:mode title include]
@deprecated[@racketmodname[racket/include]]{}
Similar to @racketmodname[scheme/include], but with a different syntax
for paths.
@defform/subs[#:literals (build-path lib up same)
(include path-spec)
([path-spec string
(build-path elem ...+)
(lib file-string collection-string ...)]
[elem string
up
same])]{
Inlines the syntax in the designated file in place of the
@racket[include] expression. The @racket[path-spec] can be any of the
following:
@itemize[
@item{A literal string that specifies a path to include, parsed
according to the platform's conventions (which means that it is
not portable).}
@item{A path construction of the form @racket[(build-path elem
...+)], where @racket[build-path] is
@racket[module-identifier=?] either to the @racket[build-path]
export from @racket[mzscheme] or to the top-level
@racket[build-path], and where each @racket[elem] is a path
string, @racket[up] (unquoted), or @racket[same] (unquoted).
The @racket[elem]s are combined in the same way as for the
@racket[build-path] function to obtain the path to include.}
@item{A path construction of the form @racket[(lib file-string
collection-string ...)], where @racket[lib] is free or refers
to a top-level @racket[lib] variable. The
@racket[collection-string]s are passed to
@racket[collection-path] to obtain a directory; if no
@racket[collection-strings]s are supplied, @racket["mzlib"] is
used. The @racket[file-string] is then appended to the
directory using @racket[build-path] to obtain the path to
include.}
]
If @racket[path-spec] specifies a relative path to include, the path
is resolved relative to the source for the @racket[include]
expression, if that source is a complete path string. If the source is
not a complete path string, then @racket[path-spec] is resolved
relative to the current load relative directory if one is available,
or to the current directory otherwise.
The included syntax is given the lexical context of the
@racket[include] expression.}
@deftogether[(
@defform[(include-at/relative-to context source path-spec)]
@defform[(include-at/relative-to/reader context source path-spec reader-expr)]
@defform[(include/reader path-spec reader-expr)]
)]{
Variants of @racket[include] analogous to the variants of
@racketmodname[scheme/include].}

3
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/info.rkt
View File

@ -1,3 +0,0 @@
#lang info
(define scribblings '(("mzlib.scrbl" (multi-page) (legacy))))

13
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/integer-set.scrbl
View File

@ -1,13 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label data/integer-set
mzlib/integer-set))
@mzlib[#:mode title integer-set]
@deprecated[@racketmodname[data/integer-set]]{}
The @racketmodname[mzlib/integer-set] library re-exports bindings
from @racketmodname[data/integer-set] except that it renames
@racket[symmetric-difference] to @racket[xor], @racket[subtract]
to @racket[difference], and @racket[count] to @racket[card].

452
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/kw.scrbl
View File

@ -1,452 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
scribble/eval
(for-label mzlib/kw
mzlib/etc))
@(define kw-eval (make-base-eval))
@interaction-eval[#:eval kw-eval (require mzscheme)]
@interaction-eval[#:eval kw-eval (require mzlib/kw)]
@(begin
(define-syntax-rule (bind id)
(begin
(require (for-label scheme/base))
(define id (racket lambda))))
(bind base-lambda))
@mzlib[#:mode title kw]
@deprecated[@racketmodname[racket/base]]{The Racket base language
supports keyword arguments. Using the built-in keyword arguments
in Racket is highly recommended.}
@margin-note{The @base-lambda and procedure-application forms of
@racket[scheme/base] support keyword arguments, and it is
@emph{not} compatible with the @racket[mzlib/kw]
library.}
@deftogether[(
@defform[(lambda/kw kw-formals body ...+)]
@defform/subs[
(define/kw (head args) body ...+)
([kw-formals id
(id ... [#:optional optional-spec ...]
[#:key key-spec ...]
[rest/mode-spec ...])
(id ... . id)]
[optional-spec id
(id default-expr)]
[key-spec id
(id default-expr)
(id keyword default-expr)]
[rest/mode-spec (code:line #:rest id)
(code:line #:other-keys id)
(code:line #:other-keys+body id)
(code:line #:all-keys id)
(code:line #:body kw-formals)
(code:line #:allow-other-keys)
(code:line #:forbid-other-keys)
(code:line #:allow-duplicate-keys)
(code:line #:forbid-duplicate-keys)
(code:line #:allow-body)
(code:line #:forbid-body)
(code:line #:allow-anything)
(code:line #:forbid-anything)]
[head id
(head . kw-formals)])
])]{
Like @racket[lambda], but with optional and keyword-based argument
processing. This form is similar to an extended version of Common
Lisp procedure arguments (but note the differences below). When used
with plain variable names, @racket[lambda/kw] expands to a plain
@racket[lambda], so @racket[lambda/kw] is suitable for a language
module that will use it to replace @racket[lambda]. Also, when used
with only optionals, the resulting procedure is similar to
@racket[opt-lambda] (but a bit faster).
In addition to @racket[lambda/kw], @racket[define/kw] is similar to
@racket[define], except that the @racket[formals] are as in
@racket[lambda/kw]. Like @racket[define], this form can be used with
nested parenthesis for curried functions (the MIT-style generalization
of @racket[define]).
The syntax of @racket[lambda/kw] is the same as @racket[lambda],
except for the list of formal argument specifications. These
specifications can hold (zero or more) plain argument names, then an
optionals (and defaults) section that begins after an
@racket[#:optional] marker, then a keyword section that is marked by
@racket[#:keyword], and finally a section holding rest and
``rest''-like arguments which are described below, together with
argument processing flag directives. Each section is optional, but
the order of the sections must be as listed. Of course, all binding
@racket[id]s must be unique.
The following sections describe each part of the @racket[kw-formals].}
@; ----------------------------------------
@section{Required Arguments}
Required arguments correspond to @racket[id]s that appear before any
keyword marker in the argument list. They determine the minimum arity
of the resulting procedure.
@; ----------------------------------------
@section{Optional Arguments}
The optional-arguments section follows an
@as-index{@racket[#:optional]} marker in the @racket[_kw-formals].
Each optional argument can take the form of a parenthesized variable
and a default expression; the latter is used if a value is not given
at the call site. The default expression can be omitted (along with
the parentheses), in which case @racket[#f] is the default.
The default expression's environment includes all previous arguments,
both required and optional names. With @math{k} optionals after
@math{n} required arguments, and with no keyword arguments or
rest-like arguments, the resulting procedure accept between @math{n}
and @math{n+k} arguments, inclusive.
The treatment of optionals is efficient, with an important caveat:
default expressions appear multiple times in the resulting
@racket[case-lambda]. For example, the default expression for the last
optional argument appears @math{k-1} times (but no expression is ever
evaluated more than once in a procedure call). This expansion risks
exponential blow-up is if @racket[lambda/kw] is used in a default
expression of a @racket[lambda/kw], etc. The bottom line, however, is
that @racket[lambda/kw] is a sensible choice, due to its enhanced
efficiency, even when you need only optional arguments.
Using both optional and keyword arguments is possible, but note that
the resulting behavior differs from traditional keyword facilities
(including the one in Common Lisp). See the following section for
details.
@; ----------------------------------------
@section{Keyword Arguments}
A keyword argument section is marked by a @as-index{@racket[#:key]}.
If it is used with optional arguments, then the keyword specifications
must follow the optional arguments (which mirrors the use in call
sites; where optionals are given before keywords).
When a procedure accepts both optional and keyword arguments, the
argument-handling convention is slightly different than in traditional
keyword-argument facilities: a keyword after required arguments marks
the beginning of keyword arguments, no matter how many optional
arguments have been provided before the keyword. This convention
restricts the procedure's non-keyword optional arguments to
non-keyword values, but it also avoids confusion when mixing optional
arguments and keywords. For example, when a procedure that takes two
optional arguments and a keyword argument @racket[#:x] is called with
@racket[#:x 1], then the optional arguments get their default values
and the keyword argument is bound to @racket[1]. (The traditional
behavior would bind @racket[#:x] and @racket[1] to the two optional
arguments.) When the same procedure is called with @racket[1 #:x 2],
the first optional argument is bound to @racket[1], the second
optional argument is bound to its default, and the keyword argument is
bound to @racket[2]. (The traditional behavior would report an error,
because @racket[2] is provided where @racket[#:x] is expected.)
Like optional arguments, each keyword argument is specified as a
parenthesized variable name and a default expression. The default
expression can be omitted (with the parentheses), in which case
@racket[#f] is the default value. The keyword used at a call site for
the corresponding variable has the same name as the variable; a third
form of keyword arguments has three parts---a variable name, a
keyword, and a default expression---to allow the name of the locally
bound variable to differ from the keyword used at call sites.
When calling a procedure with keyword arguments, the required argument
(and all optional arguments, if specified) must be followed by an even
number of arguments, where the first argument is a keyword that
determines which variable should get the following value, etc. If the
same keyword appears multiple times (and if multiple instances of the
keyword are allowed; see @secref["mode-keywords"]), the value after
the first occurrence is used for the variable:
@examples[
#:eval kw-eval
((lambda/kw (#:key x [y 2] [z #:zz 3] #:allow-duplicate-keys)
(list x y z))
#:x 'x #:zz 'z #:x "foo")
]
Default expressions are evaluated only for keyword arguments that do
not receive a value for a particular call. Like optional arguments,
each default expression is evaluated in an environment that includes
all previous bindings (required, optional, and keywords that were
specified on its left).
See @secref["mode-keywords"] for information on when duplicate or
unknown keywords are allowed at a call site.
@; ----------------------------------------
@section{Rest and Rest-like Arguments}
The last @racket[_kw-formals] section---after the required, optional,
and keyword arguments---may contain specifications for rest-like
arguments and/or mode keywords. Up to five rest-like arguments can be
declared, each with an @racket[_id] to bind:
@itemize[
@item{@as-index{@racket[#:rest]} --- The variable is bound to the
list of ``rest'' arguments, which is the list of all values after
the required and the optional values. This list includes all
keyword-value pairs, exactly as they are specified at the call site.
Scheme's usual dot-notation is accepted in @racket[_kw-formals] only
if no other meta-keywords are specified, since it is not clear
whether it should specify the same binding as a @racket[#:rest] or
as a @racket[#:body]. The dot notation is allowed without
meta-keywords to make the @racket[lambda/kw] syntax compatible with
@racket[lambda].}
@item{@as-index{@racket[#:body]} --- The variable is bound to all
arguments after keyword--value pairs. (This is different from
Common Lisp's @racket[&body], which is a synonym for
@racket[&rest].) More generally, a @racket[#:body] specification
can be followed by another @racket[_kw-formals], not just a single
@racket[_id]; see @secref["kw-body"] for more information.}
@item{@as-index{@racket[#:all-keys]} --- the variable is bound to the
list of all keyword-values from the call site, which is always a
proper prefix of a @racket[#:rest] argument. (If no @racket[#:body]
arguments are declared, then @racket[#:all-keys] binds the same as
@racket[#:rest].) See also @racket[keyword-get].}
@item{@racket[#:other-keys] --- The variable is bound like an
@racket[#:all-keys] variable, except that all keywords specified in
the @racket[kw-formals] are removed from the list. When a keyword
is used multiple times at a call cite (and this is allowed), only
the first instances is removed for the @racket[#:other-keys]
binding.}
@item{@racket[#:other-keys+body] --- the variable is bound like a
@racket[#:rest] variable, except that all keywords specified in the
@racket[_kw-formals] are removed from the list. When a keyword is
used multiple times at a call site (and this is allowed), only the
first instance us removed for the @racket[#:other-keys+body]
binding. (When no @racket[#:body] variables are specified, then
@racket[#:other-keys+body] is the same as @racket[#:other-keys].)}
]
In the following example, all rest-like arguments are used and have different
bindings:
@examples[
#:eval kw-eval
((lambda/kw (#:key x y
#:rest r
#:other-keys+body rk
#:all-keys ak
#:other-keys ok
#:body b)
(list r rk b ak ok))
#:z 1 #:x 2 2 3 4)
]
Note that the following invariants always hold:
@itemize[
@item{@racket[_rest] = @racket[(append _all-keys _body)]}
@item{@racket[_other-keys+body] = @racket[(append _other-keys _body)]}
]
To write a procedure that uses a few keyword argument values, and that
also calls another procedure with the same list of arguments
(including all keywords), use @racket[#:other-keys] (or
@racket[#:other-keys+body]). The Common Lisp approach is to specify
@racket[:allow-other-keys], so that the second procedure call will not
cause an error due to unknown keywords, but the
@racket[:allow-other-keys] approach risks confusing the two layers of
keywords.
@; ----------------------------------------
@section[#:tag "kw-body"]{Body Argument}
The most notable divergence from Common Lisp in @racket[lambda/kw] is
the @racket[#:body] argument, and the fact that it is possible at a
call site to pass plain values after the keyword-value pairs. The
@racket[#:body] binding is useful for procedure calls that use
keyword-value pairs as sort of an attribute list before the actual
arguments to the procedure. For example, consider a procedure that
accepts any number of numeric arguments and will apply a procedure to
them, but the procedure can be specified as an optional keyword
argument. It is easily implemented with a @racket[#:body] argument:
@examples[
#:eval kw-eval
(define/kw (mathop #:key [op +] #:body b)
(apply op b))
(mathop 1 2 3)
(mathop #:op max 1 2 3)
]
(Note that the first body value cannot itself be a keyword.)
A @racket[#:body] declaration works as an arbitrary
@racket[kw-formals], not just a single variable like @racket[b] in the
above example. For example, to make the above @racket[mathop] work
only on three arguments that follow the keyword, use @racket[(x y z)]
instead of @racket[b]:
@examples[
#:eval kw-eval
(define/kw (mathop #:key [op +] #:body (x y z))
(op x y z))
]
In general, @racket[#:body] handling is compiled to a sub procedure
using @racket[lambda/kw], so that a procedure can use more then one
level of keyword arguments. For example:
@examples[
#:eval kw-eval
(define/kw (mathop #:key [op +]
#:body (x y z #:key [convert values]))
(op (convert x) (convert y) (convert z)))
(mathop #:op * 2 4 6 #:convert exact->inexact)
]
Obviously, nested keyword arguments works only when non-keyword
arguments separate the sets.
Run-time errors during such calls report a mismatch for a procedure
with a name that is based on the original name plus a @racketidfont{~body}
suffix:
@examples[
#:eval kw-eval
(mathop #:op * 2 4)
]
@; ----------------------------------------
@section[#:tag "mode-keywords"]{Mode Keywords}
Finally, the argument list of a @racket[lambda/kw] can contain
keywords that serve as mode flags to control error reporting.
@itemize[
@item{@as-index{@racket[#:allow-other-keys]} --- The keyword-value
sequence at the call site @italic{can} include keywords that are not
listed in the keyword part of the @racket[lambda/kw] form.}
@item{@as-index{@racket[#:forbid-other-keys]} --- The keyword-value
sequence at the call site @italic{cannot} include keywords that are
not listed in the keyword part of the @racket[lambda/kw] form,
otherwise the @racket[exn:fail:contract] exception is raised.}
@item{@as-index{@racket[#:allow-duplicate-keys]} --- The
keyword-value list at the call site @emph{can} include duplicate
values associated with same keyword, the first one is used.}
@item{@as-index{@racket[#:forbid-duplicate-keys]} --- The
keyword-value list at the call site @italic{cannot} include
duplicate values for keywords, otherwise the
@racket[exn:fail:contract] exception is raised. This restriction
applies only to keywords that are listed in the keyword part of the
@racket[lambda/kw] form --- if other keys are allowed, this
restriction does not apply to them.}
@item{@as-index{@racket[#:allow-body]} --- Body arguments
@italic{can} be specified at the call site after all keyword-value
pairs.}
@item{@as-index{@racket[#:forbid-body]} --- Body arguments
@italic{cannot} be specified at the call site after all
keyword-value pairs.}
@item{@as-index{@racket[#:allow-anything]} --- Allows all of the
above, and treat a single keyword at the end of an argument list as
a @racket[#:body], a situation that is usually an error. When this
is used and no rest-like arguments are used except @racket[#:rest],
an extra loop is saved and calling the procedures is faster (around
20%).}
@item{@as-index{@racket[#:forbid-anything]} --- Forbids all of the
above, ensuring that calls are as restricted as possible.}
]
These above mode markers are rarely needed, because the default modes
are determined by the declared rest-like arguments:
@itemize[
@item{The default is to allow other keys if a @racket[#:rest],
@racket[#:other-keys+body], @racket[#:all-keys], or
@racket[#:other-keys] variable is declared (and an
@racket[#:other-keys] declaration requires allowing other keys).}
@item{The default is to allow duplicate keys if a @racket[#:rest] or
@racket[#:all-keys] variable is declared.}
@item{The default is to allow body arguments if a @racket[#:rest],
@racket[#:body], or @racket[#:other-keys+body] variable is declared
(and a @racket[#:body] argument requires allowing them).}
]
Here's an alternate specification, which maps rest-like arguments to
the behavior that they imply:
@itemize[
@item{@racket[#:rest]: Everything is allowed (a body, other keys,
and duplicate keys);}
@item{@racket[#:other-keys+body]: Other keys and body are allowed,
but duplicates are not;}
@item{@racket[#:all-keys]: Other keys and duplicate keys are allowed,
but a body is not;}
@item{@racket[#:other-keys]: Other keys must be allowed (on by
default, cannot use with @racket[#:forbid-other-keys]), and
duplicate keys and body are not allowed;}
@item{@racket[#:body]: Body must be allowed (on by default, cannot use
with @racket[#:forbid-body]) and other keys and duplicate keys and
body are not allowed;}
@item{Except for the previous two ``must''s, defaults can be
overridden by an explicit @racket[#:allow-...] or a
@racket[#:forbid-...] mode.}
]
@; ----------------------------------------
@section[#:tag "keyword-get"]{Property Lists}
@defproc[(keyword-get [args (listof (cons/c keyword? any/c))] [kw keyword?]
[not-found (-> any)])
any]{
Searches a list of keyword arguments (a ``property list'' or ``plist''
in Lisp jargon) for the given keyword, and returns the associated
value. It is the facility that is used by @racket[lambda/kw] to
search for keyword values.
The @racket[args] list is scanned from left to right, if the keyword
is found, then the next value is returned. If the @racket[kw] was not
found, then the @racket[not-found] thunk is used to produce a value by
applying it. If the @racket[kw] was not found, and @racket[not-found]
thunk is not given, @racket[#f] is returned. (No exception is raised
if the @racket[args] list is imbalanced, and the search stops at a
non-keyword value.)}
@close-eval[kw-eval]

77
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/list.scrbl
View File

@ -1,77 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/list))
@mzlib[#:mode title list]
@deprecated[@racketmodname[racket/list]]{}
The @racketmodname[mzlib/list] library re-exports several functions
from @racketmodname[scheme/base] and @racketmodname[scheme/list]:
@racketblock[
cons?
empty?
empty
foldl
foldr
remv
remq
remove
remv*
remq*
remove*
findf
memf
assf
filter
sort
]
@deftogether[(
@defproc[(first [v pair?]) any/c]
@defproc[(second [v (and/c pair? ....)]) any/c]
@defproc[(third [v (and/c pair? ....)]) any/c]
@defproc[(fourth [v (and/c pair? ....)]) any/c]
@defproc[(fifth [v (and/c pair? ....)]) any/c]
@defproc[(sixth [v (and/c pair? ....)]) any/c]
@defproc[(seventh [v (and/c pair? ....)]) any/c]
@defproc[(eighth [v (and/c pair? ....)]) any/c]
)]{
Accesses the first, second, @|etc| elment of ``list'' @racket[v]. The
argument need not actually be a list; it is inspected only as far as
necessary to obtain an element (unlike the same-named functions from
@racketmodname[scheme/list], which do require the argument to be a
list).}
@defproc[(rest [v pair?]) any/c]{
The same as @racket[cdr].}
@defproc[(last-pair [v pair?]) pair?]{
Returns the last pair in @racket[v], raising an error if @racket[v] is
not a pair (but @racket[v] does not have to be a proper list).}
@defproc[(merge-sorted-lists [lst1 list?][lst2 lst?]
[less-than? (any/c any/c . -> . any/c)])
list?]{
Merges the two sorted input lists, creating a new sorted list. The
merged result is stable: equal items in both lists stay in the same
order, and these in @racket[lst1] precede @racket[lst2].}
@defproc[(mergesort [lst list?] [less-than? (any/c any/c . -> . any/c)])
list?]{
The same as @racket[sort].}
@defproc[(quicksort [lst list?] [less-than? (any/c any/c . -> . any/c)])
list?]{
The same as @racket[sort].}

49
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/match-grammar.rkt
View File

@ -1,49 +0,0 @@
#lang scheme/base
(require scribblings/reference/match-parse)
(provide match-grammar)
(define grammar "
pat ::= id @match anything, bind identifier
| _ @match anything
| literal @match literal
| 'datum @match equal% datum
| (lvp ...) @match sequence of lvps
| (lvp ... . pat) @match lvps consed onto a pat
| #(lvp ...) @match vector of pats
| #&pat @match boxed pat
| ($ struct-id pat ...) @match struct-id instance
| (AND pat ...) @match when all pats match
| (OR pat ...) @match when any pat match
| (NOT pat ...) @match when no pat match
| (= expr pat) @match (expr value) to pat
| (? pred-expr pat ...) @match if (expr value) and pats
| `qp @match quasipattern
literal ::= #t @match true
| #f @match false
| string @match equal% string
| number @match equal% number
| character @match equal% character
| bytes @match equal% byte string
| keyword @match equal% keyword
| regexp literal @match equal% regexp literal
| pregexp literal @match equal% pregexp literal
lvp ::= pat ooo @greedily match pat instances
| pat @match pat
ooo ::= *** @zero or more; *** is literal
| ___ @zero or more
| ..K @K or more
| __K @K or more
qp ::= literal @match literal
| id @match equal% symbol
| (qp ...) @match sequences of qps
| (qp ... . qp) @match sequence of qps consed onto a qp
| (qp ... qp ooo) @match qps consed onto a repeated qp
| #(qp ...) @match vector of qps
| #&qp @match boxed qp
| ,pat @match pat
| ,@pat @match pat, spliced
")
(define match-grammar
(parse-match-grammar grammar))

57
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/match.scrbl
View File

@ -1,57 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
"match-grammar.rkt"
(for-label mzlib/match))
@(begin
(define-syntax-rule (bind id)
(begin
(require racket/match)
(define id (racket match))))
(bind racket-match))
@mzlib[#:mode title match]
@deprecated[@racketmodname[racket/match]]{}
The @racketmodname[mzlib/match] library provides a @racket[match] form
similar to that of @racketmodname[racket/match], but with an different
(older and less extensible) syntax of patterns.
@defform/subs[(match val-expr clause ...)
([clause [pat expr ...+]
[pat (=> id) expr ...+]])]{
See @racket-match from @racketmodname[racket/match] for a description
of matching. The grammar of @racket[pat] for this @racket[match] is as
follows:
@|match-grammar|}
@; ------------------------------------------------------------
@deftogether[(
@defform[(define/match (head args) match*-clause ...)]
@defform[(match-lambda clause ...)]
@defform[(match-lambda* clause ...)]
@defform[(match-let ([pat expr] ...) body ...+)]
@defform[(match-let* ([pat expr] ...) body ...+)]
@defform[(match-letrec ([pat expr] ...) body ...+)]
@defform[(match-define pat expr)]
)]{
Analogous to the combined forms from @racket[racket/match].}
@; ------------------------------------------------------------
@deftogether[(
@defform*[((define-match-expander id proc-expr)
(define-match-expander id proc-expr proc-expr)
(define-match-expander id proc-expr proc-expr proc-expr))]
@defparam[match-equality-test comp-proc (any/c any/c . -> . any)]
)]{
Analogous to the form and parameter from @racket[racket/match]. The
@racket[define-match-expander] form, however, supports an extra
@racket[proc-expr] as the middle one: an expander for use with
@racket[match] from @racketmodname[mzlib/match].}

13
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/math.scrbl
View File

@ -1,13 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/math))
@mzlib[#:mode title math]
@deprecated[@racketmodname[racket/math]]{}
Re-exports @racketmodname[scheme/math], and also exports @racket[e].
@defthing[e real?]{
An approximation to Euler's constant: @number->string[(exp 1)].}

378
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/mzlib.scrbl
View File

@ -1,378 +0,0 @@
#lang scribble/doc
@(require "common.rkt")
@title{MzLib: Legacy Libraries}
The @filepath{mzlib} collection contains wrappers and libraries for
compatibility with older versions of Racket. In many ways, the
libraries of the @filepath{mzlib} collection go with the
@racketmodname[mzscheme] legacy language. Newer variants of many
libraries reside in the @filepath{scheme} collection.
@table-of-contents[]
@; ----------------------------------------------------------------------
@mzlib[a-signature]
@deprecated[@racketmodname[racket/signature]]{}
Like @racketmodname[scheme/signature] in @hash-lang[] form for
defining a single signature within a module, but based on
@racketmodname[mzscheme] instead of @racketmodname[scheme/base].
@; ----------------------------------------------------------------------
@mzlib[a-unit]
@deprecated[@racketmodname[racket/unit]]{}
Like @racketmodname[scheme/unit] in @hash-lang[] form for defining a
single unit within a module, but based on @racketmodname[mzscheme]
instead of @racketmodname[scheme/base].
@; ----------------------------------------------------------------------
@mzlib[async-channel]
@deprecated[@racketmodname[racket/async-channel]]{}
Re-exports @racketmodname[scheme/async-channel].
@; ----------------------------------------------------------------------
@include-section["awk.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[class]
@deprecated[@racketmodname[racket/class]]{}
Re-exports @racketmodname[scheme/class], except for the contract
constructors.
@; ----------------------------------------------------------------------
@mzlib[cm]
@deprecated[@racketmodname[compiler/cm]]{}
Re-exports @racketmodname[compiler/cm].
@; ----------------------------------------------------------------------
@mzlib[cm-accomplice]
@deprecated[@racketmodname[compiler/cm-accomplice]]{}
Re-exports @racketmodname[compiler/cm-accomplice].
@; ----------------------------------------------------------------------
@include-section["cmdline.scrbl"]
@; ----------------------------------------------------------------------
@include-section["cml.scrbl"]
@; ----------------------------------------------------------------------
@include-section["compat.scrbl"]
@; ----------------------------------------------------------------------
@include-section["compile.scrbl"]
@; ----------------------------------------------------------------------
@include-section["contract.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[control]
@deprecated[@racketmodname[racket/control]]{}
Re-exports @racketmodname[scheme/control].
@; ----------------------------------------------------------------------
@mzlib[date]
@deprecated[@racketmodname[racket/date]]{}
Re-exports @racketmodname[scheme/date].
@; ----------------------------------------------------------------------
@mzlib[deflate]
@deprecated[@racketmodname[file/gzip]]{}
Re-exports @racketmodname[file/gzip].
@; ----------------------------------------------------------------------
@mzlib[defmacro]
@deprecated[@racketmodname[compatibility/defmacro]]{}
Re-exports @racketmodname[compatibility/defmacro].
@; ----------------------------------------------------------------------
@include-section["etc.scrbl"]
@; ----------------------------------------------------------------------
@include-section["file.scrbl"]
@; ----------------------------------------------------------------------
@include-section["for.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[foreign]
@deprecated[@racketmodname[ffi/unsafe]]{}
Re-exports @racketmodname[scheme/foreign].
@; ----------------------------------------------------------------------
@include-section["include.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[inflate]
@deprecated[@racketmodname[file/gunzip]]{}
Re-exports @racketmodname[file/gunzip].
@; ----------------------------------------------------------------------
@include-section["integer-set.scrbl"]
@; ----------------------------------------------------------------------
@include-section["kw.scrbl"]
@; ----------------------------------------------------------------------
@include-section["list.scrbl"]
@; ----------------------------------------------------------------------
@include-section["match.scrbl"]
@; ----------------------------------------------------------------------
@include-section["math.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[md5]
@deprecated[@racketmodname[file/md5]]{}
Re-exports @racketmodname[file/md5].
@; ----------------------------------------------------------------------
@include-section["os.scrbl"]
@; ----------------------------------------------------------------------
@include-section["pconvert.scrbl"]
@; ----------------------------------------------------------------------
@include-section["pconvert-prop.scrbl"]
@; ----------------------------------------------------------------------
@include-section["plt-match.scrbl"]
@; ----------------------------------------------------------------------
@include-section["port.scrbl"]
@; ----------------------------------------------------------------------
@include-section["pregexp.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[pretty]
@deprecated[@racketmodname[racket/pretty]]{}
Re-exports @racketmodname[scheme/pretty].
@; ----------------------------------------------------------------------
@mzlib[process]
@deprecated[@racketmodname[racket/system]]{}
Re-exports @racketmodname[scheme/system].
@; ----------------------------------------------------------------------
@include-section["restart.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[runtime-path]
@deprecated[@racketmodname[racket/runtime-path]]{}
Re-exports @racketmodname[scheme/runtime-path].
@; ----------------------------------------------------------------------
@include-section["sandbox.scrbl"]
@; ----------------------------------------------------------------------
@include-section["sendevent.scrbl"]
@; ----------------------------------------------------------------------
@include-section["serialize.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[shared]
@deprecated[@racketmodname[racket/shared]]{}
Re-exports @racketmodname[scheme/shared].
@; ----------------------------------------------------------------------
@include-section["string.scrbl"]
@; ----------------------------------------------------------------------
@include-section["struct.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[stxparam]
@deprecated[@racketmodname[racket/stxparam]]{
Also see @racketmodname[racket/stxparam-exptime].
}
Re-exports @racketmodname[scheme/stxparam] and
@racketmodname[scheme/stxparam-exptime] (both at phase level 0).
@; ----------------------------------------------------------------------
@mzlib[surrogate]
@deprecated[@racketmodname[racket/surrogate]]{}
Re-exports @racketmodname[scheme/surrogate].
@; ----------------------------------------------------------------------
@mzlib[tar]
@deprecated[@racketmodname[file/tar]]{}
Re-exports @racketmodname[file/tar].
@; ----------------------------------------------------------------------
@include-section["thread.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[trace]
@deprecated[@racketmodname[racket/trace]]{}
Re-exports @racketmodname[racket/trace].
@; ----------------------------------------------------------------------
@include-section["traceld.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[trait]
@deprecated[@racketmodname[racket/trait]]{}
Re-exports @racketmodname[scheme/trait].
@; ----------------------------------------------------------------------
@include-section["transcr.scrbl"]
@; ----------------------------------------------------------------------
@include-section["unit.scrbl"]
@; ----------------------------------------------------------------------
@mzlib[unit-exptime]
@deprecated[@racketmodname[racket/unit-exptime]]{}
Re-exports @racketmodname[scheme/unit-exptime].
@; ----------------------------------------
@mzlib[unit200]
@deprecated[@racketmodname[racket/unit]]{}
The @racketmodname[mzlib/unit200] library provides an old
implementation of units. See archived version 360 documentation on the
@filepath{unit.ss} library of the @filepath{mzlib} collection for
information about this library.
@; ----------------------------------------
@mzlib[unitsig200]
@deprecated[@racketmodname[racket/unit]]{}
The @racketmodname[mzlib/unit200] library provides an old
implementation of units. See archived version 360 documentation on the
@filepath{unitsig.ss} library of the @filepath{mzlib} collection for
information about this library.
@; ----------------------------------------
@mzlib[zip]
@deprecated[@racketmodname[file/zip]]{}
Re-exports @racketmodname[file/zip].
@; ----------------------------------------------------------------------
@(bibliography
(bib-entry #:key "Shivers06"
#:title "Scsh Reference Manual"
#:author "Olin Shivers, Brian D. Carlstrom, Martin Gasbichler, and Mike Sperber"
#:date "2006")
(bib-entry #:key "Reppy99"
#:title @italic{Concurrent Programming in ML}
#:author "John H. Reppy"
#:date "1999")
)
@;------------------------------------------------------------------------
@index-section[]

30
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/os.scrbl
View File

@ -1,30 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/os))
@mzlib[#:mode title os]
@defproc[(gethostname) string?]{
Returns a string for the current machine's hostname (including its
domain).}
@defproc[(getpid) exact-integer?]{
Returns an integer identifying the current process within the
operating system.}
@defproc[(truncate-file [file path-string?][n-bytes exact-nonnegative-integer? 0])
void?]{
Truncates or extends the given @racket[file] so that it is
@racket[n-bytes] long. If the file does not exist, or if the process
does not have sufficient privilege to truncate the file, the
@racket[exn:fail] exception is raised.
The @racket[truncate-file] function is implemented in terms of
@racketmodname[racket/base]'s @racket[file-truncate].}

49
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/pconvert-prop.scrbl
View File

@ -1,49 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/pconvert
mzlib/pconvert-prop))
@mzlib[#:mode title pconvert-prop]
@deftogether[(
@defthing[prop:print-converter property?]
@defproc[(print-converter? [v any/c]) any]
@defproc[(print-converter-proc [v print-converter?]) (any/c (any/c . -> . any/c) . -> . any/c)]
)]{
The @racket[prop:print-converter] property can be given a procedure
value for a structure type. In that case, for constructor-style print
conversion via @racket[print-convert], instances of the structure are
converted by calling the procedure that is the property's value. The
procedure is called with the value to convert and a procedure to
recursively convert nested values. The result should be an
S-expression for the converted value.
The @racket[print-converter?] predicate recognizes instances of
structure types that have the @racket[prop:print-converter] property,
and @racket[print-converter-proc] extracts the property value.}
@deftogether[(
@defthing[prop:print-convert-constructor-name property?]
@defproc[(print-convert-named-constructor? [v any/c]) any]
@defproc[(print-convert-constructor-name [v print-convert-named-constructor?]) any]
)]{
The @racket[prop:print-convert-constructor-name] property can be given
a symbol value for a structure type. In that case, for
constructor-style print conversion via @racket[print-convert],
instances of the structure are shown using the symbol as the
constructor name.
The @racket[prop:print-converter] property takes precedence over
@racket[prop:print-convert-constructor-name]. If neither is attached
to a structure type, its instances are converted using a constructor
name that is @racketidfont{make-} prefixed onto the result of
@racket[object-name].
The @racket[print-convert-named-constructor?] predicate recognizes
instances of structure types that have the
@racket[prop:print-convert-constructor-name] property, and
@racket[print-convert-constructor-name] extracts the property value.}

263
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/pconvert.scrbl
View File

@ -1,263 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/pconvert
mzlib/pconvert-prop
racket/contract
racket/pretty))
@mzlib[#:mode title pconvert]
The @racketmodname[mzlib/pconvert] library defines routines for
printing Racket values as @racket[eval]uable S-expressions. Racket's
default printing mode also prints values as expressions (in contrast
to the Lisp and Racket tradition of printing @racket[read]able
S-expressions), but @racketmodname[mzlib/pconvert] is more
configurable and approximates expressions for a wider range of
values. For example, procedures print using @racketresultfont{lambda}
instead of @racketresultfont{#<procedure>}.
The @racket[print-convert] procedure does not print values; rather, it
converts a Racket value into another Racket value such that the new
value @racket[pretty-write]s as a Racket expression that evaluates to
the original value. For example, @racket[(pretty-write (print-convert
`(9 ,(box 5) #(6 7))))] prints the literal expression
@racketresult[(list 9 (box 5) (vector 6 7))] to the current output
port.
To install print converting into the read-eval-print loop, require
@racketmodname[mzlib/pconvert] and call the procedure
@racket[install-converting-printer].
In addition to @racket[print-convert], this library provides
@racket[print-convert], @racket[build-share], @racket[get-shared],
and @racket[print-convert-expr]. The last three are used to convert
sub-expressions of a larger expression (potentially with shared
structure).
See also @racket[prop:print-convert-constructor-name].
@defboolparam[abbreviate-cons-as-list abbreviate?]{
A parameter that controls how lists are represented with
constructor-style conversion. If the parameter's value is @racket[#t],
lists are represented using @racket[list]. Otherwise, lists are
represented using @racket[cons]. The initial value of the parameter is
@racket[#t].}
@defboolparam[booleans-as-true/false use-name?]{
A parameter that controls how @racket[#t] and @racket[#f] are
represented. If the parameter's value is @racket[#t], then @racket[#t]
is represented as @racket[true] and @racket[#f] is represented as
@racket[false]. The initial value of the parameter is @racket[#t].}
@defparam[use-named/undefined-handler use-handler (any/c . -> . any/c)]{
A parameter that controls how values that have inferred names are
represented. The procedure is passed a value. If the procedure returns
true, the procedure associated with @racket[named/undefined-handler]
is invoked to render that value. Only values that have inferred names
but are not defined at the top-level are used with this handler.
The initial value of the parameter is @racket[(lambda (x) #f)].}
@defparam[named/undefined-handler use-handler (any/c . -> . any/c)]{
Parameter for a procedure that controls how values that have inferred
names are represented. The procedure is called only if
@racket[use-named/undefined-handler] returns true for some value. In
that case, the procedure is passed that same value, and the result of
the parameter is used as the representation for the value.
The initial value of the parameter is @racket[(lambda (x) #f)].}
@defboolparam[add-make-prefix-to-constructor add-prefix?]{
A parameter that controls whether a @racketidfont{make-} prefix is
added to a constructor name for a structure instance. The initial
value of the parameter is @racket[#f].}
@defproc[(build-share [v any/c]) ....]{
Takes a value and computes sharing information used for representing
the value as an expression. The return value is an opaque structure
that can be passed back into @racket[get-shared] or
@racket[print-convert-expr].}
@defboolparam[constructor-style-printing use-constructors?]{
Parameter that controls how values are represented after conversion.
If this parameter's value is @racket[#t], then constructors are used;
e.g., pair containing @racket[1] and @racket[2] is represented as
@racket[(cons 1 2)]. Otherwise, @racket[quasiquote]-style syntax is
used; e.g., the pair containing @racket[1] and @racket[2] is
represented as @racket[`(1 . 2)]. The initial value of the parameter
is @racket[#f].
The constructor used for mutable pairs is @racketidfont{mcons}, unless
@racket[print-mpair-curly-braces] is set to @racket[#f], in which case
@racketidfont{cons} and @racketidfont{list} are used. Similarly, when
using @racket[quasiquote] style and @racket[print-mpair-curly-braces]
is set to @racket[#f], mutable pair constructions are represented
using @racketidfont{quote}, @racketidfont{quasiquote}, etc.
See also @racket[quasi-read-style-printing] and
@racket[prop:print-convert-constructor-name].}
@defparam[current-build-share-hook
hook
(any/c (any/c . -> . void?)
(any/c . -> . void?) . -> . any)]{
Parameter that sets a procedure used by @racket[print-convert] and
@racket[build-share] to assemble sharing information. The procedure
@racket[hook] takes three arguments: a value @racket[_v], a procedure
@racket[_basic-share], and a procedure @racket[_sub-share]; the return
value is ignored. The @racket[basic-share] procedure takes @racket[_v]
and performs the built-in sharing analysis, while the
@racket[_sub-share] procedure takes a component of @racket[_v] ands
analyzes it. Sharing information is accumulated as values are passed
to @racket[basic-share] and @racket[sub-share].
A @racket[current-build-share-hook] procedure usually works together
with a @racket[current-print-convert-hook] procedure.}
@defparam[current-build-share-name-hook hook (any/c . -> . (or/c symbol? false/c))]{
Parameter that sets a procedure used by @racket[print-convert] and
@racket[build-share] to generate a new name for a shared value. The
@racket[hook] procedure takes a single value and returns a symbol for
the value's name. If @racket[hook] returns @racket[#f], a name is
generated using the form
``@racketidfont{-}@racket[_n]@racketidfont{-}, where @racket[n] is an
integer.}
@defparam[current-print-convert-hook
hook
(any/c (any/c . -> . any/c)
(any/c . -> . any/c)
. -> . any/c)]{
Parameter that sets a procedure used by @racket[print-convert] and
@racket[print-convert-expr] to convert values. The procedure
@racket[hook] takes three arguments---a value @racket[_v], a procedure
@racket[_basic-convert], and a procedure @racket[_sub-convert]---and
returns the converted representation of @racket[_v]. The
@racket[_basic-convert] procedure takes @racket[_v] and returns the
default conversion, while the @racket[_sub-convert] procedure takes a
component of @racket[_v] and returns its conversion.
A @racket[current-print-convert-hook] procedure usually works together
with a @racket[current-build-share-hook] procedure.}
@defparam[current-read-eval-convert-print-prompt str string?]{
Parameter that sets the prompt used by
@racket[install-converting-printer].
The initial value is @racket["|- "].}
@defproc[(get-shared [share-info ....]
[cycles-only? any/c #f])
(list-of (cons/c symbol? any/c))]{
The @racket[shared-info] value must be a result from @racket[build-share].
The procedure returns a list matching variables to shared values
within the value passed to @racket[build-share].
The default value for @racket[cycles-only?] is @racket[#f];
if it is not @racket[#f], @racket[get-shared] returns only information
about cycles.
For example,
@racketblock[
(get-shared (build-share (shared ([a (cons 1 b)]
[b (cons 2 a)])
a)))
]
might return the list
@racketblock[
'((-1- (cons 1 -2-)) (-2- (cons 2 -1-)))
]}
@defproc[(install-converting-printer) void?]{
Sets the current print handler to print values using
@racket[print-convert] and sets @racket[print-as-expression] to
@racket[#f] (since the conversion of a value is meant to be printed in
@racket[read]able form rather than @racket[eval]uable form). The
current read handler is also set to use the prompt returned by
@racket[current-read-eval-convert-print-prompt].}
@defproc[(print-convert [v any/c][cycles-only? any/c (show-sharing)]) any/c]{
Converts the value @racket[v]. If @racket[cycles-only?] is not
@racket[#f], then only circular objects are included in the
output.}
@defproc[(print-convert-expr [share-info ....]
[v any/c]
[unroll-once? any/c]) any/c]{
Converts the value @racket[v] using sharing information
@racket[share-info], which was previously returned by
@racket[build-share] for a value containing @racket[v]. If the most
recent call to @racket[get-shared] with @racket[share-info] requested
information only for cycles, then @racket[print-convert-expr] will
only display sharing among values for cycles, rather than showing all
value sharing.
The @racket[unroll-once?] argument is used if @racket[v] is a shared
value in @racket[share-info]. In this case, if @racket[unroll-once?]
is @racket[#f], then the return value will be a shared-value
identifier; otherwise, the returned value shows the internal structure
of @racket[v] (using shared value identifiers within @racket[v]'s
immediate structure as appropriate).}
@defboolparam[quasi-read-style-printing on?]{
Parameter that controls how vectors and boxes are represented after
conversion when the value of @racket[constructor-style-printing] is
@racket[#f]. If @racket[quasi-read-style-printing] is set to
@racket[#f], then boxes and vectors are unquoted and represented using
constructors. For example, the list of a box containing the number 1
and a vector containing the number 1 is represented as @racketresult[`(,(box
1) ,(vector 1))]. If the parameter's value is @racket[#t], then
@racket[#&....] and @racket[#(....)] are used, e.g., @racket[`(#&1
#(1))]. The initial value of the parameter is @racket[#t].}
@defboolparam[show-sharing show?]{
Parameter that determines whether sub-value sharing is conserved (and
shown) in the converted output by default. The initial value of the
parameter is @racket[#t].}
@defboolparam[whole/fractional-exact-numbers whole-frac?]{
Parameter that controls how exact, non-integer numbers are converted
when the numerator is greater than the denominator. If the parameter's
value is @racket[#t], the number is converted to the form @racket[(+
_integer _fraction)] (i.e., a list containing @racket['+], an exact
integer, and an exact rational less than @racket[1] and greater than
@racket[-1]). The initial value of the parameter is @racket[#f].}

18
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/plt-match.scrbl
View File

@ -1,18 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/plt-match))
@mzlib[#:mode title plt-match]
@deprecated[@racketmodname[racket/match]]{}
The @racketmodname[mzlib/plt-match] library mostly re-provides
@racket[scheme/match].
@deftogether[(
@defform*[((define-match-expander id proc-expr)
(define-match-expander id proc-expr proc-expr)
(define-match-expander id proc-expr proc-expr proc-expr))]
)]{
The same as the form from @racketmodname[mzlib/match].}

18
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/port.scrbl
View File

@ -1,18 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/port))
@mzlib[#:mode title port]
@deprecated[@racketmodname[racket/port]]{}
The @racketmodname[mzlib/port] library mostly re-provides
@racketmodname[racket/port].
@defproc[(strip-shell-command-start [in input-port?]) void?]{
Reads and discards a leading @litchar{#!} in @racket[in] (plus
continuing lines if the line ends with a backslash). Since
@litchar{#!} followed by a forward slash or space is a comment, this
procedure is not needed before reading Scheme expressions.}

58
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/pregexp.scrbl
View File

@ -1,58 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/pregexp
(only-in scheme/base regexp-quote)))
@mzlib[#:mode title pregexp]
@deprecated[@racketmodname[racket/base]]{}
The @racketmodname[mzlib/pregexp] library provides wrappers around
@racket[regexp-match], @|etc| that coerce string and byte-string
arguments to @racket[pregexp] matchers instead of @racket[regexp]
matchers.
The library also re-exports: @racket[pregexp], and it re-exports
@racket[regexp-quote] as @racket[pregexp-quote].
@deftogether[(
@defproc[(pregexp-match [pattern (or/c string? bytes? regexp? byte-regexp?)]
[input (or/c string? bytes? input-port?)]
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? false/c) #f]
[output-port (or/c output-port? false/c) #f])
(or/c (listof (or/c (cons (or/c string? bytes?)
(or/c string? bytes?))
false/c))
false/c)]
@defproc[(pregexp-match-positions [pattern (or/c string? bytes? regexp? byte-regexp?)]
[input (or/c string? bytes? input-port?)]
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? false/c) #f]
[output-port (or/c output-port? false/c) #f])
(or/c (listof (or/c (cons exact-nonnegative-integer?
exact-nonnegative-integer?)
false/c))
false/c)]
@defproc[(pregexp-split [pattern (or/c string? bytes? regexp? byte-regexp?)]
[input (or/c string? bytes? input-port?)]
[start-pos exact-nonnegative-integer? 0]
[end-pos (or/c exact-nonnegative-integer? false/c) #f])
(listof (or/c string? bytes?))]
@defproc[(pregexp-replace [pattern (or/c string? bytes? regexp? byte-regexp?)]
[input (or/c string? bytes?)]
[insert (or/c string? bytes?
(string? . -> . string?)
(bytes? . -> . bytes?))])
(or/c string? bytes?)]
@defproc[(pregexp-replace* [pattern (or/c string? bytes? regexp? byte-regexp?)]
[input (or/c string? bytes?)]
[insert (or/c string? bytes?
(string? . -> . string?)
(bytes? . -> . bytes?))])
(or/c string? bytes?)]
)]{
Like @racket[regexp-match], @|etc|, but a string @racket[pattern]
argument is compiled via @racket[pregexp], and a byte string
@racket[pattern] argument is compiled via @racket[byte-pregexp].}

69
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/restart.scrbl
View File

@ -1,69 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/restart
mzlib/cmdline))
@mzlib[#:mode title restart]
@deprecated[@racketmodname[racket/sandbox]]{
The @racket[racket/sandbox] library provides a more general way to
simulate running a new Racket process.
}
@defproc[(restart-mzscheme [init-argv (vectorof string?)]
[adjust-flag-table (any/c . -> . any/c)]
[argv (vectorof string?)]
[init-namespace (-> any)])
boolean?]{
Simulates starting Racket with the vector of command-line strings
@racket[argv]. The @racket[init-argv], @racket[adjust-flag-table], and
@racket[init-namespace] arguments are used to modify the default
settings for command-line flags, adjust the parsing of command-line
flags, and customize the initial namespace, respectively.
The vector of strings @racket[init-argv] is read first with the
standard Racket command-line parsing. Flags that load files or
evaluate expressions (e.g., @Flag{f} and @Flag{e}) are ignored, but
flags that set Racket's modes (e.g., @Flag{c} or @Flag{j})
effectively set the default mode before @racket[argv] is parsed.
Before @racket[argv] is parsed, the procedure
@racket[adjust-flag-table] is called with a command-line flag table as
accepted by @racket[parse-command-line]. The return value must also be
a table of command-line flags, and this table is used to parse
@racket[argv]. The intent is to allow @racket[adjust-flag-table] to
add or remove flags from the standard set.
After @racket[argv] is parsed, a new thread and a namespace are
created for the ``restarted'' Racket. (The new namespace is
installed as the current namespace in the new thread.) In the new
thread, restarting performs the following actions:
@itemize[
@item{The @racket[init-namespace] procedure is called with no
arguments. The return value is ignored.}
@item{Expressions and files specified by @racket[argv] are evaluated
and loaded. If an error occurs, the remaining expressions and
files are ignored, and the return value for
@racket[restart-mzscheme] is set to @racket[#f].}
@item{The @racket[read-eval-print-loop] procedure is called, unless a
flag in @racket[init-argv] or @racket[argv] disables it. When
@racket[read-eval-print-loop] returns, the return value for
@racket[restart-mzscheme] is set to @racket[#t].}
]
Before evaluating command-line arguments, an exit handler is installed
that immediately returns from @racket[restart-mzscheme] with the value
supplied to the handler. This exit handler remains in effect when
@racket[read-eval-print-loop] is called (unless a command-line
argument changes it). If @racket[restart-mzscheme] returns normally,
the return value is determined as described above.
Note that an error in a command-line expression followed by
@racket[read-eval-print-loop] produces a @racket[#t] result. This is
consistent with Racket's stand-alone behavior.}

84
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/sandbox.scrbl
View File

@ -1,84 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/sandbox
(only-in racket/sandbox make-module-evaluator)))
@(begin
(define-syntax-rule (bind id)
(begin
(require (for-label racket/sandbox))
(define id (racket make-evaluator))))
(bind racket-make-evaluator))
@mzlib[#:mode title sandbox]
@deprecated[@racketmodname[racket/sandbox]]{}
The @racketmodname[mzlib/sandbox] library mostly re-exports
@racketmodname[racket/sandbox], but it provides a slightly different
@racket[make-evaluator] function.
The library re-exports the following bindings:
@racketblock[
sandbox-init-hook
sandbox-reader
sandbox-input
sandbox-output
sandbox-error-output
sandbox-propagate-breaks
sandbox-coverage-enabled
sandbox-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-network-guard
sandbox-make-inspector
sandbox-eval-limits
kill-evaluator
break-evaluator
set-eval-limits
put-input
get-output
get-error-output
get-uncovered-expressions
call-with-limits
with-limits
exn:fail:resource?
exn:fail:resource-resource
]
@defproc*[([(make-evaluator [language (or/c module-path?
(one-of/c 'r5rs 'beginner 'beginner-abbr
'intermediate 'intermediate-lambda 'advanced)
(list/c (one-of/c 'special) symbol?)
(list/c (one-of/c 'special) symbol?)
(cons/c (one-of/c 'begin) list?))]
[requires (or/c (cons/c 'begin list?)
(listof (or/c module-path? path?)))]
[input-program any/c] ...)
(any/c . -> . any)]
[(make-evaluator [module-decl (or/c syntax? pair?)])
(any/c . -> . any)])]{
Like @racket-make-evaluator or @racket[make-module-evaluator], but
with several differences:
@itemize[
@item{The @racket[language] argument can be one of a fixed set of
symbols: @racket['r5rs], etc. They are converted by adding a
@racket[(list 'special ....)] wrapper.}
@item{If @racket[requires] starts with @racket['begin], then each
element in the remainder of the list is effectively evaluated
as a prefix to the program. Otherwise, it corresponds to the
@racket[#:requires] argument of @|racket-make-evaluator|.}
@item{For each of @racket[language] and @racket[requires] that starts
with @racket['begin], the expressions are inspected to find
top-level @racket[require] forms (using symbolic equality to
detect @racket[require]), and the @racket[require]d modules are
added to the @racket[#:allow] list for @|racket-make-evaluator|.}
]}

29
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/sendevent.scrbl
View File

@ -1,29 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/sendevent))
@(begin
(define-syntax-rule (bind id)
(begin
(require (for-label scheme/gui/base))
(define id (racket send-event))))
(bind mred-send-event))
@mzlib[#:mode title sendevent]
The @racketmodname[mzlib/sendevent] library provides a
@racket[send-event] function that works only on Mac OS X, and only
when running in GRacket (though the library can be loaded in Racket).
@defproc[(send-event [receiver-bytes (lambda (s) (and (bytes? s)
(= 4 (bytes-length s))))]
[event-class-bytes (lambda (s) (and (bytes? s)
(= 4 (bytes-length s))))]
[event-id-bytes (lambda (s) (and (bytes? s)
(= 4 (bytes-length s))))]
[direct-arg-v any/c (void)]
[argument-list list? null])
any/c]{
Calls @|mred-send-event| @racketmodname[scheme/gui/base], if
available, otherwise raises @racket[exn:fail:unsupported].}

39
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/serialize.scrbl
View File

@ -1,39 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/serialize))
@(begin
(define-syntax-rule (bind id id2)
(begin
(require (for-label racket/serialize))
(define id (racket define-serializable-struct))
(define id2 (racket define-serializable-struct/versions))))
(bind racket-define-serializable-struct
racket-define-serializable-struct/versions))
@mzlib[#:mode title serialize]
@deprecated[@racketmodname[racket/serialize]]{}
The @racketmodname[mzlib/serialize] library provides the same bindings
as @racketmodname[racket/serialize], except that
@racket[define-serializable-struct] and
@racket[define-serializable-struct/versions] are based on the syntax
of @racket[define-struct] from @racketmodname[mzscheme].
@deftogether[(
@defform[(define-serializable-struct id-maybe-super (field-id ...) maybe-inspector-expr)]
@defform/subs[(define-serializable-struct/versions id-maybe-super vers-num (field-id ...)
(other-version-clause ...)
maybe-inspector-expr)
([id-maybe-super id
(id super-id)]
[maybe-inspector-expr code:blank
inspector-expr]
[other-version-clause (other-vers make-proc-expr
cycle-make-proc-expr)])]
)]{
Like @racket-define-serializable-struct and
@racket-define-serializable-struct/versions, but with the syntax of
closer to @racket[define-struct] of @racketmodname[mzscheme].}

118
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/string.scrbl
View File

@ -1,118 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/string
scheme/contract
(only-in scheme/base
regexp-try-match)))
@mzlib[#:mode title string]
@deprecated[@racketmodname[racket/base]]{
Also see @racketmodname[racket/string]
}
The @racketmodname[mzlib/string] library re-exports several functions
from @racketmodname[scheme/base]:
@racketblock[
real->decimal-string
regexp-quote
regexp-replace-quote
regexp-match*
regexp-match-positions*
regexp-match-peek-positions*
regexp-split
regexp-match-exact?
]
It also re-exports @racket[regexp-try-match] as
@racket[regexp-match/fail-without-reading].
@defproc[(glob->regexp [str (or/c string bytes?)?]
[hide-dots? any/c #t]
[case-sensitive? any/c (eq? (system-path-convention-type)'unix)]
[simple? any/c #f])
(or/c regexp? byte-regexp?)]{
Produces a regexp for a an input ``glob pattern'' @racket[str]. A
glob pattern is one that matches @litchar{*} with any string,
@litchar{?} with a single character, and character ranges are the same
as in regexps (unless @racket[simple?] is true). In addition, the
resulting regexp does not match strings that begin with @litchar{.},
unless @racket[str] begins with @litchar{.} or @racket[hide-dots?] is
@racket[#f]. The resulting regexp can be used with string file names
to check the glob pattern. If the glob pattern is provided as a byte
string, the result is a byte regexp.
The @racket[case-sensitive?] argument determines whether the resulting
regexp is case-sensitive.
If @racket[simple?] is true, then ranges with
@litchar{[}...@litchar{]} in @racket[str] are treated as literal
character sequences.}
@defproc[(string-lowercase! [str (and/c string? (not/c immutable?))]) void?]{
Destructively changes @racket[str] to contain only lowercase
characters.}
@defproc[(string-uppercase! [str (and/c string? (not/c immutable?))]) void?]{
Destructively changes @racket[str] to contain only uppercase
characters.}
@defproc[(eval-string [str (or/c string? bytes?)]
[err-handler (or/c false/c
(any/c . -> . any/c)
(-> any/c))
#f])
list?]{
Reads and evaluates S-expressions from @racket[str], returning results
for all of the expressions in the string. If any expression produces
multiple results, the results are spliced into the resulting list. If
@racket[str] contains only whitespace and comments, an empty list is
returned, and if @racket[str] contains multiple expressions, the
result will be contain multiple values from all subexpressions.
The @racket[err-handler] argument can be:
@itemize[
@item{@racket[#f] (the default) which means that errors are not
caught;}
@item{a one-argument procedure, which will be used with an exception
(when an error occurs) and its result will be returned}
@item{a thunk, which will be used to produce a result.}
]}
@defproc[(expr->string [expr any/c]) string?]{
Prints @racket[expr] into a string and returns the string.}
@defproc[(read-from-string [str (or/c string? bytes?)]
[err-handler (or/c false/c
(any/c . -> . any/c)
(-> any/c))
#f])
any/c]{
Reads the first S-expression from @racket[str] and returns it. The
@racket[err-handler] is as in @racket[eval-string].}
@defproc[(read-from-string-all [str (or/c string? bytes?)]
[err-handler (or/c false/c
(any/c . -> . any/c)
(-> any/c))
#f])
list?]{
Reads all S-expressions from the string (or byte string) @racket[str]
and returns them in a list. The @racket[err-handler] is as in
@racket[eval-string].}

70
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/struct.scrbl
View File

@ -1,70 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
scribble/eval
(for-label mzlib/struct
scheme/contract
(only-in scheme/base
regexp-try-match)))
@(define struct-eval (make-base-eval))
@interaction-eval[#:eval struct-eval (require mzscheme)]
@interaction-eval[#:eval struct-eval (require mzlib/struct)]
@mzlib[#:mode title struct]
@defform[(copy-struct struct-id struct-expr
(accessor-id field-expr) ...)]{
``Functional update'' for structure instances. The result of
evaluating @racket[struct-expr] must be an instance of the structure
type named by @racket[struct-id]. The result of the
@racket[copy-struct] expression is a fresh instance of
@racket[struct-id] with the same field values as the result of
@racket[struct-expr], except that the value for the field accessed by
each @racket[accessor-id] is replaced by the result of
@racket[field-expr].
The result of @racket[struct-expr] might be an instance of a sub-type
of @racket[struct-id], but the result of the @racket[copy-struct]
expression is an immediate instance of @racket[struct-id]. If
@racket[struct-expr] does not produce an instance of
@racket[struct-id], the @racket[exn:fail:contract] exception is
raised.
If any @racket[accessor-id] is not bound to an accessor of
@racket[struct-id] (according to the expansion-time information
associated with @racket[struct-id]), or if the same
@racket[accessor-id] is used twice, then a syntax error is raised.}
@defform/subs[(define-struct/properties id (field-id ...)
((prop-expr val-expr) ...)
maybe-inspector-expr)
([maybe-inspector-expr code:blank
expr])]{
Like @racket[define-struct] from @racketmodname[mzscheme], but
properties can be attached to the structure type. Each
@racket[prop-expr] should produce a structure-type property value, and
each @racket[val-expr] produces the corresponding value for the
property.
@examples[
#:eval struct-eval
(define-struct/properties point (x y)
([prop:custom-write (lambda (p port write?)
(fprintf port "(~a, ~a)"
(point-x p)
(point-y p)))]))
(display (make-point 1 2))
]}
@defform[(make-->vector struct-id)]{
Builds a function that accepts a structure type instance (matching
@racket[struct-id]) and provides a vector of the fields of the
structure type instance.}
@close-eval[struct-eval]

99
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/thread.scrbl
View File

@ -1,99 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/thread
racket/engine
scheme/contract
scheme/tcp))
@mzlib[#:mode title thread]
@deprecated[@racketmodname[racket/engine]]{}
Re-exports the bindings from @racketmodname[racket/engine] under
different names and also provides two extra bindings. The renamings
are:
@itemlist[
@item{@racket[engine] as @racket[coroutine]}
@item{@racket[engine?] as @racket[coroutine?]}
@item{@racket[engine-run] as @racket[coroutine-run]}
@item{@racket[engine-result] as @racket[coroutine-result]}
@item{@racket[engine-kill] as @racket[coroutine-kill]}
]
@defproc[(consumer-thread [f procedure?][init (-> any) void])
(values thread? procedure?)]{
Returns two values: a thread descriptor for a new thread, and a
procedure with the same arity as @racket[f].
When the returned procedure is applied, its arguments are queued to be
passed on to @racket[f], and @|void-const| is immediately returned.
The thread created by @racket[consumer-thread] dequeues arguments and
applies @racket[f] to them, removing a new set of arguments from the
queue only when the previous application of @racket[f] has completed;
if @racket[f] escapes from a normal return (via an exception or a
continuation), the @racket[f]-applying thread terminates.
The @racket[init] argument is a procedure of no arguments; if it is
provided, @racket[init] is called in the new thread immediately after the
thread is created.}
@defproc[(run-server [port-no (integer-in 1 65535)]
[conn-proc (input-port? output-port? . -> . any)]
[conn-timeout (and/c real? (not/c negative?))]
[handler (exn? . -> . any/c) void]
[listen ((integer-in 1 65535) (one-of/c 5) (one-of/c #t)
. -> . listener?)
tcp-listen]
[close (listener? . -> . any) tcp-close]
[accept (listener? . ->* . (input-port? output-port?)) tcp-accept]
[accept/break (listener? . ->* . (input-port? output-port?)) tcp-accept/enable-break])
void?]{
Executes a TCP server on the port indicated by @racket[port-no]. When
a connection is made by a client, @racket[conn] is called with two
values: an input port to receive from the client, and an output port
to send to the client.
Each client connection is managed by a new custodian, and each call to
@racket[conn] occurs in a new thread (managed by the connection's
custodian). If the thread executing @racket[conn] terminates for any
reason (e.g., @racket[conn] returns), the connection's custodian is
shut down. Consequently, @racket[conn] need not close the ports
provided to it. Breaks are enabled in the connection thread if breaks
are enabled when @racket[run-server] is called.
To facilitate capturing a continuation in one connection thread and
invoking it in another, the parameterization of the
@racket[run-server] call is used for every call to
@racket[handler]. In this parameterization and for the connection's
thread, the @racket[current-custodian] parameter is assigned to the
connection's custodian.
If @racket[conn-timeout] is not @racket[#f], then it must be a
non-negative number specifying the time in seconds that a connection
thread is allowed to run before it is sent a break signal. Then, if
the thread runs longer than @racket[(* conn-timeout 2)] seconds, then
the connection's custodian is shut down. If @racket[conn-timeout] is
@racket[#f], a connection thread can run indefinitely.
If @racket[handler] is provided, it is passed exceptions related
to connections (i.e., exceptions not caught by @racket[conn-proc], or
exceptions that occur when trying to accept a connection). The default
handler ignores the exception and returns @|void-const|.
The @racket[run-server] function uses @racket[listen], @racket[close],
@racket[accept] and @racket[accept/break] in the same way as it might
use @racket[tcp-listen], @racket[tcp-close], @racket[tcp-accept], and
@racket[tcp-accept/enable-break] to accept connections. Provide
alternate procedures to use an alternate communication protocol (such
as SSL) or to supply optional arguments in the use of
@racket[tcp-listen]. The @racket[listener?] part of the contract
indicates that the procedures must all work on the same kind of
listener value.
The @racket[run-server] procedure loops to serve client connections,
so it never returns. If a break occurs, the loop will cleanly shut
down the server, but it will not terminate active connections.}

22
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/traceld.scrbl
View File

@ -1,22 +0,0 @@
#lang scribble/doc
@(require "common.rkt")
@mzlib[#:mode title traceld]
The @racketmodname[mzlib/traceld] library does not provide any
bindings. Instead, @racketmodname[mzlib/traceld] is @racket[require]d
for its side-effects.
The @racketmodname[mzlib/traceld] library installs a new load handler
(see @racket[current-load]) and load-extension handler (see
@racket[current-load-extension]) to print information about the files
that are loaded. These handlers chain to the current handlers to
perform the actual loads. Trace output is printed to the port that is
the current error port (see @racket[current-error-port]) when the
library is instantiated.
Before a file is loaded, the tracer prints the file name and ``time''
(as reported by the procedure @racket[current-process-milliseconds])
when the load starts. Trace information for nested loads is printed
with indentation. After the file is loaded, the file name is printed
with the ``time'' that the load completed.

22
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/transcr.scrbl
View File

@ -1,22 +0,0 @@
#lang scribble/doc
@(require "common.rkt")
@mzlib[#:mode title transcr]
The @racket[transcript-on] and @racket[transcript-off] procedures of
@racketmodname[mzscheme] always raise
@racket[exn:fail:unsupported]. The @racketmodname[mzlib/transcr]
library provides working versions of @racket[transcript-on] and
@racket[transcript-off].
@(define-syntax-rule (go)
(begin
(require (for-label mzlib/transcr))
@deftogether[(
@defproc[(transcript-on [filename any/c]) any]
@defproc[(transcript-off) any]
)]{
Starts/stops recording a transcript at @racket[filename].}))
@(go)

57
pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/unit.scrbl
View File

@ -1,57 +0,0 @@
#lang scribble/doc
@(require "common.rkt"
(for-label mzlib/unit))
@(begin
(define-syntax-rule (bind id)
(begin
(require (for-label racket/base))
(define id (racket struct))))
(bind racket-struct)
(define-syntax-rule (bindc id)
(begin
(require (for-label racket/unit))
(define id (racket struct/ctc))))
(bindc racket-struct/ctc))
@mzlib[#:mode title unit #:use-sources ((submod racket/unit compat))]
@deprecated[@racketmodname[racket/unit]]{}
The @racketmodname[mzlib/unit] library mostly re-provides
@racketmodname[racket/unit], except for @racket-struct and
@racket-struct/ctc from @racketmodname[racket/unit].
@defform/subs[(struct id (field-id ...) omit-decl ...)
([omit-decl -type
-selectors
-setters
-constructor])]{
A signature form like @racket-struct from @racketmodname[racket/base],
but with a different syntax for options that limit exports.}
@defform/subs[(struct/ctc id ([field-id contract-expr] ...) omit-decl ...)
([omit-decl -type
-selectors
-setters
-constructor])]{
A signature form like @racket-struct/ctc from @racketmodname[racket/unit],
but with a different syntax for the options that limit exports.}
@deftogether[(
@defidform[struct~r]
@defidform[struct~r/ctc]
)]{
The same as @|racket-struct| from @racketmodname[racket/base] and @|racket-struct/ctc| from
@racketmodname[racket/unit].}
@deftogether[(
@defidform[struct~s]
@defidform[struct~s/ctc]
)]{
Like @racket[struct~r] and @racket[struct~r/ctc], but the constructor is
named the same as the type, instead of with @racketidfont{make-} prefix.}

11
pkgs/compatibility-pkgs/compatibility-lib/LICENSE.txt
View File

@ -1,11 +0,0 @@
compatibility-lib
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

136
pkgs/compatibility-pkgs/compatibility-lib/compatibility/defmacro.rkt
View File

@ -1,136 +0,0 @@
#lang racket/base
;; defmacro - for legacy macros only
(require (for-syntax racket/base syntax/stx))
(provide define-macro
defmacro)
(define-syntax define-macro
(lambda (stx)
(syntax-case stx ()
[(_ (name . args) proc0 proc ...)
(begin
(unless (identifier? (syntax name))
(raise-syntax-error
#f
"expected an identifier for the macro name"
stx
(syntax name)))
(let loop ([args (syntax args)])
(cond
[(stx-null? args) 'ok]
[(identifier? args) 'ok]
[(stx-pair? args)
(unless (identifier? (stx-car args))
(raise-syntax-error
#f
"expected an identifier for a macro argument"
stx
(stx-car args)))
(loop (stx-cdr args))]
[else (raise-syntax-error
#f
"not a valid argument sequence after the macro name"
stx)]))
(syntax
(define-macro name (lambda args proc0 proc ...))))]
[(_ name proc)
(begin
(unless (identifier? (syntax name))
(raise-syntax-error
#f
"expected an identifier for the macro name"
stx
(syntax name)))
(syntax
(define-syntax name
(let ([p proc])
(unless (procedure? p)
(raise-type-error
'define-macro
"procedure (arity 1)"
p))
(lambda (stx)
(let ([l (syntax->list stx)])
(unless (and l (procedure-arity-includes? p (sub1 (length l))))
(raise-syntax-error
#f
"bad form"
stx))
(let ([ht (make-hash)])
(datum->syntax
stx
(dm-subst
ht
(apply p (cdr (dm-syntax->datum stx ht))))
stx))))))))])))
(define-syntax defmacro
(syntax-rules ()
[(_ name formals body1 body ...)
(define-macro (name . formals) body1 body ...)]))
;; helper submodule
;;
;; defined as a submodule because swindle requires it
(module dmhelp racket/base
(require syntax/stx)
(provide dm-syntax->datum
dm-subst)
;; `dm-syntax->datum' is like syntax-object->datum, but it also
;; builds a hash table that maps generated data to original syntax
;; objects. The hash table can then be used with `dm-subst' to
;; replace each re-used, unmodified datum with the original syntax
;; object.
(define (dm-syntax->datum stx ht)
;; Easiest to handle cycles by letting `syntax-object->datum'
;; do all the work.
(let ([v (syntax->datum stx)])
(let loop ([stx stx][v v])
(let ([already (hash-ref ht v (lambda () #f))])
(if already
(hash-set! ht v #t) ;; not stx => don't subst later
(hash-set! ht v stx))
(cond
[(stx-pair? stx)
(loop (stx-car stx) (car v))
(loop (stx-cdr stx) (cdr v))]
[(stx-null? stx) null]
[(vector? (syntax-e stx))
(for-each
loop
(vector->list
(syntax-e stx))
(vector->list v))]
[(box? (syntax-e stx))
(loop (unbox (syntax-e stx))
(unbox v))]
[else (void)])))
v))
(define (dm-subst ht v)
(define cycle-ht (make-hash))
(let loop ([v v])
(if (hash-ref cycle-ht v (lambda () #f))
v
(begin
(hash-set! cycle-ht v #t)
(let ([m (hash-ref ht v (lambda () #f))])
(cond
[(syntax? m) m] ;; subst back!
[(pair? v) (cons (loop (car v))
(loop (cdr v)))]
[(vector? v) (list->vector
(map
loop
(vector->list v)))]
[(box? v) (box (loop (unbox v)))]
[else v])))))))
;; this require has to be here after the submodule
(require (for-syntax 'dmhelp))

210
pkgs/compatibility-pkgs/compatibility-lib/compatibility/mlist.rkt
View File

@ -1,210 +0,0 @@
#lang racket/base
(require (for-syntax racket/base)
racket/performance-hint)
(provide mmap
mfor-each
mlist
mlist?
mlength
mappend
mappend!
mreverse
mreverse!
mlist-tail
mlist-ref
mmemq
mmemv
mmember
massq
massv
massoc
mlist->list
list->mlist
mlistof)
(begin-encourage-inline
(define mmap
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) null]
[else (mcons (f (mcar l)) (loop (mcdr l)))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) null]
[else (mcons (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2)))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) null]
[else (mcons (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls)))]))]))
(define mfor-each
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) (void)]
[else (f (mcar l))
(loop (mcdr l))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) (void)]
[else (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) (void)]
[else (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls))]))])))
(define (list->mlist l)
(cond
[(null? l) null]
[else (mcons (car l) (list->mlist (cdr l)))]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))
(define-syntax mlist
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id . _) (raise-syntax-error #f
"cannot mutate imported variable"
stx
#'id)]
[(_ a) #'(mcons a null)]
[(_ a b) #'(mcons a (mcons b null))]
[(_ a b c) #'(mcons a (mcons b (mcons c null)))]
[(_ arg ...) #'(-mlist arg ...)]
[_ #'-mlist]))))
(define -mlist
(let ([mlist
(case-lambda
[() null]
[(a) (mcons a null)]
[(a b) (mcons a (mcons b null))]
[(a b c) (mcons a (mcons b (mcons c null)))]
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
[l (list->mlist l)])])
mlist))
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlength l)
(let loop ([l l][len 0])
(cond
[(null? l) len]
[else (loop (mcdr l) (add1 len))])))
(define mappend
(case-lambda
[() null]
[(a) a]
[(a b) (let loop ([a a])
(if (null? a)
b
(mcons (mcar a) (loop (mcdr a)))))]
[(a . l) (mappend a (apply mappend l))]))
;; mappend! : like append, but mutate each list to refer to the next.
;; modeled loosely on the v372 behavior
(define mappend!
(case-lambda
[() null]
[(a) a]
[(a b) (if (null? a)
b
(let loop ([atail a])
(cond [(null? (mcdr atail)) (set-mcdr! atail b) a]
[else (loop (mcdr atail))])))]
[(a . l) (mappend! a (apply mappend! l))]))
(define (mreverse l)
(let loop ([l l][a null])
(cond
[(null? l) a]
[else (loop (mcdr l) (mcons (mcar l) a))])))
(define (mreverse! l)
(let loop ([l l][prev null])
(cond
[(null? l) prev]
[else (let ([next (mcdr l)])
(set-mcdr! l prev)
(loop next l))])))
(define (mlist-tail l n)
(cond
[(zero? n) l]
[else (mlist-tail (mcdr l) (sub1 n))]))
(define (mlist-ref l n)
(cond
[(zero? n) (mcar l)]
[else (mlist-ref (mcdr l) (sub1 n))]))
(define (do-member =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar l)) l]
[else (loop (mcdr l))])))
(define (mmemq v l)
(do-member eq? v l))
(define (mmemv v l)
(do-member eqv? v l))
(define (mmember v l)
(do-member equal? v l))
(define (do-assoc =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar (mcar l))) (mcar l)]
[else (loop (mcdr l))])))
(define (massq v l)
(do-assoc eq? v l))
(define (massv v l)
(do-assoc eqv? v l))
(define (massoc v l)
(do-assoc equal? v l))
(define ((mlistof p?) l)
(let loop ([l l])
(cond
[(null? l) #t]
[(not (mpair? l)) #f]
[(p? (mcar l)) (loop (mcdr l))]
[else #f])))

458
pkgs/compatibility-pkgs/compatibility-lib/compatibility/package.rkt
View File

@ -1,458 +0,0 @@
#lang racket/base
(require (for-syntax racket/base
racket/list
syntax/kerncase
syntax/boundmap
syntax/define
syntax/flatten-begin
syntax/context))
(provide define-package
package-begin
open-package
open*-package
define*
define*-values
define*-syntax
define*-syntaxes
(for-syntax package?
package-exported-identifiers
package-original-identifiers))
(define-for-syntax (do-define-* stx define-values-id)
(syntax-case stx ()
[(_ (id ...) rhs)
(let ([ids (syntax->list #'(id ...))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"expected an identifier for definition"
stx
id)))
ids)
(with-syntax ([define-values define-values-id])
(syntax/loc stx
(define-values (id ...) rhs))))]))
(define-syntax (-define*-values stx)
(do-define-* stx #'define-values))
(define-syntax (-define*-syntaxes stx)
(do-define-* stx #'define-syntaxes))
(define-syntax (define*-values stx)
(syntax-case stx ()
[(_ (id ...) rhs)
(syntax-property
(syntax/loc stx (-define*-values (id ...) rhs))
'certify-mode
'transparent-binding)]))
(define-syntax (define*-syntaxes stx)
(syntax-case stx ()
[(_ (id ...) rhs)
(syntax-property
(syntax/loc stx (-define*-syntaxes (id ...) rhs))
'certify-mode
'transparent-binding)]))
(define-syntax (define* stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
(quasisyntax/loc stx
(define*-values (#,id) #,rhs))))
(define-syntax (define*-syntax stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
(quasisyntax/loc stx
(define*-syntaxes (#,id) #,rhs))))
(begin-for-syntax
(define-struct package (exports hidden)
#:omit-define-syntaxes
#:property prop:procedure (lambda (r stx)
(raise-syntax-error
#f
"misuse of a package name"
stx)))
(define (generate-hidden id)
;; Like `generate-temporaries', but preserve the symbolic name
((make-syntax-introducer) (datum->syntax #f (syntax-e id))))
(define (reverse-mapping who id exports hidden)
(or (ormap (lambda (m)
(and (free-identifier=? id (cdr m))
(car m)))
exports)
(ormap (lambda (h)
(and (free-identifier=? id h)
;; Not at top level, where free-id=? is unreliable,
;; and re-definition is ok:
(identifier-binding id)
;; Name is inaccessible. Generate a temporary to
;; avoid potential duplicate-definition errors
;; when the name is bound in the same context as
;; the package.
(generate-hidden id)))
hidden)
id)))
(define-for-syntax (move-props orig new)
(datum->syntax new
(syntax-e new)
orig
orig))
(define-for-syntax code-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define-for-syntax (disarm* stx)
(cond
[(and (syntax? stx)
(pair? (syntax-e stx)))
(let ([stx (syntax-disarm stx code-insp)])
(datum->syntax stx (disarm* (syntax-e stx)) stx stx))]
[(pair? stx) (cons (disarm* (car stx)) (disarm* (cdr stx)))]
[else stx]))
(define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx ()
[(_ pack-id mode exports form ...)
(let ([id #'pack-id]
[exports #'exports]
[mode (syntax-e #'mode)])
(unless (eq? mode '#:begin)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier"
stx
id)))
(let ([exports
(cond
[(syntax->list exports)
=> (lambda (l)
(for-each (lambda (i)
(unless (identifier? i)
(raise-syntax-error #f
"expected identifier to export"
stx
i)))
l)
(let ([dup-id (check-duplicate-identifier l)])
(when dup-id
(raise-syntax-error
#f
"duplicate export"
stx
dup-id)))
l)]
[else (raise-syntax-error #f
(format "expected a parenthesized sequence of identifiers ~a"
(case mode
[(#:only) "to export"]
[(#:all-defined-except) "to exclude from export"]
[else (format "for ~a" mode)]))
stx
exports)])])
(let* ([def-ctx (syntax-local-make-definition-context)]
[ctx (generate-expand-context #t)]
[pre-package-id (lambda (id def-ctxes)
(identifier-remove-from-definition-context
id
def-ctxes))]
[kernel-forms (list*
#'-define*-values
#'-define*-syntaxes
(kernel-form-identifier-list))]
[init-exprs (syntax->list #'(form ...))]
[new-bindings (make-bound-identifier-mapping)]
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
(lambda (stx)
(syntax-case* (disarm* stx) (define-syntaxes #%plain-app make-package quote-syntax
list cons #%plain-lambda)
free-transformer-identifier=?
[(define-syntaxes (pack-id)
(#%plain-app
make-package
(#%plain-lambda ()
(#%plain-app list
(#%plain-app cons
(quote-syntax export)
(quote-syntax renamed))
...))
hidden))
(with-syntax ([(export ...)
(map (lambda (id)
(if (or (ormap (lambda (e-id)
(bound-identifier=? id e-id))
renamed-exports)
(not (ormap (lambda (e-id)
(bound-identifier=? id e-id))
renamed-defines)))
;; Need to preserve the original
(pre-package-id id def-ctxes)
;; It's not accessible, so just hide the name
;; to avoid re-binding errors. (Is this necessary,
;; or would `pre-package-id' take care of it?)
(generate-hidden id)))
(syntax->list #'(export ...)))])
(syntax/loc stx
(define-syntaxes (pack-id)
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
hidden))))]
[_ stx])))]
[complement (lambda (bindings ids)
(let ([tmp (make-bound-identifier-mapping)])
(bound-identifier-mapping-for-each bindings
(lambda (k v)
(bound-identifier-mapping-put! tmp k #t)))
(for-each (lambda (id)
(bound-identifier-mapping-put! tmp id #f))
ids)
(filter
values
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
(let ([register-bindings!
(lambda (ids)
(for-each (lambda (id)
(when (bound-identifier-mapping-get new-bindings id (lambda () #f))
(raise-syntax-error #f
"duplicate binding"
stx
id))
(bound-identifier-mapping-put! new-bindings
id
#t))
ids))]
[add-package-context (lambda (def-ctxes)
(lambda (stx)
(let ([q (local-expand #`(quote #,stx)
ctx
(list #'quote)
def-ctxes)])
(syntax-case q ()
[(_ stx) #'stx]))))])
(let loop ([exprs init-exprs]
[rev-forms null]
[def-ctxes (list def-ctx)])
(cond
[(null? exprs)
(for-each (lambda (def-ctx)
(internal-definition-context-seal def-ctx))
def-ctxes)
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
[defined-renamed (bound-identifier-mapping-map new-bindings
(lambda (k v) k))])
(for-each (lambda (ex renamed)
(unless (bound-identifier-mapping-get new-bindings
renamed
(lambda () #f))
(raise-syntax-error #f
(format "no definition for ~a identifier"
(case mode
[(#:only) "exported"]
[(#:all-defined-except) "excluded"]))
stx
ex)))
exports
exports-renamed)
(let-values ([(exports exports-renamed)
(if (memq mode '(#:only #:begin))
(values exports exports-renamed)
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
;; In case of define*, get only the last definition:
(let ([tmp (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put!
tmp
((add-package-context def-ctxes)
(pre-package-id id def-ctxes))
#t))
all-exports-renamed)
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
[exports (map (lambda (id) (pre-package-id id def-ctxes))
exports-renamed)])
(values exports exports-renamed)))))]
[(prune)
(lambda (stx)
(identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))])
(with-syntax ([(export ...) (map prune exports)]
[(renamed ...) (map prune exports-renamed)]
[(hidden ...) (map prune (complement new-bindings exports-renamed))])
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
(reverse rev-forms))])
(if (eq? mode '#:begin)
(if (eq? 'expression (syntax-local-context))
(quasisyntax/loc stx (let () #,@body))
(quasisyntax/loc stx (begin #,@body)))
(quasisyntax/loc stx
(begin
#,@(if (eq? 'top-level (syntax-local-context))
;; delcare all bindings before they are used:
#`((define-syntaxes #,defined-renamed (values)))
null)
#,@body
(define-syntax pack-id
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
(lambda ()
(list (quote-syntax hidden) ...)))))))))))]
[else
(let ([expr (local-expand (car exprs)
ctx
kernel-forms
def-ctxes)])
(syntax-case expr (begin)
[(begin . rest)
(loop (append (flatten-begin expr) (cdr exprs))
rev-forms
def-ctxes)]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-syntaxes)
(free-identifier=? #'def #'-define*-syntaxes))
(andmap identifier? (syntax->list #'(id ...))))
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(let ([star? (free-identifier=? #'def #'-define*-syntaxes)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(last def-ctxes))]
[ids (map
(lambda (id) (syntax-property id 'unshadowable #t))
(if star?
(map (add-package-context (list def-ctx)) ids)
ids))])
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons (move-props expr #`(define-syntaxes #,ids rhs))
rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
[(def (id ...) rhs)
(and (or (free-identifier=? #'def #'define-values)
(free-identifier=? #'def #'-define*-values))
(andmap identifier? (syntax->list #'(id ...))))
(let ([star? (free-identifier=? #'def #'-define*-values)]
[ids (syntax->list #'(id ...))])
(let* ([def-ctx (if star?
(syntax-local-make-definition-context (car def-ctxes))
(last def-ctxes))]
[ids (map
(lambda (id) (syntax-property id 'unshadowable #t))
(if star?
(map (add-package-context (list def-ctx)) ids)
ids))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(register-bindings! ids)
(loop (cdr exprs)
(cons (move-props expr #`(define-values #,ids rhs)) rev-forms)
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
[else
(loop (cdr exprs)
(cons (if (and (eq? mode '#:begin)
(null? (cdr exprs)))
expr
#`(define-values () (begin #,expr (values))))
rev-forms)
def-ctxes)]))]))))))]))
(define-syntax (define-package stx)
(syntax-case stx ()
[(_ id #:all-defined form ...)
(do-define-package stx #'(define-package id #:all-defined () form ...))]
[(_ id #:all-defined-except ids form ...)
(do-define-package stx stx)]
[(_ id #:only ids form ...)
(do-define-package stx stx)]
[(_ id ids form ...)
(do-define-package stx #'(define-package id #:only ids form ...))]))
(define-syntax (package-begin stx)
(syntax-case stx ()
[(_ form ...)
(do-define-package stx #'(define-package #f #:begin () form ...))]))
(define-for-syntax (do-open stx define-syntaxes-id)
(syntax-case stx ()
[(_ pack-id)
(let ([id #'pack-id])
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier for a package"
stx
id))
(let ([v (syntax-local-value id (lambda () #f))])
(unless (package? v)
(raise-syntax-error #f
"identifier is not bound to a package"
stx
id))
(let ([introduce (syntax-local-make-delta-introducer
(syntax-local-introduce id))])
(with-syntax ([(intro ...)
(map (lambda (i)
(syntax-local-introduce
(syntax-local-get-shadower
(introduce i))))
(map car ((package-exports v))))]
[(defined ...)
(map (lambda (v) (syntax-local-introduce (cdr v)))
((package-exports v)))]
[((a . b) ...) (map (lambda (p)
(cons (syntax-local-introduce (car p))
(syntax-local-introduce (cdr p))))
((package-exports v)))]
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
(syntax-property
#`(#,define-syntaxes-id (intro ...)
(let ([rev-map (lambda (x)
(reverse-mapping
'pack-id
x
(list (cons (quote-syntax a)
(quote-syntax b))
...)
(list (quote-syntax h) ...)))])
(values (make-rename-transformer #'defined rev-map)
...)))
'disappeared-use
(syntax-local-introduce id))))))]))
(define-syntax (open-package stx)
(do-open stx #'define-syntaxes))
(define-syntax (open*-package stx)
(do-open stx #'define*-syntaxes))
(define-for-syntax (package-exported-identifiers id)
(let ([v (and (identifier? id)
(syntax-local-value id (lambda () #f)))])
(unless (package? v)
(if (identifier? id)
(raise-arguments-error 'package-exported-identifiers "identifier is not bound to a package"
"identifier" id)
(raise-argument-error 'package-exported-identifiers "identifier?" id)))
(let ([introduce (syntax-local-make-delta-introducer
(syntax-local-introduce id))])
(map (lambda (i)
(syntax-local-introduce
(syntax-local-get-shadower
(introduce (car i)))))
((package-exports v))))))
(define-for-syntax (package-original-identifiers id)
(let ([v (and (identifier? id)
(syntax-local-value id (lambda () #f)))])
(unless (package? v)
(if (identifier? id)
(raise-arguments-error 'package-original-identifiers "identifier is not bound to a package"
"identifier" id)
(raise-argument-error 'package-original-identifiers "identifier?" id)))
(map cdr ((package-exports v)))))

10
pkgs/compatibility-pkgs/compatibility-lib/info.rkt
View File

@ -1,10 +0,0 @@
#lang info
(define collection 'multi)
(define deps '("scheme-lib"
"base"
"net-lib"
"sandbox-lib"))
(define pkg-desc "implementation (no documentation) part of \"compatibility\"")
(define pkg-authors '(eli mflatt robby samth))

3
pkgs/compatibility-pkgs/compatibility-lib/lazy/mz-without-promises.rkt
View File

@ -1,3 +0,0 @@
;; A tiny language to build our promises with no built-in interference
(module mz-without-promises mzscheme
(provide (all-from-except mzscheme delay force promise?)))

29
pkgs/compatibility-pkgs/compatibility-lib/mzlib/a-signature.rkt
View File

@ -1,29 +0,0 @@
(module a-signature mzscheme
(require-for-syntax racket/private/unit-compiletime
racket/private/unit-syntax)
(require "unit.rkt")
(provide (rename module-begin #%module-begin)
(all-from-except mzscheme #%module-begin)
(all-from "unit.rkt"))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-sig$" (symbol->string s) "")
"^")))
(define-syntax (module-begin stx)
(parameterize ((error-syntax stx))
(with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
(syntax-case stx ()
((_ . x)
(with-syntax ((((reqs ...) . (body ...))
(split-requires (checked-syntax->list #'x))))
(datum->syntax-object
stx
(syntax-e #'(#%module-begin
reqs ...
(provide name)
(define-signature name (body ...))))
stx))))))))

89
pkgs/compatibility-pkgs/compatibility-lib/mzlib/a-unit.rkt
View File

@ -1,89 +0,0 @@
(module a-unit mzscheme
(require "unit.rkt")
(require-for-syntax syntax/kerncase)
(provide (rename module-begin #%module-begin)
(all-from-except mzscheme #%module-begin)
(all-from "unit.rkt"))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-unit$" (symbol->string s) "")
"@")))
;; Look for `import' and `export', and start processing the body:
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ elem ...)
(with-syntax ([((elem ...) . (literal ...))
(let loop ([elems (syntax->list #'(elem ...))]
[accum null])
(syntax-case elems (import export)
[((import . _1) (export . _2) . _3)
(cons (reverse accum) elems)]
[((import . _1) . _2)
(raise-syntax-error
#f
"expected an `export' clause after `import'"
stx)]
[()
(raise-syntax-error
#f
"missing an `import' clause"
stx)]
[_else
(loop (cdr elems) (cons (car elems) accum))]))])
(with-syntax ((name (datum->syntax-object
stx
(make-name (syntax-property stx 'enclosing-module-name))
stx))
(orig-stx stx))
(datum->syntax-object
stx
(syntax-e
#'(#%module-begin (a-unit-module orig-stx finish-a-unit (import export)
"original import form"
name (elem ...) (literal ...))))
stx
stx)))]))
;; Process one `require' form (and make sure it's a require form):
(define-syntax (a-unit-module stx)
(syntax-case stx ()
[(_ orig-stx finish stops separator name (elem1 elem ...) (literal ...))
(let ([e (local-expand #'elem1
'module
(append
(syntax->list #'stops)
(list*
#'require
#'require-for-syntax
#'require-for-template
(kernel-form-identifier-list))))])
(syntax-case e (begin)
[(req r ...)
(or (module-identifier=? #'req #'require)
(module-identifier=? #'req #'require-for-syntax)
(module-identifier=? #'req #'require-for-template))
#'(begin
(req r ...)
(a-unit-module orig-stx finish stops separator name (elem ...) (literal ...)))]
[(begin b ...)
#'(a-unit-module orig-stx finish stops separator name (b ... elem ...) (literal ...))]
[_else
(raise-syntax-error
#f
(format "non-require form before ~a" (syntax-e #'separator))
#'orig-stx
e)]))]
[(_ orig-stx finish stops separator name () (literal ...))
#'(finish orig-stx name literal ...)]))
;; All requires are done, so finish handling the unit:
(define-syntax (finish-a-unit stx)
(syntax-case stx (import export)
[(_ orig-stx name imports exports elem ...)
#'(begin
(provide name)
(define-unit name imports exports elem ...))])))

3
pkgs/compatibility-pkgs/compatibility-lib/mzlib/async-channel.rkt
View File

@ -1,3 +0,0 @@
#lang racket/base
(require racket/async-channel)
(provide (all-from-out racket/async-channel))

256
pkgs/compatibility-pkgs/compatibility-lib/mzlib/awk.rkt
View File

@ -1,256 +0,0 @@
(module awk mzscheme
(require-for-syntax syntax/stx)
(provide awk match:start match:end match:substring regexp-exec)
(define-syntax awk
(lambda (stx)
(syntax-case stx ()
[(_ next-record
(record field ...)
counter
((state-variable init-expr) ...)
continue
clause ...)
(and (identifier? (syntax counter))
(identifier? (syntax continue)))
(let ([clauses (syntax->list (syntax (clause ...)))]
[initvars null])
(with-syntax ([(local-state ...) (generate-temporaries
(syntax->list (syntax (state-variable ...))))])
(letrec ([get-after-clauses
(lambda ()
(let loop ([l clauses][afters null])
(cond
[(null? l) (if (stx-null? afters)
(syntax ((values state-variable ...)))
afters)]
[(syntax-case (car l) (after)
[(after . rest) (syntax rest)]
[_else #f])
=> (lambda (rest)
(with-syntax ([(after ...) afters])
(loop (cdr l) (syntax (after ... . rest)))))]
[else
(loop (cdr l) afters)])))]
[wrap-state
(lambda (e)
(syntax-case e (=>)
[(=> f)
(with-syntax ([body (wrap-state (syntax ((f arg))))])
(syntax (=> (lambda (arg)
. body))))]
[body
(syntax
((call-with-values (lambda () . body)
(lambda (local-state ... . extras)
(set! else-ready? #f)
(set! state-variable local-state)
...))))]))]
[make-range
(lambda (include-on? include-off? body rest)
(syntax-case body ()
[(t1 t2 . body)
(with-syntax ([on? (car (generate-temporaries '(1)))]
[t1 (make-test (syntax-e (syntax t1)) (syntax t1))]
[t2 (make-test (syntax-e (syntax t2)) (syntax t2))]
[body (wrap-state (syntax body))])
(with-syntax ([check (if include-on?
(if include-off?
(syntax post-on-on?)
(syntax on?))
(if include-off?
(syntax orig-on?)
(syntax (and orig-on? on?))))])
(set! initvars (cons (syntax (on? #f)) initvars))
(syntax
((let ([orig-on? on?])
(unless on?
(set! on? t1))
(let ([post-on-on? on?])
(when on?
(set! on? (not t2))))
(when check
. body))
. rest))))]
[_else (raise-syntax-error
#f
"bad range"
stx
body)]))]
[make-test
(lambda (test expr)
(cond
[(string? test)
(with-syntax ([g (car (generate-temporaries '(1)))]
[expr expr])
(set! initvars (cons (syntax (g (regexp expr))) initvars))
(syntax (regexp-exec g record)))]
[(number? test)
(with-syntax ([expr expr])
(syntax (= expr counter)))]
[else expr]))]
[get-testing-clauses
(lambda ()
(let loop ([l clauses])
(if (null? l)
null
(syntax-case (car l) ()
[(test-expr body ...)
(with-syntax ([rest (loop (cdr l))])
(let ([test (syntax-e (syntax test-expr))]
[body (syntax (body ...))])
(cond
[(or (string? test) (number? test))
(with-syntax ([t (make-test test (syntax test-expr))]
[body (wrap-state body)])
(syntax
((cond [t . body]
[else (void)])
. rest)))]
[(eq? test 'else)
(with-syntax ([body (wrap-state body)])
(syntax
((when else-ready? . body)
(set! else-ready? #t)
. rest)))]
[(eq? test 'range)
(make-range #f #f body (syntax rest))]
[(eq? test ':range)
(make-range #t #f body (syntax rest))]
[(eq? test 'range:)
(make-range #f #t body (syntax rest))]
[(eq? test ':range:)
(make-range #t #t body (syntax rest))]
[(eq? test 'after)
(syntax rest)]
[(eq? test '/)
(with-syntax ([g (car (generate-temporaries '(1)))])
(syntax-case* body (/) (lambda (a b)
(eq? (syntax-e a)
(syntax-e b)))
[(re / (var ...) . body)
(and (string? (syntax-e (syntax re)))
(andmap (lambda (x) (or (identifier? x)
(not (syntax-e x))))
(syntax->list (syntax (var ...)))))
(with-syntax ([(var ...)
(map (lambda (x)
(if (identifier? x)
x
(car (generate-temporaries '(1)))))
(syntax->list (syntax (var ...))))]
[body (wrap-state (syntax body))])
(set! initvars (cons (syntax (g (regexp re))) initvars))
(syntax
((cond
[(regexp-match re record)
=> (lambda (arg)
(apply
(lambda (var ...) . body)
arg))]
[else (void)])
. rest)))]
[_else (raise-syntax-error
#f
"bad / ... / clause"
stx
(car l))]))]
[else
(with-syntax ([body (wrap-state body)])
(syntax
((cond [test-expr . body]
[else (void)])
. rest)))])))]
[_else (raise-syntax-error
#f
"bad clause"
stx
(car l))]))))])
(with-syntax ([testing-clauses (get-testing-clauses)]
[after-clauses (get-after-clauses)]
[initvars initvars])
(syntax
(let ((state-variable init-expr) ...
. initvars)
(let loop ([counter 1])
(call-with-values (lambda () next-record)
(lambda (record field ...)
(if (eof-object? record)
(begin
. after-clauses)
(let ([else-ready? #t])
(let/ec escape
(let ([continue
(lambda (local-state ... . extras)
(set! state-variable local-state)
...
(escape))])
. testing-clauses))
(loop (add1 counter)))))))))))))]
;; Left out continue...
[(_ next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
clause ...)
(identifier? (syntax counter-variable))
(syntax
(awk next-record
(record field-variable ...)
counter-variable
((state-variable init-expr) ...)
continue
clause ...))]
;; Left out counter...
[(_ next-record
(record field-variable ...)
((state-variable init-expr) ...)
continue-variable
clause ...)
(identifier? (syntax continue-variable))
(syntax
(awk next-record
(record field-variable ...)
counter
((state-variable init-expr) ...)
continue-variable
clause ...))]
;; Left out both...
[(_ next-record
(record field-variable ...)
((state-variable init-expr) ...)
clause ...)
(syntax
(awk next-record
(record field-variable ...)
counter
((state-variable init-expr) ...)
continue
clause ...))])))
(define-struct match (s a))
(define match:start
(case-lambda
[(rec) (match:start rec 0)]
[(rec which) (car (list-ref (match-a rec) which))]))
(define match:end
(case-lambda
[(rec) (match:end rec 0)]
[(rec which) (cdr (list-ref (match-a rec) which))]))
(define match:substring
(case-lambda
[(rec) (match:substring rec 0)]
[(rec which) (let ([p (list-ref (match-a rec) which)])
(substring (match-s rec) (car p) (cdr p)))]))
(define regexp-exec
(lambda (re s)
(let ([r (regexp-match-positions re s)])
(if r
(make-match s r)
#f)))))

4
pkgs/compatibility-pkgs/compatibility-lib/mzlib/class.rkt
View File

@ -1,4 +0,0 @@
#lang racket/base
(require racket/private/class-internal
racket/private/class-c-old)
(provide-public-names)

4
pkgs/compatibility-pkgs/compatibility-lib/mzlib/cm-accomplice.rkt
View File

@ -1,4 +0,0 @@
#lang racket/base
(require compiler/cm-accomplice)
(provide (all-from-out compiler/cm-accomplice))

4
pkgs/compatibility-pkgs/compatibility-lib/mzlib/cm.rkt
View File

@ -1,4 +0,0 @@
#lang racket/base
(require compiler/cm)
(provide (all-from-out compiler/cm))

145
pkgs/compatibility-pkgs/compatibility-lib/mzlib/cmdline.rkt
View File

@ -1,145 +0,0 @@
#lang mzscheme
(require (only racket/cmdline parse-command-line))
(provide command-line
parse-command-line)
(define-syntax (command-line stx)
(define (id=? x y)
(eq? (syntax-e x) (syntax-e y)))
(define (serror msg . detail)
(apply raise-syntax-error #f msg stx detail))
(define (extract-one what args . detail)
(if (null? args)
(apply serror (format "missing ~a" what) detail)
(values (car args) (cdr args))))
(define (extract-list stx/list pred)
(let loop ([xs null]
[rest (if (syntax? stx/list) (syntax->list stx/list) stx/list)])
(if (and (pair? rest) (pred (car rest)))
(loop (cons (car rest) xs) (cdr rest))
(values (reverse xs) rest))))
(define (formal-names l)
(map (lambda (a)
(datum->syntax-object
(quote-syntax here)
(let ([s (symbol->string (syntax-e a))])
(if (char=? #\* (string-ref s (sub1 (string-length s))))
(substring s 0 (sub1 (string-length s)))
s))
#f))
l))
(syntax-case stx ()
[(_ program-name argv clause ...)
(let ([clauses
(let loop ([csrcs (syntax->list #'(clause ...))][clauses null])
(with-syntax ([(clause ...) clauses])
(if (null? csrcs)
#'((list clause ...) (lambda (accum) (void)) null)
(let ([line (car csrcs)]
[arest (cdr csrcs)])
(syntax-case* line (help-labels => args) id=?
[(help-labels s ...)
(begin
(unless (andmap (lambda (x) (string? (syntax-e x)))
(syntax->list #'(s ...)))
(serror "help-labels clause must contain only strings" line))
(loop arest #'(clause ... '(help-labels s ...))))]
[(tag . rest)
(ormap (lambda (x) (id=? #'tag x))
(syntax->list #'(once-each once-any multi final)))
(with-syntax
([sublines
(let slloop ([sublines (syntax->list #'rest)])
(if (null? sublines)
#'()
(with-syntax
([looped (slloop (cdr sublines))]
[subline
(with-syntax
([flags
(syntax-case (car sublines) ()
[((flag ...) . rest)
(begin
(unless (andmap
(lambda (x) (string? (syntax-e x)))
(syntax->list #'(flag ...)))
(serror
"flag specification is not a string or sequence of strings"
#'(flag ...)))
#'(flag ...))]
[(flag . rest)
(string? (syntax-e #'flag))
#'(flag)]
[else
(serror "clause does not start with flags")])])
(syntax-case* (car sublines) (=>) id=?
[(_ => a b)
#'(list 'flags a b)]
[(_ rest ...)
(let*-values ([(formals rest)
(extract-list #'(rest ...) identifier?)]
[(helps rest)
(extract-list
rest (lambda (x) (string? (syntax-e x))))]
[(expr1 rest)
(extract-one
"handler body expressions" rest line)])
(when (null? helps)
(serror "missing help string/s"))
(with-syntax ([formals formals]
[formal-names (formal-names formals)]
[helps helps]
[expr1 expr1]
[rest rest])
#'(list 'flags
(lambda (flag . formals) expr1 . rest)
'(helps . formal-names))))]))])
#'(subline . looped))))])
(loop arest #'(clause ... (list 'tag . sublines))))]
[(=> finish-proc arg-help help-proc unknown-proc)
(begin
(unless (null? arest)
(serror "=> must be the last clause line"))
#'((list clause ...)
finish-proc arg-help help-proc unknown-proc))]
[(=> finish-proc arg-help help-proc)
(begin
(unless (null? arest)
(serror "=> must be the last clause line"))
#'((list clause ...)
finish-proc arg-help help-proc))]
[(=> finish-proc arg-help)
(begin
(unless (null? arest)
(serror "=> must be the last clause line"))
#'((list clause ...) finish-proc arg-help))]
[(=> . _)
(serror "bad => line" line)]
[(args arg-formals body1 body ...)
(begin
(unless (null? arest)
(serror "args must be the last clause" line))
(let ([formals
(let loop ([f #'arg-formals])
(syntax-case f ()
[() null]
[(arg . rest)
(identifier? #'arg)
(cons #'arg (loop #'rest))]
[arg
(identifier? #'arg)
(list #'arg)]
[else
(serror "bad argument list" line)]))])
(with-syntax ([formal-names (formal-names formals)])
#'((list clause ...)
(lambda (accume . arg-formals)
body1 body ...)
'formal-names))))]
[(args . _)
(serror "bad args line" line)]
[else (serror "not a once-each, once-any, multi, final, args, or => line" line)])))))])
(with-syntax ([clauses clauses])
#'(parse-command-line program-name argv . clauses)))]))

35
pkgs/compatibility-pkgs/compatibility-lib/mzlib/cml.rkt
View File

@ -1,35 +0,0 @@
#lang racket/base
(require racket/contract/base)
(define (spawn thunk)
(thread/suspend-to-kill thunk))
(define (channel)
(make-channel))
(define (channel-recv-evt ch)
ch)
(define (channel-send-evt ch v)
(wrap-evt
(channel-put-evt ch v)
void))
(define (thread-done-evt th)
(thread-dead-evt th))
(define (current-time)
(current-inexact-milliseconds))
(define (time-evt t)
(alarm-evt t))
(provide/contract
(spawn ((-> any) . -> . thread?))
(channel (-> channel?))
(channel-recv-evt (channel? . -> . evt?))
(channel-send-evt (channel? any/c . -> . evt?))
(thread-done-evt (thread? . -> . evt?))
(current-time (-> number?))
(time-evt (real? . -> . evt?)))

109
pkgs/compatibility-pkgs/compatibility-lib/mzlib/compat.rkt
View File

@ -1,109 +0,0 @@
(module compat mzscheme
(provide real-time
1+ 1-
>=? <=? >? <? =?
flush-output-port
gentemp
atom?
putprop getprop
new-cafe
define-structure)
(define 1+ add1)
(define 1- sub1)
(define =? =)
(define <? <)
(define >? >)
(define <=? <)
(define >=? >)
(define atom? (lambda (v) (not (pair? v))))
(define gentemp gensym)
(define flush-output-port flush-output)
(define real-time current-milliseconds)
(define table (make-hash-table))
(define getprop
(case-lambda
[(k prop) (getprop k prop #f)]
[(k prop def)
(let ([al (hash-table-get table k (lambda () #f))])
(if al
(let ([v (assq prop al)])
(if v
(unbox (cdr v))
def))
def))]))
(define putprop
(lambda (k prop nv)
(let ([al (hash-table-get table k (lambda () '()))])
(let ([v (assq prop al)])
(if v
(set-box! (cdr v) nv)
(hash-table-put! table k (cons (cons prop (box nv)) al)))))))
;; Chez's new-cafe
(define new-cafe
(letrec ([nc
(case-lambda
[() (nc (current-eval))]
[(eval)
(let/ec escape
(let ([orig-exit (exit-handler)]
[orig-eval (current-eval)])
(dynamic-wind
(lambda ()
(current-eval eval)
(exit-handler
(lambda (v) (escape v))))
read-eval-print-loop
(lambda ()
(current-eval orig-eval)
(exit-handler orig-exit)))))])])
nc))
(define-syntax define-structure
(lambda (stx)
(syntax-case stx ()
[(_ (sname field ...))
(syntax (define-structure (sname field ...) ()))]
[(_ (sname field ...) ([init-field init] ...))
(andmap identifier? (syntax->list
(syntax (sname field ... init-field ...))))
(let ([name (symbol->string (syntax-e (syntax sname)))]
[fields (map symbol->string
(map syntax-e
(syntax->list (syntax (field ...)))))]
[init-fields (map symbol->string
(map syntax-e
(syntax->list (syntax (init-field ...)))))]
[+ (lambda args
(datum->syntax-object
(syntax sname)
(string->symbol (apply string-append args))
(syntax sname)))])
(with-syntax ([struct: (+ "struct:" name)]
[make- (+ "make-" name)]
[? (+ name "?")]
[(gs ...)
(apply
append
(map (lambda (f) (list (+ name "-" f)
(+ "set-" name "-" f "!")))
(append fields init-fields)))])
(syntax
(define-values (struct: make- ? gs ...)
(let ()
(define-struct sname (field ... init-field ...))
(values struct:
(let ([make- (lambda (field ...)
(make- field ...
init ...))])
make-)
? gs ...))))))]))))

4
pkgs/compatibility-pkgs/compatibility-lib/mzlib/compile.rkt
View File

@ -1,4 +0,0 @@
#lang racket/base
(require compiler/compile-file)
(provide compile-file)

209
pkgs/compatibility-pkgs/compatibility-lib/mzlib/contract.rkt
View File

@ -1,209 +0,0 @@
#lang racket/base
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide arrow contracts from our local copy (mostly)
;;
(require "private/contract-arrow.rkt")
(provide (all-from-out "private/contract-arrow.rkt"))
(require (only-in racket/contract/base unconstrained-domain->))
(provide unconstrained-domain->)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide contracts for objects
;;
(require "private/contract-object.rkt")
(provide (all-from-out "private/contract-object.rkt"))
(require (only-in racket/class
is-a?/c
implementation?/c
subclass?/c
mixin-contract
make-mixin-contract))
(provide is-a?/c
implementation?/c
subclass?/c
mixin-contract
make-mixin-contract)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style define/contract
;;
(require "private/contract-define.rkt")
(provide (all-from-out "private/contract-define.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style flat mutable contracts
;;
(require "private/contract-mutable.rkt")
(provide (all-from-out "private/contract-mutable.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style flat struct contracts
;;
(require "private/contract-struct.rkt")
(provide (all-from-out "private/contract-struct.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide everything from the racket/ implementation
;; except the arrow contracts
;;
(require (prefix-in : racket/contract))
(require (for-syntax racket/provide-transform racket/base))
(define-syntax remove-prefix
(make-provide-transformer
(λ (stx ctxt)
(syntax-case stx ()
[(_ args ...)
(for/list ([arg (in-list (syntax->list #'(args ...)))])
(export arg
(string->symbol
(regexp-replace #rx"^:" (symbol->string (syntax-e arg)) ""))
0
#f
arg))]))))
(provide (remove-prefix
:define-contract-struct
:</c
:>/c
:chaperone-contract?
:contract-name
:contract-projection
:contract?
:false/c
:flat-contract
:flat-contract-predicate
:flat-contract?
:flat-named-contract
:impersonator-contract?
:make-none/c
:n->th
:natural-number/c
:printable/c
:promise/c
:or/c
:prompt-tag/c
:>=/c
:syntax/c
:any
:non-empty-listof
:any/c
:between/c
:cons/c
:integer-in
:symbols
:real-in
:list/c
:continuation-mark-key/c
:one-of/c
:procedure-arity-includes/c
:not/c
:flat-rec-contract
:flat-murec-contract
:=/c
:and/c
:parameter/c
:none/c
:<=/c
:listof
:contract
:current-contract-region
:recursive-contract
:provide/contract
:build-compound-type-name
:coerce-chaperone-contract
:coerce-chaperone-contracts
:coerce-contract
:coerce-contract/f
:coerce-contracts
:coerce-flat-contract
:coerce-flat-contracts
:contract-first-order
:contract-first-order-passes?
:contract-stronger?
:eq-contract-val
:eq-contract?
:equal-contract-val
:equal-contract?
:has-contract?
:impersonator-prop:contracted
:prop:contracted
:value-contract
:define/subexpression-pos-prop
:define/final-prop
:blame-add-unknown-context
:blame-context
:blame-contract
:blame-fmt->-string
:blame-negative
:blame-original?
:blame-positive
:blame-replace-negative
:blame-source
:blame-swap
:blame-swapped?
:blame-value
:blame?
:current-blame-format
:exn:fail:contract:blame-object
:exn:fail:contract:blame?
:make-exn:fail:contract:blame
:raise-blame-error
:struct:exn:fail:contract:blame
:blame-add-context
:exn:fail:contract:blame
:build-chaperone-contract-property
:build-contract-property
:build-flat-contract-property
:chaperone-contract-property?
:contract-property?
:contract-struct-exercise
:contract-struct-generate
:flat-contract-property?
:make-chaperone-contract
:make-contract
:make-flat-contract
:prop:chaperone-contract
:prop:contract
:prop:flat-contract
:prop:opt-chaperone-contract
:prop:opt-chaperone-contract-get-test
:prop:opt-chaperone-contract?
:skip-projection-wrapper?
:opt/c
:define-opt/c))
(provide
(rename-out [:or/c union])
(rename-out [:string-len/c string/len]))
(define (build-flat-contract name pred)
(:flat-contract (procedure-rename pred name)))
(provide build-flat-contract)
(require racket/contract/combinator)
;; exports from racket/contract/combinator as of 5.3.5
(provide blame-add-unknown-context blame-context blame-contract blame-fmt->-string blame-negative
blame-original? blame-positive blame-replace-negative blame-source blame-swap blame-swapped?
blame-update blame-value blame? build-chaperone-contract-property build-compound-type-name
build-contract-property build-flat-contract-property chaperone-contract-property?
coerce-chaperone-contract coerce-chaperone-contracts coerce-contract coerce-contract/f
coerce-contracts coerce-flat-contract coerce-flat-contracts contract-first-order
contract-first-order-passes? contract-property? contract-stronger? contract-struct-exercise
contract-struct-generate current-blame-format eq-contract-val eq-contract? equal-contract-val
equal-contract? exn:fail:contract:blame-object exn:fail:contract:blame?
flat-contract-property? impersonator-prop:contracted make-chaperone-contract make-contract
make-exn:fail:contract:blame make-flat-contract prop:chaperone-contract prop:contract
prop:contracted prop:flat-contract prop:opt-chaperone-contract
prop:opt-chaperone-contract-get-test prop:opt-chaperone-contract? raise-blame-error
skip-projection-wrapper? struct:exn:fail:contract:blame define/final-prop
exn:fail:contract:blame blame-add-context define/subexpression-pos-prop)

6
pkgs/compatibility-pkgs/compatibility-lib/mzlib/control.rkt
View File

@ -1,6 +0,0 @@
#lang racket/base
;; deprecated library, see `racket/control`
(require racket/control)
(provide (all-from-out racket/control))

6
pkgs/compatibility-pkgs/compatibility-lib/mzlib/date.rkt
View File

@ -1,6 +0,0 @@
#lang racket/base
;; deprecated library, see `racket/date`
(require racket/date)
(provide (all-from-out racket/date))

Some files were not shown because too many files have changed in this diff Show More