Split almost everything else from the main repository.
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
parent
f3dba3eb6b
commit
2987338218
18
Makefile
18
Makefile
|
|
@ -21,7 +21,9 @@
|
||||||
|
|
||||||
# Packages (separated by spaces) to link in development mode or
|
# Packages (separated by spaces) to link in development mode or
|
||||||
# to include in a distribution:
|
# 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
|
# In-place build
|
||||||
|
|
@ -29,6 +31,10 @@ PKGS = main-distribution plt-services
|
||||||
PLAIN_RACKET = racket/bin/racket
|
PLAIN_RACKET = racket/bin/racket
|
||||||
WIN32_PLAIN_RACKET = racket\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_ARGS = -I racket/base -e '(case (system-type) [(macosx) (exit 0)] [else (exit 1)])'
|
||||||
MACOSX_CHECK = $(PLAIN_RACKET) -G build/config $(MACOSX_CHECK_ARGS)
|
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:
|
# Explicitly propagate variables for non-GNU `make's:
|
||||||
PKG_LINK_COPY_ARGS = PKGS="$(PKGS)" LINK_MODE="$(LINK_MODE)"
|
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
|
LIBSETUP = -N raco -l- raco setup
|
||||||
|
|
||||||
plain-in-place:
|
plain-in-place:
|
||||||
|
|
@ -53,6 +60,9 @@ plain-in-place:
|
||||||
if $(MACOSX_CHECK) ; then $(MAKE) native-from-git ; fi
|
if $(MACOSX_CHECK) ; then $(MAKE) native-from-git ; fi
|
||||||
$(MAKE) pkg-links $(PKG_LINK_COPY_ARGS)
|
$(MAKE) pkg-links $(PKG_LINK_COPY_ARGS)
|
||||||
$(PLAIN_RACKET) $(LIBSETUP) $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
|
$(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
|
# For Windows: set up the following collections first, so that native
|
||||||
# libraries are in place for use by a full setup:
|
# 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)
|
$(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) -nxiID $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS) $(LIB_PRE_COLLECTS)
|
||||||
$(WIN32_PLAIN_RACKET) $(LIBSETUP) $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
|
$(WIN32_PLAIN_RACKET) $(LIBSETUP) $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
|
||||||
|
$(WIN32_PLAIN_RACO) pkg install $(JOB_OPTIONS) --scope installation \
|
||||||
|
--deps search-auto $(INSTALL_PKGS)
|
||||||
|
|
||||||
again:
|
again:
|
||||||
$(MAKE) LINK_MODE="--restore"
|
$(MAKE) LINK_MODE="--restore"
|
||||||
|
|
@ -96,6 +108,7 @@ plain-unix-style:
|
||||||
$(MAKE) local-catalog-maybe-native RACKET="$(DESTDIR)$(PREFIX)/bin/racket"
|
$(MAKE) local-catalog-maybe-native RACKET="$(DESTDIR)$(PREFIX)/bin/racket"
|
||||||
"$(DESTDIR)$(PREFIX)/bin/raco" pkg install $(UNIX_RACO_ARGS) $(REQUIRED_PKGS) $(PKGS)
|
"$(DESTDIR)$(PREFIX)/bin/raco" pkg install $(UNIX_RACO_ARGS) $(REQUIRED_PKGS) $(PKGS)
|
||||||
cd racket/src/build; $(MAKE) fix-paths
|
cd racket/src/build; $(MAKE) fix-paths
|
||||||
|
"$(DESTDIR)$(PREFIX)/bin/raco" pkg install $(JOB_OPTIONS) -i --dep search-auto $(INSTALL_PKGS)
|
||||||
|
|
||||||
error-need-prefix:
|
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:
|
pkg-links:
|
||||||
$(PLAIN_RACKET) $(LINK_ALL) $(LINK_MODE) $(PKGS) $(REQUIRED_PKGS)
|
$(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:
|
win32-pkg-links:
|
||||||
IF NOT EXIST native-pkgs\racket-win32-i386 $(MAKE) complain-no-submodule
|
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)"
|
$(MAKE) pkg-links PLAIN_RACKET="$(WIN32_PLAIN_RACKET)" LINK_MODE="$(LINK_MODE)" PKGS="$(PKGS)"
|
||||||
|
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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)])))
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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=
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 1.3 KiB |
|
|
@ -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))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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"))
|
|
||||||
|
|
@ -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)]))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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])))
|
|
||||||
|
|
@ -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
|
|
||||||
}))
|
|
||||||
|
|
@ -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 ()))))))
|
|
||||||
|
|
@ -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)])
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang info
|
|
||||||
|
|
||||||
(define raco-commands
|
|
||||||
'(("ctool" compiler/commands/ctool "compile and link C-based extensions" #f)))
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
||||||
|
|
@ -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))))
|
|
||||||
|
|
||||||
|
|
@ -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^)
|
|
||||||
|
|
@ -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")))
|
|
||||||
|
|
@ -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"))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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^)
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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)))))))
|
|
||||||
|
|
@ -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^)
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require "dynext.rkt")
|
|
||||||
(provide (all-from-out "dynext.rkt"))
|
|
||||||
|
|
@ -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 "")))
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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")))))))
|
|
||||||
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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"))
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
#lang info
|
|
||||||
|
|
||||||
(define test-responsibles '((all mflatt)))
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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)].}
|
|
||||||
|
|
@ -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 ())]))
|
|
||||||
|
|
@ -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]
|
|
||||||
|
|
@ -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].
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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
|
|
||||||
}
|
|
||||||
|
|
@ -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]
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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]
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
#lang info
|
|
||||||
|
|
||||||
(define scribblings '(("mzlib.scrbl" (multi-page) (legacy))))
|
|
||||||
|
|
@ -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].
|
|
||||||
|
|
@ -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]
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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)].}
|
|
||||||
|
|
@ -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[]
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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|.}
|
|
||||||
|
|
||||||
]}
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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].}
|
|
||||||
|
|
@ -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]
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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)
|
|
||||||
|
|
@ -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.}
|
|
||||||
|
|
@ -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.
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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])))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -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))
|
|
||||||
|
|
@ -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?)))
|
|
||||||
|
|
@ -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))))))))
|
|
||||||
|
|
||||||
|
|
@ -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 ...))])))
|
|
||||||
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
(require racket/async-channel)
|
|
||||||
(provide (all-from-out racket/async-channel))
|
|
||||||
|
|
@ -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)))))
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
(require racket/private/class-internal
|
|
||||||
racket/private/class-c-old)
|
|
||||||
(provide-public-names)
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require compiler/cm-accomplice)
|
|
||||||
(provide (all-from-out compiler/cm-accomplice))
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require compiler/cm)
|
|
||||||
(provide (all-from-out compiler/cm))
|
|
||||||
|
|
@ -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)))]))
|
|
||||||
|
|
@ -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?)))
|
|
||||||
|
|
||||||
|
|
@ -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 ...))))))]))))
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
(require compiler/compile-file)
|
|
||||||
|
|
||||||
(provide compile-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)
|
|
||||||
|
|
@ -1,6 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
;; deprecated library, see `racket/control`
|
|
||||||
|
|
||||||
(require racket/control)
|
|
||||||
(provide (all-from-out racket/control))
|
|
||||||
|
|
@ -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
Loading…
Reference in New Issue
Block a user