Merge branch 'master' of git:plt
This commit is contained in:
Matthias Felleisen
commit
be256183e1
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -115,9 +115,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids
|
|||
|
||||
make-color
|
||||
make-pen
|
||||
|
||||
save-image
|
||||
)
|
||||
pen?
|
||||
step-count?
|
||||
save-image)
|
||||
|
||||
(provide bitmap)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "../../mrlib/image-core.ss"
|
||||
"img-err.ss"
|
||||
scheme/match
|
||||
scheme/contract
|
||||
scheme/class
|
||||
scheme/gui/base
|
||||
racket/match
|
||||
racket/contract
|
||||
racket/class
|
||||
racket/gui/base
|
||||
htdp/error
|
||||
scheme/math
|
||||
(for-syntax scheme/base
|
||||
scheme/list)
|
||||
racket/math
|
||||
(for-syntax racket/base
|
||||
racket/list)
|
||||
lang/posn)
|
||||
|
||||
(define (show-image arg [extra-space 0])
|
||||
|
|
@ -92,7 +92,7 @@
|
|||
|
||||
|
||||
;; bitmap : string -> image
|
||||
;; gets one of the bitmaps that comes with drscheme, scales it down by 1/8 or something
|
||||
;; gets one of the bitmaps that comes with drracket, scales it down by 1/8 or something
|
||||
;; so that later scaling /translation/whatever will look reasonable.
|
||||
;; (the error message for a bad argument will list all of the currently installed example images;
|
||||
;; we may want to have some way teachers can stick new ones in there)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide define/chk
|
||||
to-img
|
||||
|
|
@ -16,13 +16,13 @@
|
|||
check-mode/color-combination)
|
||||
|
||||
(require htdp/error
|
||||
scheme/class
|
||||
racket/class
|
||||
lang/posn
|
||||
scheme/gui/base
|
||||
racket/gui/base
|
||||
"../../mrlib/image-core.ss"
|
||||
(prefix-in cis: "../../mrlib/cache-image-snip.ss")
|
||||
(for-syntax scheme/base
|
||||
scheme/list))
|
||||
(for-syntax racket/base
|
||||
racket/list))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme
|
||||
#lang racket
|
||||
|
||||
#|
|
||||
|
||||
This is a file from Guillaume that ran very slowly with the
|
||||
htdp/image library; here it is used as a performance test.
|
||||
Porting to #lang scheme +2htdp/image consisted of adding requires,
|
||||
Porting to #lang racket +2htdp/image consisted of adding requires,
|
||||
changing overlay/xy to underlay/xy, defining empty-scene, and
|
||||
adding the check-expect macro (and related code).
|
||||
Also added the timing code at the end.
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
#|
|
||||
;; snippet of code for experimentation
|
||||
#lang scheme/gui
|
||||
#lang racket/gui
|
||||
(require 2htdp/image
|
||||
lang/posn
|
||||
(only-in lang/htdp-advanced equal~?))
|
||||
|
|
@ -42,14 +42,14 @@
|
|||
; "../private/img-err.ss"
|
||||
"../../mrlib/private/image-core-bitmap.ss"
|
||||
lang/posn
|
||||
scheme/math
|
||||
scheme/class
|
||||
scheme/gui/base
|
||||
racket/math
|
||||
racket/class
|
||||
racket/gui/base
|
||||
rackunit
|
||||
(prefix-in 1: htdp/image)
|
||||
(only-in lang/htdp-advanced equal~?))
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-syntax racket/base))
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(test a => b)
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ sitemapdir="$scriptdir/sitemap"
|
|||
nsisdir="$scriptdir/nsis"
|
||||
unixinstallerdir="$scriptdir/unix-installer"
|
||||
unixpathcheckscript="$unixinstallerdir/check-install-paths"
|
||||
unixinstallerscript="$unixinstallerdir/plt-installer-header"
|
||||
unixinstallerscript="$unixinstallerdir/installer-header"
|
||||
|
||||
# full clean tgz before building anything (relative to $maindir)
|
||||
cleantgz="${installdir}-clean-tree.tgz"
|
||||
|
|
@ -1702,7 +1702,7 @@ do_tgz_to_exe() {
|
|||
_tgunzip "$nsistgz"
|
||||
_tgunzip "$tmptgz"
|
||||
show "Running NSIS to create the installer"
|
||||
"/c/Program Files/NSIS/makensis.exe" /V3 "plt-installer.nsi" | tr -d '\r' \
|
||||
"/c/Program Files/NSIS/makensis.exe" /V3 "installer.nsi" | tr -d '\r' \
|
||||
|| exit_error "NSIS build failed"
|
||||
_mv "installer.exe" "$tmpexe"
|
||||
_cd "$savedpwd"
|
||||
|
|
@ -1710,22 +1710,22 @@ do_tgz_to_exe() {
|
|||
}
|
||||
tgz_to_exe() {
|
||||
local srctgz="$1" tgtexe="$2.exe" pname="$3"; shift 3
|
||||
local nsistgz="$tmpdir/plt-nsis.tgz"
|
||||
local nsistgz="$tmpdir/racket-nsis.tgz"
|
||||
local tmptgz="$tmpdir/tgz2exe.tgz"
|
||||
local tmpexe="$tmpdir/tgz2exe.exe"
|
||||
_rm "$tmpdir/plt-nsis-$$"
|
||||
_cp -r "$PLTHOME/$nsisdir" "$tmpdir/plt-nsis-$$"
|
||||
_cd "$tmpdir/plt-nsis-$$"
|
||||
show "Writing \"plt-defs.nsh\""
|
||||
_rm "$tmpdir/racket-nsis-$$"
|
||||
_cp -r "$PLTHOME/$nsisdir" "$tmpdir/racket-nsis-$$"
|
||||
_cd "$tmpdir/racket-nsis-$$"
|
||||
show "Writing \"racket-defs.nsh\""
|
||||
{ local def='!define'
|
||||
echo "$def PLTVersion \"$version\""
|
||||
echo "$def RKTVersion \"$version\""
|
||||
# this must be four numbers
|
||||
echo "$def PLTVersionLong \"$version1.$version2.$version3.$version4\""
|
||||
echo "$def PLTHumanName \"`name_of_dist_package \"$pname\"` v$version\""
|
||||
echo "$def RKTVersionLong \"$version1.$version2.$version3.$version4\""
|
||||
echo "$def RKTHumanName \"`name_of_dist_package \"$pname\"` v$version\""
|
||||
if [[ "$releasing" != "yes" ]]; then
|
||||
echo "$def PLTStartName \"`name_of_dist_package \"$pname\"` v$version\""
|
||||
echo "$def RKTStartName \"`name_of_dist_package \"$pname\"` v$version\""
|
||||
else
|
||||
echo "$def PLTStartName \"`name_of_dist_package \"$pname\"`\""
|
||||
echo "$def RKTStartName \"`name_of_dist_package \"$pname\"`\""
|
||||
fi
|
||||
local dname
|
||||
case "$pname" in
|
||||
|
|
@ -1735,21 +1735,21 @@ tgz_to_exe() {
|
|||
( * ) exit_error "Unknown package name for exe installer: \"$pname\"" ;;
|
||||
esac
|
||||
if [[ "$releasing" != "yes" ]]; then
|
||||
echo "$def PLTDirName \"$dname-$version\""
|
||||
echo "$def RKTDirName \"$dname-$version\""
|
||||
else
|
||||
echo "$def PLTDirName \"$dname\""
|
||||
echo "$def RKTDirName \"$dname\""
|
||||
fi
|
||||
echo "$def PLTRegName \"$dname-$version\""
|
||||
echo "$def RKTRegName \"$dname-$version\""
|
||||
if [[ "$pname" = "mz" ]]; then echo "$def SimpleInstaller"; fi
|
||||
} > "plt-defs.nsh" \
|
||||
|| exit_error "Could not write \"plt-defs.h\""
|
||||
local line="---------- plt-defs.nsh ----------"
|
||||
} > "racket-defs.nsh" \
|
||||
|| exit_error "Could not write \"racket-defs.h\""
|
||||
local line="---------- racket-defs.nsh ----------"
|
||||
echo "$line"
|
||||
cat "plt-defs.nsh"
|
||||
cat "racket-defs.nsh"
|
||||
echo "$line" | sed 's/./-/g'
|
||||
_tgzip "$nsistgz" *
|
||||
_cd "$tmpdir"
|
||||
_rm "$tmpdir/plt-nsis-$$"
|
||||
_rm "$tmpdir/racket-nsis-$$"
|
||||
_scp "$nsistgz" "${nsismachine}:$nsistgz"
|
||||
_scp "$srctgz" "${nsismachine}:$tmptgz"
|
||||
run_part "$nsismachine" \
|
||||
|
|
|
|||
BIN
collects/meta/build/nsis/header-r.bmp
Normal file
BIN
collects/meta/build/nsis/header-r.bmp
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 34 KiB |
BIN
collects/meta/build/nsis/header.bmp
Normal file
BIN
collects/meta/build/nsis/header.bmp
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 34 KiB |
|
Before Width: | Height: | Size: 25 KiB After Width: | Height: | Size: 25 KiB |
|
|
@ -5,44 +5,44 @@
|
|||
;; ==================== Configuration
|
||||
|
||||
;; The following should define:
|
||||
;; PLTVersion, PLTVersionLong, PLTHumanName,
|
||||
;; PLTDirName, PLTRegName
|
||||
;; RKTVersion, RKTVersionLong, RKTHumanName,
|
||||
;; RKTDirName, RKTRegName
|
||||
|
||||
!include plt-defs.nsh
|
||||
!include racket-defs.nsh
|
||||
|
||||
Name "${PLTHumanName}"
|
||||
Name "${RKTHumanName}"
|
||||
OutFile "installer.exe"
|
||||
|
||||
BrandingText "${PLTHumanName}"
|
||||
BrandingText "${RKTHumanName}"
|
||||
BGGradient 4040A0 101020
|
||||
|
||||
SetCompressor /SOLID "LZMA"
|
||||
|
||||
InstallDir "$PROGRAMFILES\${PLTDirName}"
|
||||
InstallDir "$PROGRAMFILES\${RKTDirName}"
|
||||
!ifndef SimpleInstaller
|
||||
InstallDirRegKey HKLM "Software\${PLTRegName}" ""
|
||||
InstallDirRegKey HKLM "Software\${RKTRegName}" ""
|
||||
!endif
|
||||
!define MUI_STARTMENUPAGE_DEFAULTFOLDER "${PLTStartName}"
|
||||
!define MUI_ICON "plt-installer.ico"
|
||||
!define MUI_UNICON "plt-uninstaller.ico"
|
||||
!define MUI_STARTMENUPAGE_DEFAULTFOLDER "${RKTStartName}"
|
||||
!define MUI_ICON "installer.ico"
|
||||
!define MUI_UNICON "uninstaller.ico"
|
||||
!define MUI_HEADERIMAGE
|
||||
!define MUI_HEADERIMAGE_BITMAP "plt-header.bmp"
|
||||
!define MUI_HEADERIMAGE_BITMAP_RTL "plt-header-r.bmp"
|
||||
!define MUI_HEADERIMAGE_BITMAP "header.bmp"
|
||||
!define MUI_HEADERIMAGE_BITMAP_RTL "header-r.bmp"
|
||||
!define MUI_HEADERIMAGE_RIGHT
|
||||
|
||||
!define MUI_WELCOMEFINISHPAGE_BITMAP "plt-welcome.bmp"
|
||||
!define MUI_UNWELCOMEFINISHPAGE_BITMAP "plt-welcome.bmp"
|
||||
!define MUI_WELCOMEFINISHPAGE_BITMAP "welcome.bmp"
|
||||
!define MUI_UNWELCOMEFINISHPAGE_BITMAP "welcome.bmp"
|
||||
|
||||
!define MUI_WELCOMEPAGE_TITLE "${PLTHumanName} Setup"
|
||||
!define MUI_UNWELCOMEPAGE_TITLE "${PLTHumanName} Uninstall"
|
||||
!define MUI_WELCOMEPAGE_TITLE "${RKTHumanName} Setup"
|
||||
!define MUI_UNWELCOMEPAGE_TITLE "${RKTHumanName} Uninstall"
|
||||
!ifdef SimpleInstaller
|
||||
!define MUI_WELCOMEPAGE_TEXT "This is a simple installer for ${PLTHumanName}.$\r$\n$\r$\nIt will only create the PLT folder. To uninstall, simply remove the folder.$\r$\n$\r$\n$_CLICK"
|
||||
!define MUI_WELCOMEPAGE_TEXT "This is a simple installer for ${RKTHumanName}.$\r$\n$\r$\nIt will only create the Racket folder. To uninstall, simply remove the folder.$\r$\n$\r$\n$_CLICK"
|
||||
!else
|
||||
!define MUI_WELCOMEPAGE_TEXT "This wizard will guide you through the installation of ${PLTHumanName}.$\r$\n$\r$\nPlease close other PLT applications (DrScheme, MrEd, MzScheme) so the installer can update relevant system files.$\r$\n$\r$\n$_CLICK"
|
||||
!define MUI_WELCOMEPAGE_TEXT "This wizard will guide you through the installation of ${RKTHumanName}.$\r$\n$\r$\nPlease close other Racket applications so the installer can update relevant system files.$\r$\n$\r$\n$_CLICK"
|
||||
!endif
|
||||
!define MUI_UNWELCOMEPAGE_TEXT "This wizard will guide you through the removal of ${PLTHumanName}.$\r$\n$\r$\nBefore starting, make sure PLT applications (DrScheme, MrEd, MzScheme) are not running.$\r$\n$\r$\n$_CLICK"
|
||||
!define MUI_UNWELCOMEPAGE_TEXT "This wizard will guide you through the removal of ${RKTHumanName}.$\r$\n$\r$\nBefore starting, make sure no Racket applications are running.$\r$\n$\r$\n$_CLICK"
|
||||
|
||||
!define MUI_FINISHPAGE_TITLE "${PLTHumanName}"
|
||||
!define MUI_FINISHPAGE_TITLE "${RKTHumanName}"
|
||||
!ifdef SimpleInstaller
|
||||
!define MUI_FINISHPAGE_RUN
|
||||
!define MUI_FINISHPAGE_RUN_FUNCTION OpenInstDir
|
||||
|
|
@ -51,8 +51,8 @@ InstallDir "$PROGRAMFILES\${PLTDirName}"
|
|||
FunctionEnd
|
||||
!define MUI_FINISHPAGE_RUN_TEXT "Open the installation folder"
|
||||
!else
|
||||
!define MUI_FINISHPAGE_RUN "$INSTDIR\DrScheme.exe"
|
||||
!define MUI_FINISHPAGE_RUN_TEXT "Run DrScheme"
|
||||
!define MUI_FINISHPAGE_RUN "$INSTDIR\DrRacket.exe"
|
||||
!define MUI_FINISHPAGE_RUN_TEXT "Run DrRacket"
|
||||
!endif
|
||||
!define MUI_FINISHPAGE_LINK "Visit the Racket web site"
|
||||
!define MUI_FINISHPAGE_LINK_LOCATION "http://racket-lang.org/"
|
||||
|
|
@ -60,19 +60,19 @@ InstallDir "$PROGRAMFILES\${PLTDirName}"
|
|||
; !define MUI_UNFINISHPAGE_NOAUTOCLOSE ; to allow users see what was erased
|
||||
|
||||
!define MUI_STARTMENUPAGE_REGISTRY_ROOT "HKLM"
|
||||
!define MUI_STARTMENUPAGE_REGISTRY_KEY "Software\${PLTRegName}"
|
||||
!define MUI_STARTMENUPAGE_REGISTRY_KEY "Software\${RKTRegName}"
|
||||
!define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "Start Menu Folder"
|
||||
|
||||
; Doesn't work on some non-xp machines
|
||||
; !define MUI_INSTFILESPAGE_PROGRESSBAR colored
|
||||
|
||||
VIProductVersion "${PLTVersionLong}"
|
||||
VIAddVersionKey "ProductName" "PLT Scheme"
|
||||
VIAddVersionKey "Comments" "This is PLT Scheme, including DrScheme which is based on MrEd and MzScheme."
|
||||
VIProductVersion "${RKTVersionLong}"
|
||||
VIAddVersionKey "ProductName" "Racket"
|
||||
VIAddVersionKey "Comments" "This is the Racket language, see http://racket-lang.org/."
|
||||
VIAddVersionKey "CompanyName" "PLT"
|
||||
VIAddVersionKey "LegalCopyright" "© PLT"
|
||||
VIAddVersionKey "FileDescription" "PLT Scheme Installer"
|
||||
VIAddVersionKey "FileVersion" "${PLTVersion}"
|
||||
VIAddVersionKey "FileDescription" "Racket Installer"
|
||||
VIAddVersionKey "FileVersion" "${RKTVersion}"
|
||||
|
||||
;; ==================== Variables
|
||||
|
||||
|
|
@ -137,36 +137,36 @@ Function myTestInstDir
|
|||
FunctionEnd
|
||||
!else
|
||||
Function myTestInstDir
|
||||
; The assumption is that users might have all kinds of ways to get a PLT
|
||||
; The assumption is that users might have all kinds of ways to get a Racket
|
||||
; tree, plus, they might have an old wise-based installation, so it is better
|
||||
; to rely on files rather than test registry keys. Note: no version check.
|
||||
; if any of these exist, then we assume it's an old installation
|
||||
IfFileExists "$INSTDIR\MzScheme.exe" plt_is_installed
|
||||
IfFileExists "$INSTDIR\MrEd.exe" plt_is_installed
|
||||
IfFileExists "$INSTDIR\DrScheme.exe" plt_is_installed
|
||||
IfFileExists "$INSTDIR\collects" plt_is_installed
|
||||
Goto plt_is_not_installed
|
||||
plt_is_installed:
|
||||
IfFileExists "$INSTDIR\Racket.exe" racket_is_installed
|
||||
IfFileExists "$INSTDIR\GRacket.exe" racket_is_installed
|
||||
IfFileExists "$INSTDIR\DrRacket.exe" racket_is_installed
|
||||
IfFileExists "$INSTDIR\collects" racket_is_installed
|
||||
Goto racket_is_not_installed
|
||||
racket_is_installed:
|
||||
IfFileExists "${UNINSTEXE}" we_have_uninstall
|
||||
MessageBox MB_YESNO "It appears that there is an existing PLT Scheme installation in '$INSTDIR', but no Uninstaller was found.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES maybe_remove_tree
|
||||
MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR', but no Uninstaller was found.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES maybe_remove_tree
|
||||
Abort
|
||||
we_have_uninstall:
|
||||
MessageBox MB_YESNO "It appears that there is an existing PLT Scheme installation in '$INSTDIR'.$\r$\nDo you want to uninstall it first (recommended)?" /SD IDNO IDNO maybe_remove_tree
|
||||
MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR'.$\r$\nDo you want to uninstall it first (recommended)?" /SD IDNO IDNO maybe_remove_tree
|
||||
HideWindow
|
||||
ClearErrors
|
||||
ExecWait '"${UNINSTEXE}" _?=$INSTDIR'
|
||||
IfErrors uninstaller_problematic
|
||||
IfFileExists "$INSTDIR\MzScheme.exe" uninstaller_problematic
|
||||
IfFileExists "$INSTDIR\MrEd.exe" uninstaller_problematic
|
||||
IfFileExists "$INSTDIR\Racket.exe" uninstaller_problematic
|
||||
IfFileExists "$INSTDIR\GRacket.exe" uninstaller_problematic
|
||||
BringToFront
|
||||
Goto plt_is_not_installed
|
||||
Goto racket_is_not_installed
|
||||
uninstaller_problematic:
|
||||
MessageBox MB_YESNO "Errors in uninstallation!$\r$\nDo you want to quit and sort things out now (highly recommended)?" /SD IDNO IDNO maybe_remove_tree
|
||||
Quit
|
||||
maybe_remove_tree:
|
||||
MessageBox MB_YESNO "Since you insist, do you want to simply remove the previous directory now?$\r$\n(It is really better if you sort this out manually.)" /SD IDYES IDNO plt_is_not_installed
|
||||
MessageBox MB_YESNO "Since you insist, do you want to simply remove the previous directory now?$\r$\n(It is really better if you sort this out manually.)" /SD IDYES IDNO racket_is_not_installed
|
||||
RMDir /r $INSTDIR
|
||||
plt_is_not_installed:
|
||||
racket_is_not_installed:
|
||||
FunctionEnd
|
||||
!endif
|
||||
|
||||
|
|
@ -174,7 +174,7 @@ Section ""
|
|||
SetShellVarContext all
|
||||
|
||||
SetDetailsPrint both
|
||||
DetailPrint "Installing PLT Scheme..."
|
||||
DetailPrint "Installing Racket..."
|
||||
SetDetailsPrint listonly
|
||||
SetOutPath "$INSTDIR"
|
||||
File /a /r "plt\*.*"
|
||||
|
|
@ -189,43 +189,46 @@ Section ""
|
|||
!insertmacro MUI_STARTMENU_WRITE_BEGIN Application
|
||||
SetOutPath "$INSTDIR" ; Make installed links run in INSTDIR
|
||||
CreateDirectory "$SMPROGRAMS\$STARTMENU_FOLDER"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\DrScheme.lnk" "$INSTDIR\DrScheme.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\PLT Documentation.lnk" "$INSTDIR\plt-help.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\MrEd.lnk" "$INSTDIR\MrEd.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\MzScheme.lnk" "$INSTDIR\MzScheme.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\PLT Folder.lnk" "$INSTDIR"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\DrRacket.lnk" "$INSTDIR\DrRacket.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket Documentation.lnk" "$INSTDIR\Racket Documentation.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\GRacket.lnk" "$INSTDIR\GRacket.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket.lnk" "$INSTDIR\Racket.exe"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket Folder.lnk" "$INSTDIR"
|
||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Uninstall.lnk" "${UNINSTEXE}"
|
||||
!insertmacro MUI_STARTMENU_WRITE_END
|
||||
|
||||
SetDetailsPrint both
|
||||
DetailPrint "Setting Registry Keys..."
|
||||
SetDetailsPrint listonly
|
||||
WriteRegStr HKLM "Software\${PLTRegName}" "" "$INSTDIR" ; Save folder location
|
||||
WriteRegStr HKCR ".ss" "" "Scheme.Document"
|
||||
WriteRegStr HKCR ".scm" "" "Scheme.Document"
|
||||
WriteRegStr HKCR ".scrbl" "" "Scheme.Document"
|
||||
WriteRegStr HKCR "Scheme.Document" "" "PLT Scheme Document"
|
||||
WriteRegStr HKCR "Scheme.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
||||
WriteRegStr HKCR "Scheme.Document\shell\open\command" "" '"$INSTDIR\DrScheme.exe" "%1"'
|
||||
WriteRegStr HKLM "Software\${RKTRegName}" "" "$INSTDIR" ; Save folder location
|
||||
WriteRegStr HKCR ".rkt" "" "Racket.Document"
|
||||
WriteRegStr HKCR ".rktl" "" "Racket.Document"
|
||||
WriteRegStr HKCR ".rktd" "" "Racket.Document"
|
||||
WriteRegStr HKCR ".ss" "" "Racket.Document"
|
||||
WriteRegStr HKCR ".scm" "" "Racket.Document"
|
||||
WriteRegStr HKCR ".scrbl" "" "Racket.Document"
|
||||
WriteRegStr HKCR "Racket.Document" "" "Racket Document"
|
||||
WriteRegStr HKCR "Racket.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
||||
WriteRegStr HKCR "Racket.Document\shell\open\command" "" '"$INSTDIR\DrRacket.exe" "%1"'
|
||||
; Example, in case we want some things like this in the future
|
||||
; WriteRegStr HKCR "Scheme.Document\shell\mzscheme" "" "Run with MzScheme"
|
||||
; WriteRegStr HKCR "Scheme.Document\shell\mzscheme\command" "" '"$INSTDIR\MzScheme.exe" "-r" "%1"'
|
||||
WriteRegStr HKCR ".plt" "" "Setup PLT.Document"
|
||||
WriteRegStr HKCR "Setup PLT.Document" "" "PLT Scheme Package"
|
||||
WriteRegStr HKCR "Setup PLT.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
||||
WriteRegStr HKCR "Setup PLT.Document\shell\open\command" "" '"$INSTDIR\Setup PLT.exe" -p "%1"'
|
||||
; WriteRegStr HKCR "Racket.Document\shell\racket" "" "Run with Racket"
|
||||
; WriteRegStr HKCR "Racket.Document\shell\racket\command" "" '"$INSTDIR\Racket.exe" "-r" "%1"'
|
||||
WriteRegStr HKCR ".plt" "" "Racket Setup.Document"
|
||||
WriteRegStr HKCR "Racket Setup.Document" "" "Racket Package"
|
||||
WriteRegStr HKCR "Racket Setup.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
||||
WriteRegStr HKCR "Racket Setup.Document\shell\open\command" "" '"$INSTDIR\raco.exe" setup -p "%1"'
|
||||
|
||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "UninstallString" '"${UNINSTEXE}"'
|
||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "InstallLocation" "$INSTDIR"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "DisplayName" "${PLTHumanName}"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "DisplayIcon" "$INSTDIR\DrScheme.exe,0"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "DisplayVersion" "${PLTVersion}"
|
||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "UninstallString" '"${UNINSTEXE}"'
|
||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "InstallLocation" "$INSTDIR"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayName" "${RKTHumanName}"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayIcon" "$INSTDIR\DrRacket.exe,0"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayVersion" "${RKTVersion}"
|
||||
; used to also have "VersionMajor" & "VersionMinor" but looks like it's not needed
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "HelpLink" "http://racket-lang.org/"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "URLInfoAbout" "http://racket-lang.org/"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "Publisher" "PLT Scheme Inc."
|
||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "NoModify" "1"
|
||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}" "NoRepair" "1"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "HelpLink" "http://racket-lang.org/"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "URLInfoAbout" "http://racket-lang.org/"
|
||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "Publisher" "PLT Scheme Inc."
|
||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoModify" "1"
|
||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoRepair" "1"
|
||||
!endif
|
||||
|
||||
SetDetailsPrint both
|
||||
|
|
@ -238,20 +241,20 @@ SectionEnd
|
|||
|
||||
Function un.myGUIInit
|
||||
; if any of these exist, then we're fine
|
||||
IfFileExists "$INSTDIR\MzScheme.exe" plt_is_installed_un
|
||||
IfFileExists "$INSTDIR\MrEd.exe" plt_is_installed_un
|
||||
IfFileExists "$INSTDIR\DrScheme.exe" plt_is_installed_un
|
||||
IfFileExists "$INSTDIR\collects" plt_is_installed_un
|
||||
MessageBox MB_YESNO "It does not appear that PLT Scheme is installed in '$INSTDIR'.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES plt_is_installed_un
|
||||
IfFileExists "$INSTDIR\Racket.exe" racket_is_installed_un
|
||||
IfFileExists "$INSTDIR\GRacket.exe" racket_is_installed_un
|
||||
IfFileExists "$INSTDIR\DrRacket.exe" racket_is_installed_un
|
||||
IfFileExists "$INSTDIR\collects" racket_is_installed_un
|
||||
MessageBox MB_YESNO "It does not appear that Racket is installed in '$INSTDIR'.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES racket_is_installed_un
|
||||
Abort "Uninstall aborted by user"
|
||||
plt_is_installed_un:
|
||||
racket_is_installed_un:
|
||||
FunctionEnd
|
||||
|
||||
Section "Uninstall"
|
||||
SetShellVarContext all
|
||||
|
||||
SetDetailsPrint both
|
||||
DetailPrint "Removing the PLT Scheme installation..."
|
||||
DetailPrint "Removing the Racket installation..."
|
||||
SetDetailsPrint listonly
|
||||
Delete "$INSTDIR\*.exe"
|
||||
Delete "$INSTDIR\README*.*"
|
||||
|
|
@ -259,7 +262,7 @@ Section "Uninstall"
|
|||
RMDir /r "$INSTDIR\include"
|
||||
RMDir /r "$INSTDIR\lib"
|
||||
RMDir /r "$INSTDIR\doc"
|
||||
;; these exist in PLT-Full installations
|
||||
;; these exist in Racket-Full installations
|
||||
RMDir /r "$INSTDIR\man"
|
||||
RMDir /r "$INSTDIR\src"
|
||||
Delete "${UNINSTEXE}"
|
||||
|
|
@ -267,7 +270,7 @@ Section "Uninstall"
|
|||
;; if the directory is opened, it will take some time to remove
|
||||
Sleep 1000
|
||||
IfErrors +1 uninstall_inst_dir_ok
|
||||
MessageBox MB_YESNO "The PLT Scheme installation at '$INSTDIR' was not completely removed.$\r$\nForce deletion?$\r$\n(Make sure no PLT applications are running.)" /SD IDYES IDNO uninstall_inst_dir_ok
|
||||
MessageBox MB_YESNO "The Racket installation at '$INSTDIR' was not completely removed.$\r$\nForce deletion?$\r$\n(Make sure no Racket applications are running.)" /SD IDYES IDNO uninstall_inst_dir_ok
|
||||
RMDir /r "$INSTDIR"
|
||||
IfErrors +1 uninstall_inst_dir_ok
|
||||
MessageBox MB_OK "Forced deletion did not work either, you will need to clean up '$INSTDIR' manually." /SD IDOK
|
||||
|
|
@ -290,13 +293,16 @@ Section "Uninstall"
|
|||
SetDetailsPrint both
|
||||
DetailPrint "Removing Registry Keys..."
|
||||
SetDetailsPrint listonly
|
||||
DeleteRegKey /ifempty HKLM "Software\${PLTRegName}\Start Menu Folder"
|
||||
DeleteRegKey /ifempty HKLM "Software\${PLTRegName}"
|
||||
DeleteRegKey /ifempty HKLM "Software\${RKTRegName}\Start Menu Folder"
|
||||
DeleteRegKey /ifempty HKLM "Software\${RKTRegName}"
|
||||
DeleteRegKey HKCR ".rkt"
|
||||
DeleteRegKey HKCR ".rktl"
|
||||
DeleteRegKey HKCR ".rktd"
|
||||
DeleteRegKey HKCR ".ss"
|
||||
DeleteRegKey HKCR ".scm"
|
||||
DeleteRegKey HKCR ".scrbl"
|
||||
DeleteRegKey HKCR "Scheme.Document"
|
||||
DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PLTRegName}"
|
||||
DeleteRegKey HKCR "Racket.Document"
|
||||
DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}"
|
||||
|
||||
SetDetailsPrint both
|
||||
DetailPrint "Uninstallation complete."
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 34 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 34 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 201 KiB |
|
Before Width: | Height: | Size: 25 KiB After Width: | Height: | Size: 25 KiB |
BIN
collects/meta/build/nsis/welcome.bmp
Normal file
BIN
collects/meta/build/nsis/welcome.bmp
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 201 KiB |
|
|
@ -1,10 +1,10 @@
|
|||
#!/bin/sh
|
||||
#| -*- scheme -*-
|
||||
tmp="/tmp/path-compare-$$"
|
||||
if [ -x "$PLTHOME/bin/mzscheme" ]; then
|
||||
"$PLTHOME/bin/mzscheme" -r "$0" "$@"
|
||||
if [ -x "$PLTHOME/bin/racket" ]; then
|
||||
"$PLTHOME/bin/racket" -r "$0" "$@"
|
||||
else
|
||||
"mzscheme" -r "$0" "$@"
|
||||
"racket" -r "$0" "$@"
|
||||
fi > "$tmp" || exit 1
|
||||
cd "`dirname \"$0\"`"
|
||||
if diff "paths-configure-snapshot" "$tmp"; then
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ lookfor dirname
|
|||
_POSIX2_VERSION=199209
|
||||
export _POSIX2_VERSION
|
||||
|
||||
origpwd="`pwd`"
|
||||
origwd="`pwd`"
|
||||
|
||||
echo "This program will extract and install $DISTNAME."
|
||||
echo ""
|
||||
|
|
@ -73,23 +73,25 @@ echo "Note: the required diskspace for this installation is about $ORIGSIZE."
|
|||
echo ""
|
||||
echo "Do you want a Unix-style distribution?"
|
||||
echo " In this distribution mode files go into different directories according"
|
||||
echo " to Unix conventions. A \"plt-uninstall\" script will be generated to"
|
||||
echo " make it possible to remove the installation. If say 'no', the whole"
|
||||
echo " PLT directory is kept as a single (movable and erasable) unit, possibly"
|
||||
echo " with external links into it."
|
||||
echo " to Unix conventions. A \"racket-uninstall\" script will be generated"
|
||||
echo " to be used when you want to remove the installation. If you say 'no',"
|
||||
echo " the whole Racket directory is kept in a single installation directory"
|
||||
echo " (movable and erasable) unit, possibly with convenient external links"
|
||||
echo " into it -- this is often more convenient, especially if you want to"
|
||||
echo " install multiple versions or keep it in your home directory."
|
||||
if test ! "x$RELEASED" = "xyes"; then
|
||||
echo "*** This is a nightly build: such a distribution is not recommended"
|
||||
echo "*** because it cannot be used to install multiple versions."
|
||||
echo "*** This is a nightly build: such a unix-style distribution is *not*"
|
||||
echo "*** recommended because it cannot be used to install multiple versions."
|
||||
fi
|
||||
unixstyle="x"
|
||||
while test "$unixstyle" = "x"; do
|
||||
echon "Enter yes/no (default: no) > "
|
||||
read unixstyle
|
||||
case "$unixstyle" in
|
||||
[yY]* ) unixstyle="yes" ;;
|
||||
[nN]* ) unixstyle="no" ;;
|
||||
"" ) unixstyle="no" ;;
|
||||
* ) unixstyle="x" ;;
|
||||
[yY]* ) unixstyle="Y" ;;
|
||||
[nN]* ) unixstyle="N" ;;
|
||||
"" ) unixstyle="N" ;;
|
||||
* ) unixstyle="x" ;;
|
||||
esac
|
||||
done
|
||||
|
||||
|
|
@ -97,11 +99,11 @@ done
|
|||
## Where do you want it?
|
||||
|
||||
echo ""
|
||||
if test "$unixstyle" = "yes"; then
|
||||
if test "$unixstyle" = "Y"; then
|
||||
echo "Where do you want to base your installation of $DISTNAME?"
|
||||
echo " (Use an existing directory. If you've done such an installation in"
|
||||
echo " the past, either use the same place, or manually run"
|
||||
echo " 'plt-uninstaller' now.)"
|
||||
echo " 'racket-uninstall' now.)"
|
||||
TARGET1="..."
|
||||
else
|
||||
echo "Where do you want to install the \"$TARGET\" directory tree?"
|
||||
|
|
@ -109,37 +111,36 @@ else
|
|||
fi
|
||||
echo " 1 - /usr/$TARGET1 [default]"
|
||||
echo " 2 - /usr/local/$TARGET1"
|
||||
echo " 3 - \$HOME/$TARGET1 ($HOME/$TARGET1)"
|
||||
echo " 3 - ~/$TARGET1 ($HOME/$TARGET1)"
|
||||
echo " 4 - ./$TARGET1 (here)"
|
||||
if test "$unixstyle" = "yes"; then
|
||||
if test "$unixstyle" = "Y"; then
|
||||
echo " Or enter a different directory prefix to install in."
|
||||
else
|
||||
echo " Or enter a different \"plt\" directory to install in."
|
||||
echo " Or enter a different \"racket\" directory to install in."
|
||||
fi
|
||||
echon "> "
|
||||
read where
|
||||
case "$where" in
|
||||
"" | "1" ) where="/usr" ;;
|
||||
"2" ) where="/usr/local" ;;
|
||||
"3" ) where="$HOME" ;;
|
||||
"4" | "." ) where="`pwd`" ;;
|
||||
"/"* )
|
||||
if test "$unixstyle" = "no"; then
|
||||
TARGET="`\"$basename\" \"$where\"`"
|
||||
where="`\"$dirname\" \"$where\"`"
|
||||
fi
|
||||
;;
|
||||
* )
|
||||
if test "$unixstyle" = "no"; then
|
||||
TARGET="`\"$basename\" \"$where\"`"
|
||||
where="`\"$dirname\" \"$where\"`"
|
||||
fi
|
||||
if test -d "$where"; then cd "$where"; where="`pwd`"; cd "$origpwd"
|
||||
else where="`pwd`/$where"; fi
|
||||
;;
|
||||
"~/"* ) where="$HOME/${where#\~/}" ;;
|
||||
"~"* ) failwith "cannot use '~user' paths" ;;
|
||||
esac
|
||||
case "$unixstyle$where" in
|
||||
? | ?1 ) where="/usr" ;;
|
||||
?2 ) where="/usr/local" ;;
|
||||
?3 ) where="$HOME" ;;
|
||||
?4 | ?. ) where="`pwd`" ;;
|
||||
N/* ) TARGET="`\"$basename\" \"$where\"`"
|
||||
where="`\"$dirname\" \"$where\"`" ;;
|
||||
Y/* ) ;;
|
||||
N* ) TARGET="`\"$basename\" \"$where\"`"
|
||||
where="`\"$dirname\" \"$where\"`"
|
||||
if test -d "$where"; then cd "$where"; where="`pwd`"; cd "$origwd"
|
||||
else where="`pwd`/$where"; fi ;;
|
||||
Y* ) if test -d "$where"; then cd "$where"; where="`pwd`"; cd "$origwd"
|
||||
else where="`pwd`/$where"; fi ;;
|
||||
esac
|
||||
|
||||
if test "$unixstyle" = "no"; then
|
||||
if test "$unixstyle" = "N"; then
|
||||
# can happen when choosing the root
|
||||
if test "$TARGET" = "/"; then
|
||||
failwith "refusing to remove your root"
|
||||
|
|
@ -169,19 +170,19 @@ set_prefix() {
|
|||
where="$1"
|
||||
# default dirs -- mimic configure behavior
|
||||
bindir="$WHERE1/bin"
|
||||
collectsdir="$WHERE1/lib/plt/collects"
|
||||
if test -d "$WHERE1/share"; then docdir="$WHERE1/share/plt/doc"
|
||||
elif test -d "$WHERE1/doc"; then docdir="$WHERE1/doc/plt"
|
||||
else docdir="$WHERE1/share/plt/doc"
|
||||
collectsdir="$WHERE1/lib/racket/collects"
|
||||
if test -d "$WHERE1/share"; then docdir="$WHERE1/share/racket/doc"
|
||||
elif test -d "$WHERE1/doc"; then docdir="$WHERE1/doc/racket"
|
||||
else docdir="$WHERE1/share/racket/doc"
|
||||
fi
|
||||
libdir="$WHERE1/lib"
|
||||
includepltdir="$WHERE1/include/plt"
|
||||
libpltdir="$WHERE1/lib/plt"
|
||||
includerktdir="$WHERE1/include/racket"
|
||||
librktdir="$WHERE1/lib/racket"
|
||||
mandir="$WHERE1/man"
|
||||
# The source tree is always removed -- no point keeping it if it won't work
|
||||
# if test -d "$WHERE1/share"; then srcdir="$WHERE1/share/plt/src"
|
||||
# elif test -d "$WHERE1/src"; then srcdir="$WHERE1/src/plt"
|
||||
# else srcdir="$WHERE1/share/plt/src"
|
||||
# if test -d "$WHERE1/share"; then srcdir="$WHERE1/share/racket/src"
|
||||
# elif test -d "$WHERE1/src"; then srcdir="$WHERE1/src/racket"
|
||||
# else srcdir="$WHERE1/share/racket/src"
|
||||
# fi
|
||||
}
|
||||
|
||||
|
|
@ -193,11 +194,11 @@ dir_createable() {
|
|||
}
|
||||
|
||||
show_dir_var() {
|
||||
if test -f "$2"; then dir_status="(error: not a directory!)"; err="yes"
|
||||
if test -f "$2"; then dir_status="(error: not a directory!)"; err="Y"
|
||||
elif test ! -d "$2"; then
|
||||
if dir_createable "$2"; then dir_status="(will be created)"
|
||||
else dir_status="(error: not writable!)"; err="yes"; fi
|
||||
elif test ! -w "$2"; then dir_status="(error: not writable!)"; err="yes"
|
||||
else dir_status="(error: not writable!)"; err="Y"; fi
|
||||
elif test ! -w "$2"; then dir_status="(error: not writable!)"; err="Y"
|
||||
else dir_status="(exists)"
|
||||
fi
|
||||
echo " $1 $2 $dir_status"
|
||||
|
|
@ -211,26 +212,26 @@ read_dir() {
|
|||
esac
|
||||
}
|
||||
|
||||
if test "$unixstyle" = "yes"; then
|
||||
if test "$unixstyle" = "Y"; then
|
||||
set_prefix "$where"
|
||||
# loop for possible changes
|
||||
done="no"
|
||||
while test ! "$done" = "yes"; do
|
||||
done="N"
|
||||
while test ! "$done" = "Y"; do
|
||||
echo ""
|
||||
echo "Target Directories:"
|
||||
err="no"
|
||||
err="N"
|
||||
show_dir_var "[e] Executables " "$bindir"
|
||||
show_dir_var "[s] Scheme Code " "$collectsdir"
|
||||
show_dir_var "[d] Core Docs " "$docdir"
|
||||
show_dir_var "[l] C Libraries " "$libdir"
|
||||
show_dir_var "[h] C headers " "$includepltdir"
|
||||
show_dir_var "[o] Extra C Objs " "$libpltdir"
|
||||
show_dir_var "[h] C headers " "$includerktdir"
|
||||
show_dir_var "[o] Extra C Objs " "$librktdir"
|
||||
show_dir_var "[m] Man Pages " "$mandir"
|
||||
if test "$PNAME" = "full"; then
|
||||
echo " (C sources are not kept)"
|
||||
# show_dir_var "[r] Source Tree " "$srcdir"
|
||||
fi
|
||||
if test "$err" = "yes"; then echo "*** Errors in some paths ***"; fi
|
||||
if test "$err" = "Y"; then echo "*** Errors in some paths ***"; fi
|
||||
echo "Enter a new prefix, a letter to change an entry, enter to continue"
|
||||
echon "> "
|
||||
read change_what
|
||||
|
|
@ -239,8 +240,8 @@ if test "$unixstyle" = "yes"; then
|
|||
[sS]* ) echon "New directory: "; collectsdir="`read_dir`" ;;
|
||||
[dD]* ) echon "New directory: "; docdir="`read_dir`" ;;
|
||||
[lL]* ) echon "New directory: "; libdir="`read_dir`" ;;
|
||||
[hH]* ) echon "New directory: "; includepltdir="`read_dir`" ;;
|
||||
[oO]* ) echon "New directory: "; libpltdir="`read_dir`" ;;
|
||||
[hH]* ) echon "New directory: "; includerktdir="`read_dir`" ;;
|
||||
[oO]* ) echon "New directory: "; librktdir="`read_dir`" ;;
|
||||
[mM]* ) echon "New directory: "; mandir="`read_dir`" ;;
|
||||
# [rR]* ) if test "$PNAME" = "full"; then
|
||||
# echon "New directory: "; srcdir="`read_dir`"
|
||||
|
|
@ -248,11 +249,11 @@ if test "$unixstyle" = "yes"; then
|
|||
# echo "Invalid response"
|
||||
# fi ;;
|
||||
"/"* ) set_prefix "$change_what" ;;
|
||||
"" ) done="yes" ;;
|
||||
"" ) done="Y" ;;
|
||||
* ) echo "Invalid response" ;;
|
||||
esac
|
||||
done
|
||||
if test "$err" = "yes"; then failwith "errors in some paths"; fi
|
||||
if test "$err" = "Y"; then failwith "errors in some paths"; fi
|
||||
fi
|
||||
|
||||
###############################################################################
|
||||
|
|
@ -317,7 +318,7 @@ if test -d "bin"; then
|
|||
* ) sysdir="" ;;
|
||||
esac
|
||||
else
|
||||
cd "$origpwd"
|
||||
cd "$origwd"
|
||||
echo ""
|
||||
echo "If you want to install new system links within the bin, lib, include,"
|
||||
echo " man, and doc subdirectories of a common directory prefix (for"
|
||||
|
|
@ -450,13 +451,14 @@ if test -e "$WHERE1/$TARGET"; then
|
|||
esac
|
||||
fi
|
||||
|
||||
if test -x "$bindir/plt-uninstall"; then
|
||||
echo "A previous PLT uninstaller is found at \"$bindir/plt-uninstall\","
|
||||
if test -x "$bindir/racket-uninstall"; then
|
||||
echo "A previous Racket uninstaller is found at"
|
||||
echo " \"$bindir/racket-uninstall\","
|
||||
echon " ok to run it? "
|
||||
read R
|
||||
case "$R" in
|
||||
[yY]* ) echon " running uninstaller..."
|
||||
"$bindir/plt-uninstall" || failwith "problems during uninstall"
|
||||
"$bindir/racket-uninstall" || failwith "problems during uninstall"
|
||||
echo " done." ;;
|
||||
* ) failwith "abort..." ;;
|
||||
esac
|
||||
|
|
@ -465,9 +467,9 @@ fi
|
|||
unpack_installation
|
||||
|
||||
cd "$where"
|
||||
"$TARGET/bin/mzscheme" "$TARGET/collects/setup/unixstyle-install.ss" \
|
||||
"$TARGET/bin/racket" "$TARGET/collects/setup/unixstyle-install.rkt" \
|
||||
"move" "$WHERE1/$TARGET" "$bindir" "$collectsdir" "$docdir" "$libdir" \
|
||||
"$includepltdir" "$libpltdir" "$mandir" \
|
||||
"$includerktdir" "$librktdir" "$mandir" \
|
||||
|| failwith "installation failed"
|
||||
|
||||
}
|
||||
|
|
@ -475,7 +477,7 @@ cd "$where"
|
|||
###############################################################################
|
||||
## Done
|
||||
|
||||
if test "$unixstyle" = "yes"; then unixstyle_install; else wholedir_install; fi
|
||||
if test "$unixstyle" = "Y"; then unixstyle_install; else wholedir_install; fi
|
||||
|
||||
echo ""
|
||||
echo "All done."
|
||||
|
|
@ -87,10 +87,10 @@ else
|
|||
# Set prefix explicitly so we can use it during configure
|
||||
prefix="${ac_default_prefix}"
|
||||
fi
|
||||
libpltdir="${libdir}/plt"
|
||||
collectsdir="${libdir}/plt/collects"
|
||||
includepltdir="${includedir}/plt"
|
||||
docdir="${datadir}/plt/doc"
|
||||
libpltdir="${libdir}/racket"
|
||||
collectsdir="${libdir}/racket/collects"
|
||||
includepltdir="${includedir}/racket"
|
||||
docdir="${datadir}/racket/doc"
|
||||
MAKE_COPYTREE=copytree
|
||||
COLLECTS_PATH='${collectsdir}'
|
||||
INSTALL_ORIG_TREE=no
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
(drdr-directory "/opt/svn/drdr")
|
||||
(git-path "/usr/bin/git")
|
||||
(Xvfb-path "/usr/bin/Xvfb")
|
||||
(fluxbox-path "/usr/bin/fluxbox"))
|
||||
(current-make-install-timeout-seconds (* 90 60))
|
||||
(current-make-timeout-seconds (* 90 60))
|
||||
(current-subprocess-timeout-seconds 90)
|
||||
|
|
|
|||
|
|
@ -83,6 +83,11 @@
|
|||
(define (path-timing-png-prefix p)
|
||||
(path-timing-log p))
|
||||
|
||||
(define build? (make-parameter #t))
|
||||
|
||||
(define (on-unix?)
|
||||
(symbol=? 'unix (system-type 'os)))
|
||||
|
||||
(provide/contract
|
||||
[current-subprocess-timeout-seconds (parameter/c exact-nonnegative-integer?)]
|
||||
[number-of-cpus (parameter/c exact-nonnegative-integer?)]
|
||||
|
|
@ -93,9 +98,11 @@
|
|||
[plt-data-directory (-> path?)]
|
||||
[plt-future-build-directory (-> path?)]
|
||||
[drdr-directory (parameter/c path-string?)]
|
||||
[make-path (parameter/c string?)]
|
||||
[Xvfb-path (parameter/c string?)]
|
||||
[fluxbox-path (parameter/c string?)]
|
||||
[make-path (parameter/c (or/c false/c string?))]
|
||||
[Xvfb-path (parameter/c (or/c false/c string?))]
|
||||
[fluxbox-path (parameter/c (or/c false/c string?))]
|
||||
[build? (parameter/c boolean?)]
|
||||
[on-unix? (-> boolean?)]
|
||||
[plt-repository (-> path?)]
|
||||
[path-timing-log (path-string? . -> . path?)]
|
||||
[path-timing-png (path-string? . -> . path?)]
|
||||
|
|
|
|||
115
collects/meta/drdr/house-call.ss
Normal file
115
collects/meta/drdr/house-call.ss
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
#lang racket
|
||||
(require racket/runtime-path
|
||||
racket/date
|
||||
"list-count.ss"
|
||||
"scm.ss"
|
||||
"formats.ss"
|
||||
"cache.ss"
|
||||
"metadata.ss"
|
||||
"analyze.ss"
|
||||
"rendering.ss"
|
||||
"plt-build.ss"
|
||||
"status.ss"
|
||||
"replay.ss"
|
||||
"notify.ss"
|
||||
"path-utils.ss"
|
||||
"dirstruct.ss")
|
||||
|
||||
(build? #f)
|
||||
|
||||
(define show-log
|
||||
(command-line #:program "house-call"
|
||||
#:once-each
|
||||
[("-j" "--jobs") jobs "How many processes to run simultaneously" (number-of-cpus (string->number jobs))]
|
||||
["--build" "Build the source first" (build? #t)]
|
||||
#:args log-to-view
|
||||
log-to-view))
|
||||
|
||||
; Find paths we need
|
||||
(define (path->string^ p)
|
||||
(and p (path->string p)))
|
||||
|
||||
(git-path (path->string^ (find-executable-path "git")))
|
||||
(Xvfb-path (and (on-unix?) (path->string^ (find-executable-path "Xvfb"))))
|
||||
(fluxbox-path (and (on-unix?) (path->string^ (find-executable-path "fluxbox"))))
|
||||
|
||||
; Find where we are
|
||||
(define-runtime-path here ".")
|
||||
(drdr-directory here)
|
||||
(define this-rev-dir (build-path here 'up 'up 'up))
|
||||
|
||||
; Setup directories that DrDr needs
|
||||
(define (make-file-or-directory-link* from to)
|
||||
(unless (link-exists? to)
|
||||
(make-file-or-directory-link from to)))
|
||||
|
||||
(define house-calls (build-path this-rev-dir "house-calls"))
|
||||
(plt-directory house-calls)
|
||||
(for ([d (in-list (list "builds" "future-builds" "data"))])
|
||||
(make-directory* (build-path house-calls d)))
|
||||
|
||||
(make-file-or-directory-link* this-rev-dir (build-path house-calls "repo"))
|
||||
(make-file-or-directory-link* this-rev-dir (build-path house-calls "plt"))
|
||||
|
||||
; Make up a revision and link it in
|
||||
(define fake-rev (date->julian/scalinger (current-date)))
|
||||
(current-rev fake-rev)
|
||||
(define fake-trunk (revision-trunk-dir fake-rev))
|
||||
(make-parent-directory fake-trunk)
|
||||
(make-file-or-directory-link* this-rev-dir fake-trunk)
|
||||
(write-cache! (revision-commit-msg fake-rev)
|
||||
(make-git-push fake-rev "you!" empty))
|
||||
|
||||
; Override the props file
|
||||
(hash-set! props-cache fake-rev
|
||||
(dynamic-require `(file ,(path->string (build-path this-rev-dir "collects" "meta" "props")))
|
||||
'get-prop))
|
||||
|
||||
; Setup the logger
|
||||
(void
|
||||
(thread
|
||||
(lambda ()
|
||||
(define recv (make-log-receiver (current-logger) 'info))
|
||||
(let loop ()
|
||||
(match-define (vector level msg val) (sync recv))
|
||||
(display msg) (newline)
|
||||
(loop)))))
|
||||
|
||||
; Do it!
|
||||
(notify! "DrDr is making a house call...")
|
||||
(integrate-revision fake-rev)
|
||||
|
||||
(define re (rebase-path (revision-log-dir fake-rev) "/"))
|
||||
(define (print-lc label lc)
|
||||
(define l (lc->list lc))
|
||||
(unless (empty? l)
|
||||
(printf "~a:\n" label)
|
||||
(for ([bs (in-list l)])
|
||||
(printf "\t~a\n"
|
||||
(substring (path->string* (re (bytes->path bs))) 1)))
|
||||
(newline)))
|
||||
|
||||
(match (analyze-logs fake-rev)
|
||||
[(struct rendering (start end duration timeout unclean stderr _ _))
|
||||
|
||||
(print-lc "Timeout" timeout)
|
||||
(print-lc "Unclean Exit" unclean)
|
||||
(print-lc "STDERR Output" stderr)
|
||||
|
||||
(printf "Duration (Abs): ~a\n"
|
||||
(format-duration-ms (- end start)))
|
||||
(printf "Duration (Sum): ~a\n"
|
||||
(format-duration-ms duration))]
|
||||
[#f
|
||||
(void)])
|
||||
|
||||
(for ([p (in-list show-log)])
|
||||
(define lp (build-path (revision-log-dir fake-rev) p))
|
||||
(match (read-cache lp)
|
||||
[(? status? s)
|
||||
(newline)
|
||||
(printf "Replaying ~a:\n" p)
|
||||
(printf "~a\n" (regexp-replace* #rx"<current-rev>" (apply string-append (add-between (status-command-line s) " ")) (number->string fake-rev)))
|
||||
(replay-status s)]
|
||||
[x
|
||||
(printf "Could not get ~a's log; got: ~s\n" p x)]))
|
||||
|
|
@ -48,6 +48,7 @@
|
|||
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])
|
||||
|
||||
;;; Property lookup
|
||||
(provide props-cache)
|
||||
(define props-cache (make-hasheq))
|
||||
(define (get-prop a-fs-path prop [def #f] #:as-string? [as-string? #f])
|
||||
(define rev (current-rev))
|
||||
|
|
|
|||
|
|
@ -95,43 +95,45 @@
|
|||
(call-with-temporary-home-directory (lambda () e)))
|
||||
|
||||
(define (with-running-program command args thunk)
|
||||
(define-values (new-command new-args)
|
||||
(command+args+env->command+args
|
||||
#:env (current-env)
|
||||
command args))
|
||||
(define-values
|
||||
(the-process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
#f #;(current-error-port)
|
||||
#f
|
||||
#f #;(current-error-port)
|
||||
new-command new-args))
|
||||
; Die if this program does
|
||||
(define parent
|
||||
(current-thread))
|
||||
(define waiter
|
||||
(thread
|
||||
(lambda ()
|
||||
(subprocess-wait the-process)
|
||||
(printf "Killing parent because wrapper is dead...~n")
|
||||
(kill-thread parent))))
|
||||
|
||||
; Run without stdin
|
||||
(close-output-port stdin)
|
||||
|
||||
(begin0
|
||||
; Run the thunk
|
||||
(thunk)
|
||||
|
||||
; Close the output ports
|
||||
(close-input-port stdout)
|
||||
(close-input-port stderr)
|
||||
|
||||
; Kill the guard
|
||||
(kill-thread waiter)
|
||||
|
||||
; Kill the process
|
||||
(subprocess-kill the-process #t)))
|
||||
(if command
|
||||
(local [(define-values (new-command new-args)
|
||||
(command+args+env->command+args
|
||||
#:env (current-env)
|
||||
command args))
|
||||
(define-values
|
||||
(the-process stdout stdin stderr)
|
||||
(apply subprocess
|
||||
#f #;(current-error-port)
|
||||
#f
|
||||
#f #;(current-error-port)
|
||||
new-command new-args))
|
||||
; Die if this program does
|
||||
(define parent
|
||||
(current-thread))
|
||||
(define waiter
|
||||
(thread
|
||||
(lambda ()
|
||||
(subprocess-wait the-process)
|
||||
(printf "Killing parent because wrapper is dead...~n")
|
||||
(kill-thread parent))))]
|
||||
|
||||
; Run without stdin
|
||||
(close-output-port stdin)
|
||||
|
||||
(begin0
|
||||
; Run the thunk
|
||||
(thunk)
|
||||
|
||||
; Close the output ports
|
||||
(close-input-port stdout)
|
||||
(close-input-port stderr)
|
||||
|
||||
; Kill the guard
|
||||
(kill-thread waiter)
|
||||
|
||||
; Kill the process
|
||||
(subprocess-kill the-process #t)))
|
||||
(thunk)))
|
||||
|
||||
(define-runtime-path package-list "pkgs")
|
||||
(define (planet-packages)
|
||||
|
|
@ -193,7 +195,10 @@
|
|||
[(list-rest (or 'mred 'mred-text
|
||||
'gracket 'gracket-text)
|
||||
rst)
|
||||
(lambda () (list* gracket-text-path "-display" (format ":~a" (+ XSERVER-OFFSET (current-worker))) rst))]
|
||||
(if (on-unix?)
|
||||
(lambda ()
|
||||
(list* gracket-text-path "-display" (format ":~a" (+ XSERVER-OFFSET (current-worker))) rst))
|
||||
#f)]
|
||||
[_
|
||||
#f]))]
|
||||
(if pth-cmd
|
||||
|
|
@ -287,7 +292,8 @@
|
|||
(unless (read-cache* (revision-commit-msg rev))
|
||||
(write-cache! (revision-commit-msg rev)
|
||||
(get-scm-commit-msg rev (plt-repository))))
|
||||
(build-revision rev)
|
||||
(when (build?)
|
||||
(build-revision rev))
|
||||
(recur-many (number-of-cpus)
|
||||
(lambda (j inner)
|
||||
(define i (+ j XSERVER-OFFSET))
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@
|
|||
[pat subst]
|
||||
...)
|
||||
s)
|
||||
(regexp-replace* pat0
|
||||
(regexp-replace* (regexp-quote pat0)
|
||||
(regexp-replace** ([pat subst] ...) s)
|
||||
subst0)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
#|
|
||||
|
||||
This library is the part of the 2htdp/image
|
||||
teachpack that has to be shared between drscheme
|
||||
teachpack that has to be shared between drracket
|
||||
and the user's program to make copy and paste
|
||||
work right.
|
||||
|
||||
|
|
@ -26,11 +26,11 @@ has been moved out).
|
|||
|
||||
|#
|
||||
|
||||
(require scheme/class
|
||||
scheme/gui/base
|
||||
scheme/math
|
||||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/math
|
||||
"private/image-core-bitmap.ss"
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define-for-syntax id-constructor-pairs '())
|
||||
(define-for-syntax (add-id-constructor-pair a b)
|
||||
|
|
@ -317,7 +317,7 @@ has been moved out).
|
|||
(and (= (round (bb-right bb1)) (round (bb-right bb2)))
|
||||
(= (round (bb-bottom bb1)) (round (bb-bottom bb2)))
|
||||
(= (round (bb-baseline bb1)) (round (bb-baseline bb2)))))
|
||||
(define scheme/base:read read)
|
||||
(define racket/base:read read)
|
||||
|
||||
(define image-snipclass%
|
||||
(class snip-class%
|
||||
|
|
@ -331,7 +331,7 @@ has been moved out).
|
|||
(and str
|
||||
(with-handlers ((exn:fail:read? (λ (x) #f)))
|
||||
(parse
|
||||
(scheme/base:read
|
||||
(racket/base:read
|
||||
(open-input-string
|
||||
str)))))])
|
||||
(if lst
|
||||
|
|
|
|||
24
collects/mrlib/scribblings/image-core.scrbl
Normal file
24
collects/mrlib/scribblings/image-core.scrbl
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.ss")
|
||||
|
||||
@title{Image Core}
|
||||
|
||||
@defmodule[mrlib/image-core]
|
||||
|
||||
This library is the core part of the @racketmodname[2htdp/image] library that DrRacket
|
||||
links into the namespace of all languages that it runs. This ensures that minimal
|
||||
support for these images are the same in all languages, specifically including
|
||||
support for printing the images and constructing the core data structures making
|
||||
up an image.
|
||||
|
||||
@defproc[(render-image [image image?]
|
||||
[dc (is-a?/c dc<%>)]
|
||||
[dx number?]
|
||||
[dy number?])
|
||||
void?]{
|
||||
Draws @racket[image] in @racket[dc] at the position (@racket[dx],@racket[dy]).
|
||||
}
|
||||
|
||||
@defproc[(image? [v any/c]) boolean?]{
|
||||
Recognizes the images that library handles.
|
||||
}
|
||||
|
|
@ -18,6 +18,7 @@
|
|||
@include-section["path-dialog.scrbl"]
|
||||
@include-section["plot.scrbl"]
|
||||
@include-section["switchable-button.scrbl"]
|
||||
@include-section["image-core.scrbl"]
|
||||
@include-section["tex-table.scrbl"]
|
||||
|
||||
@section{Acknowledgments}
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
(provide/contract
|
||||
[current-date (-> date?)]
|
||||
[date->seconds (date? . -> . exact-integer?)]
|
||||
[date->string ((date?) (boolean?) . ->* . string?)]
|
||||
[date->string ((date?) (any/c) . ->* . string?)]
|
||||
[date-display-format (parameter/c (symbols 'american 'chinese 'german 'indian 'irish 'julian 'iso-8601 'rfc2822))]
|
||||
[find-seconds ((integer-in 0 61)
|
||||
(integer-in 0 59)
|
||||
|
|
|
|||
|
|
@ -172,10 +172,7 @@ v4 todo:
|
|||
(if (->-dom-rest/c ctc)
|
||||
(procedure-accepts-and-more? x l)
|
||||
(procedure-arity-includes? x l))
|
||||
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
|
||||
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
|
||||
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
|
||||
(->-mandatory-kwds ctc))))
|
||||
(keywords-match (->-mandatory-kwds ctc) (->-optional-kwds ctc) x)
|
||||
#t))))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
|
|
@ -1541,9 +1538,13 @@ v4 todo:
|
|||
(andmap (λ (kwd) (member kwd mandatory-kwds))
|
||||
proc-mandatory)
|
||||
;; proc accepts (but does not require) ctc's optional keywords
|
||||
(andmap (λ (kwd) (and (member kwd proc-all)
|
||||
(not (member kwd proc-mandatory))))
|
||||
optional-kwds))))
|
||||
;;
|
||||
;; if proc-all is #f, then proc accepts all keywords and thus
|
||||
;; this is triviably true (e.g. result of make-keyword-procedure)
|
||||
(or (not proc-all)
|
||||
(andmap (λ (kwd) (and (member kwd proc-all)
|
||||
(not (member kwd proc-mandatory))))
|
||||
optional-kwds)))))
|
||||
|
||||
(define (keyword-error-text mandatory-keywords optional-keywords)
|
||||
(define (format-keywords-error type kwds)
|
||||
|
|
|
|||
|
|
@ -175,11 +175,17 @@
|
|||
[certifier (sequence-transformer-ref m 2)])
|
||||
(let ([xformed (xformer (introducer (syntax-local-introduce clause)))])
|
||||
(if xformed
|
||||
(expand-clause orig-stx (certify-clause (syntax-case clause ()
|
||||
(let ([r (expand-clause orig-stx
|
||||
(certify-clause (syntax-case clause ()
|
||||
[(_ rhs) #'rhs])
|
||||
(syntax-local-introduce (introducer xformed))
|
||||
certifier
|
||||
introducer))
|
||||
introducer))])
|
||||
(syntax-property r
|
||||
'disappeared-use
|
||||
(cons (syntax-local-introduce #'form)
|
||||
(or (syntax-property r 'disappeared-use)
|
||||
null))))
|
||||
(eloop #f)))))]
|
||||
[[(id ...) (:do-in . body)]
|
||||
(syntax-case #'body ()
|
||||
|
|
@ -809,8 +815,12 @@
|
|||
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...)
|
||||
(clause . rest) . body)
|
||||
(with-syntax ([bind (expand-clause #'orig-stx #'clause)])
|
||||
#`(frm [orig-stx nested? nested? (bind . binds)]
|
||||
([fold-var fold-init] ...) rest . body))]
|
||||
(let ([r #`(frm [orig-stx nested? nested? (bind . binds)]
|
||||
([fold-var fold-init] ...) rest . body)]
|
||||
[d (syntax-property #'bind 'disappeared-use)])
|
||||
(if d
|
||||
(syntax-property r 'disappeared-use d)
|
||||
r)))]
|
||||
[(_ [orig-stx . _] . _)
|
||||
(raise-syntax-error #f "bad syntax" #'orig-stx)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -226,7 +226,9 @@
|
|||
(case-lambda
|
||||
[(doc s)
|
||||
(if doc
|
||||
(list (module-path-prefix->string doc) s)
|
||||
(if (list? s)
|
||||
(cons (module-path-prefix->string doc) s)
|
||||
(list (module-path-prefix->string doc) s))
|
||||
s)]
|
||||
[(doc prefix s)
|
||||
(doc-prefix doc (if prefix
|
||||
|
|
|
|||
|
|
@ -271,8 +271,11 @@ instead of interleaving them.}
|
|||
|
||||
@defproc[(open-output-nowhere [name any/c 'nowhere] [special-ok? any/c #t])
|
||||
output-port?]{
|
||||
|
||||
Creates and returns an output port that discards all output sent to it
|
||||
@index*['("discard-output" "null-output" "null-output-port" "dev-null"
|
||||
"/dev/null")
|
||||
'("Opening a null output port")]{
|
||||
|
||||
Creates} and returns an output port that discards all output sent to it
|
||||
(without blocking). The @scheme[name] argument is used as the port's
|
||||
name. If the @scheme[special-ok?] argument is true, then the
|
||||
resulting port supports @scheme[write-special], otherwise it does not.}
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/gui
|
||||
#lang racket/gui
|
||||
|
||||
;; Run this file is generate the images in the img/ directory,
|
||||
;; picked up by image-examples from image.scrbl
|
||||
|
||||
(require 2htdp/image
|
||||
lang/posn
|
||||
scheme/runtime-path)
|
||||
racket/runtime-path)
|
||||
|
||||
(define-runtime-path image.scrbl "image.scrbl")
|
||||
(define-runtime-path img "img")
|
||||
|
|
@ -103,9 +103,9 @@
|
|||
(printf "image-gen: didn't find any images; probably this means that you need to delete .zo files and try again\n")]
|
||||
[else
|
||||
(printf "\n")
|
||||
(call-with-output-file "image-toc.ss"
|
||||
(call-with-output-file "image-toc.rkt"
|
||||
(λ (port)
|
||||
(fprintf port "#lang scheme/base\n(provide mapping)\n")
|
||||
(fprintf port "#lang racket/base\n(provide mapping)\n")
|
||||
(fprintf port ";; this file is generated by image-gen.ss -- do not edit\n;; note that the file that creates this file depends on this file\n;; it is always safe to simply define (and provide) mapping as the empty list\n\n")
|
||||
(pretty-print
|
||||
`(define mapping (list ,@mapping))
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
(list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
|
||||
(list '(image-height (text "Hello" 24 "black")) 'val 24)
|
||||
(list '(image-baseline (text "Hello" 24 "black")) 'val 18)
|
||||
(list '(image-height (rectangle 10 0 "solid" "purple")) 'val 0)
|
||||
(list
|
||||
'(image-height
|
||||
(overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
|
||||
|
|
@ -17,6 +18,7 @@
|
|||
60)
|
||||
(list '(image-height (circle 30 "solid" "orange")) 'val 60)
|
||||
(list '(image-height (ellipse 30 40 "solid" "orange")) 'val 40)
|
||||
(list '(image-width (rectangle 0 10 "solid" "purple")) 'val 0)
|
||||
(list
|
||||
'(image-width
|
||||
(beside (circle 20 "solid" "orange") (circle 20 "solid" "purple")))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require scribble/base
|
||||
scribble/core
|
||||
scribble/manual
|
||||
scribble/scheme
|
||||
(for-syntax scheme/base)
|
||||
scribble/racket
|
||||
(for-syntax racket/base)
|
||||
"image-toc.ss")
|
||||
|
||||
(provide image-examples)
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
(for-each (λ (exp) (printf "~s\n" (syntax->datum exp)))
|
||||
(syntax->list #'(exp ...))))
|
||||
#'(interleave
|
||||
(list (schemeinput exp) ...)
|
||||
(list (racketinput exp) ...)
|
||||
(list 'exp ...))]))
|
||||
|
||||
(define (interleave expr-paras val-list+outputs)
|
||||
|
|
@ -33,10 +33,10 @@
|
|||
(let ([line (exp->line exp)])
|
||||
(case (car line)
|
||||
[(val)
|
||||
(schemeblock #,(schemeresult #,(cadr line)))]
|
||||
(racketblock #,(racketresult #,(cadr line)))]
|
||||
[(image)
|
||||
(let ([fn (format "2htdp/scribblings/img/~a" (cadr line))])
|
||||
(schemeblock #,(image fn)))]
|
||||
(racketblock #,(image fn)))]
|
||||
[(missing)
|
||||
(make-paragraph
|
||||
error-color
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scribble/doc
|
||||
|
||||
@(require (for-label (only-in scheme/contract and/c or/c any/c not/c)
|
||||
@(require (for-label (only-in racket/contract and/c or/c any/c not/c)
|
||||
2htdp/image
|
||||
(except-in lang/htdp-beginner make-posn posn? posn-x posn-y image?)
|
||||
lang/posn
|
||||
scheme/gui/base
|
||||
(only-in scheme/base path-string?))
|
||||
racket/gui/base
|
||||
(only-in racket/base path-string?))
|
||||
lang/posn
|
||||
"shared.ss"
|
||||
"image-util.ss"
|
||||
|
|
@ -16,10 +16,10 @@
|
|||
|
||||
@(define mode/color-text
|
||||
(make-splice
|
||||
@list{If the @scheme[mode] is @scheme['outline] or @scheme["outline"], then the last
|
||||
argument can be a @scheme[pen] struct or an @scheme[image-color?], but if the @scheme[mode]
|
||||
is @scheme['solid] or @scheme["solid"], then the last argument must be an
|
||||
@scheme[image-color?].}))
|
||||
@list{If the @racket[mode] is @racket['outline] or @racket["outline"], then the last
|
||||
argument can be a @racket[pen] struct or an @racket[image-color?], but if the @racket[mode]
|
||||
is @racket['solid] or @racket["solid"], then the last argument must be an
|
||||
@racket[image-color?].}))
|
||||
|
||||
@defmodule[#:require-form beginner-require 2htdp/image]
|
||||
|
||||
|
|
@ -76,7 +76,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
image?])]{
|
||||
|
||||
Constructs a upward-pointing equilateral triangle.
|
||||
The @scheme[side-length] argument
|
||||
The @racket[side-length] argument
|
||||
determines the
|
||||
length of the side of the triangle.
|
||||
|
||||
|
|
@ -98,7 +98,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
image?])]{
|
||||
|
||||
Constructs a triangle with a right angle where the two sides adjacent
|
||||
to the right angle have lengths @scheme[side-length1] and @scheme[side-length2].
|
||||
to the right angle have lengths @racket[side-length1] and @racket[side-length2].
|
||||
|
||||
@mode/color-text
|
||||
|
||||
|
|
@ -116,10 +116,10 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
[pen-or-color (or/c pen? image-color?)])
|
||||
image?])]{
|
||||
|
||||
Creates a triangle with two equal-length sides, of length @scheme[side-length]
|
||||
where the angle between those sides is @scheme[angle]. The third
|
||||
Creates a triangle with two equal-length sides, of length @racket[side-length]
|
||||
where the angle between those sides is @racket[angle]. The third
|
||||
leg is straight, horizontally. If the angle is less than
|
||||
@scheme[180], then the triangle will point up and if the @scheme[angle]
|
||||
@racket[180], then the triangle will point up and if the @racket[angle]
|
||||
is more, then the triangle will point down.
|
||||
|
||||
@mode/color-text
|
||||
|
|
@ -178,7 +178,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
|
|||
image?])]{
|
||||
|
||||
Constructs a four sided polygon with all equal sides and thus where opposite angles are equal to each
|
||||
other. The top and bottom pair of angles is @scheme[angle] and the left and right are @scheme[(- 180 angle)].
|
||||
other. The top and bottom pair of angles is @racket[angle] and the left and right are @racket[(- 180 angle)].
|
||||
|
||||
@mode/color-text
|
||||
|
||||
|
|
@ -196,7 +196,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
[outline-mode (or/c 'outline "outline")]
|
||||
[pen-or-color (or/c pen? image-color?)])
|
||||
image?])]{
|
||||
Constructs a regular polygon with @scheme[side-count] sides.
|
||||
Constructs a regular polygon with @racket[side-count] sides.
|
||||
|
||||
@mode/color-text
|
||||
|
||||
|
|
@ -213,7 +213,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
[outline-mode (or/c 'outline "outline")]
|
||||
[color (or/c pen? image-color?)])
|
||||
image?])]{
|
||||
Constructs a star with five points. The @scheme[side-length] argument
|
||||
Constructs a star with five points. The @racket[side-length] argument
|
||||
determines the side length of the enclosing pentagon.
|
||||
|
||||
@mode/color-text
|
||||
|
|
@ -236,12 +236,12 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
image?])]{
|
||||
|
||||
Constructs an arbitrary regular star polygon (a generalization of the regular polygons).
|
||||
The polygon is enclosed by a regular polygon with @scheme[side-count] sides each
|
||||
@scheme[side-length] long. The polygon is actually constructed by going from vertex to
|
||||
vertex around the regular polgon, but skipping over every @scheme[step-count] vertices.
|
||||
The polygon is enclosed by a regular polygon with @racket[side-count] sides each
|
||||
@racket[side-length] long. The polygon is actually constructed by going from vertex to
|
||||
vertex around the regular polgon, but skipping over every @racket[step-count] vertices.
|
||||
|
||||
For examples, if @scheme[side-count] is @scheme[5] and @scheme[step-count] is @scheme[2],
|
||||
then this function produces a shape just like @scheme[star].
|
||||
For examples, if @racket[side-count] is @racket[5] and @racket[step-count] is @racket[2],
|
||||
then this function produces a shape just like @racket[star].
|
||||
|
||||
@mode/color-text
|
||||
|
||||
|
|
@ -300,7 +300,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
(make-pen "darkslategray" 10 "solid" "projecting" "miter")))]
|
||||
}
|
||||
|
||||
@defproc[(line [x1 real?] [y1 real?] [color image-color?]) image?]{
|
||||
@defproc[(line [x1 real?] [y1 real?] [pen-or-color (or/c pen? image-color?)]) image?]{
|
||||
Constructs an image representing a line segment that connects the points
|
||||
(0,0) to (x1,y1).
|
||||
|
||||
|
|
@ -312,12 +312,12 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
@defproc[(add-line [image image?]
|
||||
[x1 real?] [y1 real?]
|
||||
[x2 real?] [y2 real?]
|
||||
[color image-color?])
|
||||
[pen-or-color (or/c pen? image-color?)])
|
||||
image?]{
|
||||
|
||||
Adds a line to the image @scheme[image], starting from the point (@scheme[x1],@scheme[y1])
|
||||
and going to the point (@scheme[x2],@scheme[y2]).
|
||||
Unlike @scheme[scene+line], if the line passes outside of @scheme[image], the image
|
||||
Adds a line to the image @racket[image], starting from the point (@racket[x1],@racket[y1])
|
||||
and going to the point (@racket[x2],@racket[y2]).
|
||||
Unlike @racket[scene+line], if the line passes outside of @racket[image], the image
|
||||
gets larger to accomodate the line.
|
||||
|
||||
@image-examples[(add-line (ellipse 40 40 "outline" "maroon")
|
||||
|
|
@ -333,22 +333,22 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
|
|||
@defproc[(add-curve [image image?]
|
||||
[x1 real?] [y1 real?] [angle1 angle?] [pull1 real?]
|
||||
[x2 real?] [y2 real?] [angle2 angle?] [pull2 real?]
|
||||
[color image-color?])
|
||||
[pen-or-color (or/c pen? image-color?)])
|
||||
image?]{
|
||||
|
||||
Adds a curve to @scheme[image], starting at the point
|
||||
(@scheme[x1],@scheme[y1]), and ending at the point
|
||||
(@scheme[x2],@scheme[y2]).
|
||||
Adds a curve to @racket[image], starting at the point
|
||||
(@racket[x1],@racket[y1]), and ending at the point
|
||||
(@racket[x2],@racket[y2]).
|
||||
|
||||
The @scheme[angle1] and @scheme[angle2] arguments specify the
|
||||
The @racket[angle1] and @racket[angle2] arguments specify the
|
||||
angle that the curve has as it leaves the initial point and
|
||||
as it reaches the final point, respectively.
|
||||
|
||||
The @scheme[pull1] and @scheme[pull2] arguments control how
|
||||
The @racket[pull1] and @racket[pull2] arguments control how
|
||||
long the curve tries to stay with that angle. Larger numbers
|
||||
mean that the curve stays with the angle longer.
|
||||
|
||||
Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the image
|
||||
Unlike @racket[scene+curve], if the line passes outside of @racket[image], the image
|
||||
gets larger to accomodate the curve.
|
||||
|
||||
|
||||
|
|
@ -395,12 +395,12 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
|
||||
Constructs an image that draws the given string, using a complete font specification.
|
||||
|
||||
The @scheme[face] and the @scheme[family] combine to give the complete typeface. If
|
||||
@scheme[face] is available on the system, it is used, but if not then a default typeface
|
||||
based on the @scheme[family] is chosen. The @scheme[style] controls if the face is italic
|
||||
or not (under Windows and Mac OS X, @scheme['slant] and @scheme['italic] are the same),
|
||||
the @scheme[weight] controls if it is boldface (or light), and @scheme[underline?]
|
||||
determines if the face is underlined. For more details on these arguments, see @scheme[font%],
|
||||
The @racket[face] and the @racket[family] combine to give the complete typeface. If
|
||||
@racket[face] is available on the system, it is used, but if not then a default typeface
|
||||
based on the @racket[family] is chosen. The @racket[style] controls if the face is italic
|
||||
or not (under Windows and Mac OS X, @racket['slant] and @racket['italic] are the same),
|
||||
the @racket[weight] controls if it is boldface (or light), and @racket[underline?]
|
||||
determines if the face is underlined. For more details on these arguments, see @racket[font%],
|
||||
which ultimately is what this code uses to draw the font.
|
||||
|
||||
@image-examples[(text/font "Hello" 24 "olive"
|
||||
|
|
@ -415,7 +415,7 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
([bitmap-spec rel-string
|
||||
id])]{
|
||||
|
||||
Loads the bitmap specified by @scheme[bitmap-spec]. If @scheme[bitmap-spec] is a string, it is treated as a
|
||||
Loads the bitmap specified by @racket[bitmap-spec]. If @racket[bitmap-spec] is a string, it is treated as a
|
||||
relative path. If it is an identifier, it is treated like a require spec and used to refer to a file
|
||||
in a collection.
|
||||
|
||||
|
|
@ -447,9 +447,9 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
}
|
||||
|
||||
@defproc[(overlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
Overlays all of its image arguments, much like the @scheme[overlay] function, but using
|
||||
@scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if
|
||||
@scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up
|
||||
Overlays all of its image arguments, much like the @racket[overlay] function, but using
|
||||
@racket[x-place] and @racket[y-place] to determine where the images are lined up. For example, if
|
||||
@racket[x-place] and @racket[y-place] are both @racket["middle"], then the images are lined up
|
||||
on their centers.
|
||||
|
||||
@image-examples[(overlay/align "left" "middle"
|
||||
|
|
@ -465,8 +465,8 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
}
|
||||
|
||||
@defproc[(overlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{
|
||||
Constructs an image by overlaying @scheme[i1] on top of @scheme[i2] after
|
||||
shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y]
|
||||
Constructs an image by overlaying @racket[i1] on top of @racket[i2] after
|
||||
shifting @racket[i2] over by @racket[x] pixels to the right and @racket[y]
|
||||
pixels down.
|
||||
@image-examples[(overlay/xy (rectangle 20 20 "outline" "black")
|
||||
20 0
|
||||
|
|
@ -490,7 +490,7 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
@defproc[(underlay [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
Underlays all of its arguments building a single image.
|
||||
|
||||
It behaves like @scheme[overlay], but with the arguments in the reverse order.
|
||||
It behaves like @racket[overlay], but with the arguments in the reverse order.
|
||||
That is, the first argument goes
|
||||
underneath of the second argument, which goes underneath the third argument, etc.
|
||||
The images are all lined up on their centers.
|
||||
|
|
@ -507,9 +507,9 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
}
|
||||
|
||||
@defproc[(underlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
Underlays all of its image arguments, much like the @scheme[underlay] function, but using
|
||||
@scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if
|
||||
@scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up
|
||||
Underlays all of its image arguments, much like the @racket[underlay] function, but using
|
||||
@racket[x-place] and @racket[y-place] to determine where the images are lined up. For example, if
|
||||
@racket[x-place] and @racket[y-place] are both @racket["middle"], then the images are lined up
|
||||
on their centers.
|
||||
|
||||
@image-examples[(underlay/align "left" "middle"
|
||||
|
|
@ -525,11 +525,11 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
}
|
||||
|
||||
@defproc[(underlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{
|
||||
Constructs an image by underlaying @scheme[i1] underneath of @scheme[i2] after
|
||||
shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y]
|
||||
Constructs an image by underlaying @racket[i1] underneath of @racket[i2] after
|
||||
shifting @racket[i2] over by @racket[x] pixels to the right and @racket[y]
|
||||
pixels down.
|
||||
|
||||
This is the same as @scheme[(overlay/xy i2 (- x) (- y) i1)].
|
||||
This is the same as @racket[(overlay/xy i2 (- x) (- y) i1)].
|
||||
|
||||
@image-examples[(underlay/xy (rectangle 20 20 "outline" "black")
|
||||
20 0
|
||||
|
|
@ -565,8 +565,8 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
|
||||
@defproc[(beside/align [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
Constructs an image by placing all of the argument images in a horizontal row, lined
|
||||
up as indicated by the @scheme[y-place] argument. For example, if @scheme[y-place]
|
||||
is @scheme["middle"], then the images are placed side by side with their centers
|
||||
up as indicated by the @racket[y-place] argument. For example, if @racket[y-place]
|
||||
is @racket["middle"], then the images are placed side by side with their centers
|
||||
lined up with each other.
|
||||
|
||||
@image-examples[(beside/align "bottom"
|
||||
|
|
@ -603,8 +603,8 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
|
||||
@defproc[(above/align [x-place x-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{
|
||||
Constructs an image by placing all of the argument images in a vertical row, lined
|
||||
up as indicated by the @scheme[x-place] argument. For example, if @scheme[x-place]
|
||||
is @scheme["middle"], then the images are placed above each other with their centers
|
||||
up as indicated by the @racket[x-place] argument. For example, if @racket[x-place]
|
||||
is @racket["middle"], then the images are placed above each other with their centers
|
||||
lined up.
|
||||
|
||||
@image-examples[(above/align "right"
|
||||
|
|
@ -625,7 +625,7 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
|
|||
@section{Placing Images & Scenes}
|
||||
|
||||
Placing images into scenes is particularly useful when building worlds
|
||||
and universes using @scheme[2htdp/universe].
|
||||
and universes using @racket[2htdp/universe].
|
||||
|
||||
@defproc[(empty-scene [width (and/c real? (not/c negative?))]
|
||||
[height (and/c real? (not/c negative?))])
|
||||
|
|
@ -639,10 +639,10 @@ Creates an empty scene, i.e., a rectangle with a black outline.
|
|||
|
||||
@defproc[(place-image [image image?] [x real?] [y real?] [scene image?]) image?]{
|
||||
|
||||
Places @scheme[image] onto @scheme[scene] with its center at the coordinates
|
||||
(@scheme[x],@scheme[y]) and crops the resulting image so that it has the
|
||||
same size as @scheme[scene]. The coordinates are relative to the top-left
|
||||
of @scheme[scene].
|
||||
Places @racket[image] onto @racket[scene] with its center at the coordinates
|
||||
(@racket[x],@racket[y]) and crops the resulting image so that it has the
|
||||
same size as @racket[scene]. The coordinates are relative to the top-left
|
||||
of @racket[scene].
|
||||
|
||||
@image-examples[(place-image
|
||||
(triangle 32 "solid" "red")
|
||||
|
|
@ -671,11 +671,11 @@ Creates an empty scene, i.e., a rectangle with a black outline.
|
|||
@defproc[(place-image/align [image image?] [x real?] [y real?] [x-place x-place?] [y-place y-place?][scene image?])
|
||||
image?]{
|
||||
|
||||
Like @scheme[place-image], but uses @scheme[image]'s @scheme[x-place] and
|
||||
@scheme[y-place] to anchor the image. Also, like
|
||||
@scheme[place-image], @scheme[place-image/align]
|
||||
Like @racket[place-image], but uses @racket[image]'s @racket[x-place] and
|
||||
@racket[y-place] to anchor the image. Also, like
|
||||
@racket[place-image], @racket[place-image/align]
|
||||
crops the resulting image so that it has the
|
||||
same size as @scheme[scene].
|
||||
same size as @racket[scene].
|
||||
|
||||
@image-examples[(place-image/align (triangle 48 "solid" "yellowgreen")
|
||||
64 64 "right" "bottom"
|
||||
|
|
@ -704,9 +704,9 @@ Creates an empty scene, i.e., a rectangle with a black outline.
|
|||
[color image-color?])
|
||||
image?]{
|
||||
|
||||
Adds a line to the image @scheme[scene], starting from the point (@scheme[x1],@scheme[y1])
|
||||
and going to the point (@scheme[x2],@scheme[y2]); unlike
|
||||
@scheme[add-line], this function crops the resulting image to the size of @scheme[scene].
|
||||
Adds a line to the image @racket[scene], starting from the point (@racket[x1],@racket[y1])
|
||||
and going to the point (@racket[x2],@racket[y2]); unlike
|
||||
@racket[add-line], this function crops the resulting image to the size of @racket[scene].
|
||||
|
||||
@image-examples[(scene+line (ellipse 40 40 "outline" "maroon")
|
||||
0 40 40 0 "maroon")
|
||||
|
|
@ -724,20 +724,20 @@ Creates an empty scene, i.e., a rectangle with a black outline.
|
|||
[color image-color?])
|
||||
image?]{
|
||||
|
||||
Adds a curve to @scheme[scene], starting at the point
|
||||
(@scheme[x1],@scheme[y1]), and ending at the point
|
||||
(@scheme[x2],@scheme[y2]).
|
||||
Adds a curve to @racket[scene], starting at the point
|
||||
(@racket[x1],@racket[y1]), and ending at the point
|
||||
(@racket[x2],@racket[y2]).
|
||||
|
||||
The @scheme[angle1] and @scheme[angle2] arguments specify the
|
||||
The @racket[angle1] and @racket[angle2] arguments specify the
|
||||
angle that the curve has as it leaves the initial point and
|
||||
as it reaches the final point, respectively.
|
||||
|
||||
The @scheme[pull1] and @scheme[pull2] arguments control how
|
||||
The @racket[pull1] and @racket[pull2] arguments control how
|
||||
long the curve tries to stay with that angle. Larger numbers
|
||||
mean that the curve stays with the angle longer.
|
||||
|
||||
Unlike @scheme[add-curve], this function crops the curve, only showing
|
||||
the parts that fit onto @scheme[scene].
|
||||
Unlike @racket[add-curve], this function crops the curve, only showing
|
||||
the parts that fit onto @racket[scene].
|
||||
|
||||
@image-examples[(scene+curve (rectangle 100 100 "solid" "black")
|
||||
20 20 0 1/3
|
||||
|
|
@ -767,7 +767,7 @@ the parts that fit onto @scheme[scene].
|
|||
@section{Rotating, Scaling, Cropping, and Framing Images}
|
||||
|
||||
@defproc[(rotate [angle angle?] [image image?]) image?]{
|
||||
Rotates @scheme[image] by @scheme[angle] degrees in a counter-clockwise direction.
|
||||
Rotates @racket[image] by @racket[angle] degrees in a counter-clockwise direction.
|
||||
|
||||
@image-examples[(rotate 45 (ellipse 60 20 "solid" "olivedrab"))
|
||||
(rotate 5 (rectangle 50 50 "outline" "black"))
|
||||
|
|
@ -781,15 +781,15 @@ the parts that fit onto @scheme[scene].
|
|||
|
||||
@defproc[(scale [factor (and/c real? positive?)] [image image?]) image?]{
|
||||
|
||||
Scales @scheme[image] by @scheme[factor].
|
||||
Scales @racket[image] by @racket[factor].
|
||||
|
||||
The pen sizes are also scaled and thus draw thicker (or thinner)
|
||||
lines than the original image, unless the pen was size
|
||||
@scheme[0]. That pen size is treated specially to mean ``the
|
||||
@racket[0]. That pen size is treated specially to mean ``the
|
||||
smallest available line'' and thus it always draws a one pixel
|
||||
wide line; this is also the case for @scheme['outline] and @scheme["outline"]
|
||||
shapes that are drawn with an @scheme[image-color?] instead of
|
||||
a @scheme[pen].
|
||||
wide line; this is also the case for @racket['outline] and @racket["outline"]
|
||||
shapes that are drawn with an @racket[image-color?] instead of
|
||||
a @racket[pen].
|
||||
|
||||
|
||||
@image-examples[(scale 2 (ellipse 20 30 "solid" "blue"))
|
||||
|
|
@ -800,8 +800,8 @@ the parts that fit onto @scheme[scene].
|
|||
}
|
||||
|
||||
@defproc[(scale/xy [x-factor (and/c real? positive?)] [y-factor (and/c real? positive?)] [image image?]) image?]{
|
||||
Scales @scheme[image] by @scheme[x-factor] horizontally and by
|
||||
@scheme[y-factor] vertically.
|
||||
Scales @racket[image] by @racket[x-factor] horizontally and by
|
||||
@racket[y-factor] vertically.
|
||||
|
||||
@image-examples[(scale/xy 3
|
||||
2
|
||||
|
|
@ -815,8 +815,8 @@ the parts that fit onto @scheme[scene].
|
|||
[image image?])
|
||||
image?]{
|
||||
|
||||
Crops @scheme[image] to the rectangle with the upper left at the point (@scheme[x],@scheme[y])
|
||||
and with @scheme[width] and @scheme[height].
|
||||
Crops @racket[image] to the rectangle with the upper left at the point (@racket[x],@racket[y])
|
||||
and with @racket[width] and @racket[height].
|
||||
|
||||
@image-examples[(crop 0 0 40 40 (circle 40 "solid" "chocolate"))
|
||||
(crop 40 60 40 60 (ellipse 80 120 "solid" "dodgerblue"))
|
||||
|
|
@ -829,7 +829,7 @@ the parts that fit onto @scheme[scene].
|
|||
}
|
||||
|
||||
@defproc[(frame [image image?]) image?]{
|
||||
Returns an image just like @scheme[image], except
|
||||
Returns an image just like @racket[image], except
|
||||
with a black, single pixel frame drawn around the
|
||||
bounding box of the image.
|
||||
|
||||
|
|
@ -848,27 +848,29 @@ the parts that fit onto @scheme[scene].
|
|||
|
||||
@section{Image Properties}
|
||||
|
||||
@defproc[(image-width [i image?]) (and/c integer? positive? exact?)]{
|
||||
Returns the width of @scheme[i].
|
||||
@defproc[(image-width [i image?]) (and/c integer? (not/c negative?) exact?)]{
|
||||
Returns the width of @racket[i].
|
||||
|
||||
@image-examples[(image-width (ellipse 30 40 "solid" "orange"))
|
||||
(image-width (circle 30 "solid" "orange"))
|
||||
(image-width (beside (circle 20 "solid" "orange")
|
||||
(circle 20 "solid" "purple")))]
|
||||
(circle 20 "solid" "purple")))
|
||||
(image-width (rectangle 0 10 "solid" "purple"))]
|
||||
}
|
||||
|
||||
@defproc[(image-height [i image?]) (and/c integer? positive? exact?)]{
|
||||
Returns the height of @scheme[i].
|
||||
@defproc[(image-height [i image?]) (and/c integer? (not/c negative?) exact?)]{
|
||||
Returns the height of @racket[i].
|
||||
|
||||
@image-examples[(image-height (ellipse 30 40 "solid" "orange"))
|
||||
(image-height (circle 30 "solid" "orange"))
|
||||
(image-height (overlay (circle 20 "solid" "orange")
|
||||
(circle 30 "solid" "purple")))]
|
||||
(circle 30 "solid" "purple")))
|
||||
(image-height (rectangle 10 0 "solid" "purple"))]
|
||||
}
|
||||
|
||||
@defproc[(image-baseline [i image?]) (and/c integer? positive? exact?)]{
|
||||
Returns the distance from the top of the image to its baseline.
|
||||
Unless the image was constructed with @scheme[text] or @scheme[text/font],
|
||||
Unless the image was constructed with @racket[text] or @racket[text/font],
|
||||
this will be the same as its height.
|
||||
|
||||
@image-examples[(image-baseline (text "Hello" 24 "black"))
|
||||
|
|
@ -882,60 +884,60 @@ the parts that fit onto @scheme[scene].
|
|||
This section lists predicates for the basic structures provided by the image library.
|
||||
|
||||
@defproc[(image? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is an image. Images are returned by functions
|
||||
like @scheme[ellipse] and @scheme[rectangle] and
|
||||
accepted by functions like @scheme[overlay] and @scheme[beside].
|
||||
Determines if @racket[x] is an image. Images are returned by functions
|
||||
like @racket[ellipse] and @racket[rectangle] and
|
||||
accepted by functions like @racket[overlay] and @racket[beside].
|
||||
|
||||
Additionally, images inserted into a DrRacket window are treated as
|
||||
bitmap images, as are instances of @scheme[image-snip%] and @scheme[bitmap%].
|
||||
bitmap images, as are instances of @racket[image-snip%] and @racket[bitmap%].
|
||||
}
|
||||
|
||||
@defproc[(mode? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a mode suitable for
|
||||
Determines if @racket[x] is a mode suitable for
|
||||
constructing images. It can be one of
|
||||
@scheme['solid], @scheme["solid"], @scheme['outline],
|
||||
or @scheme["outline"], indicating if the shape is
|
||||
@racket['solid], @racket["solid"], @racket['outline],
|
||||
or @racket["outline"], indicating if the shape is
|
||||
filled in or not.
|
||||
}
|
||||
|
||||
@defproc[(image-color? [x any/c]) boolean?]{
|
||||
|
||||
Determines if @scheme[x] represents a color. Strings, symbols,
|
||||
and @scheme[color] structs are allowed as colors.
|
||||
Determines if @racket[x] represents a color. Strings, symbols,
|
||||
and @racket[color] structs are allowed as colors.
|
||||
|
||||
For example,
|
||||
@scheme["magenta"], @scheme["black"], @scheme['orange], and @scheme['purple]
|
||||
@racket["magenta"], @racket["black"], @racket['orange], and @racket['purple]
|
||||
are allowed. Colors are not case-sensitive, so
|
||||
@scheme["Magenta"], @scheme["Black"], @scheme['Orange], and @scheme['Purple]
|
||||
@racket["Magenta"], @racket["Black"], @racket['Orange], and @racket['Purple]
|
||||
are also allowed, and are the same colors as in the previous sentence.
|
||||
If a string or symbol color name is not recognized, black is used in its place.
|
||||
|
||||
The complete list of colors is available in the documentation for
|
||||
@scheme[color-database<%>].
|
||||
@racket[color-database<%>].
|
||||
|
||||
}
|
||||
|
||||
@defstruct[color ([red (and/c natural-number/c (<=/c 255))]
|
||||
[green (and/c natural-number/c (<=/c 255))]
|
||||
[blue (and/c natural-number/c (<=/c 255))])]{
|
||||
The @scheme[color] struct defines a color with red, green, and blue components
|
||||
that range from @scheme[0] to @scheme[255].
|
||||
The @racket[color] struct defines a color with red, green, and blue components
|
||||
that range from @racket[0] to @racket[255].
|
||||
}
|
||||
|
||||
@defproc[(y-place? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a placement option
|
||||
Determines if @racket[x] is a placement option
|
||||
for the vertical direction. It can be one
|
||||
of
|
||||
@scheme["top"],
|
||||
@scheme['top],
|
||||
@scheme["bottom"],
|
||||
@scheme['bottom],
|
||||
@scheme["middle"],
|
||||
@scheme['middle],
|
||||
@scheme["center"],
|
||||
@scheme['center],
|
||||
@scheme["baseline"], or
|
||||
@scheme['baseline].
|
||||
@racket["top"],
|
||||
@racket['top],
|
||||
@racket["bottom"],
|
||||
@racket['bottom],
|
||||
@racket["middle"],
|
||||
@racket['middle],
|
||||
@racket["center"],
|
||||
@racket['center],
|
||||
@racket["baseline"], or
|
||||
@racket['baseline].
|
||||
|
||||
The baseline of an image is the place where the bottoms any letters line up, not counting descenders, e.g. the tail on ``y'' or ``g'' or ``j''.
|
||||
|
||||
|
|
@ -943,27 +945,31 @@ The baseline of an image is the place where the bottoms any letters line up, not
|
|||
}
|
||||
|
||||
@defproc[(x-place? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a placement option
|
||||
Determines if @racket[x] is a placement option
|
||||
for the horizontal direction. It can be one
|
||||
of @scheme["left"],
|
||||
@scheme['left],
|
||||
@scheme["right"],
|
||||
@scheme['right],
|
||||
@scheme["middle"],
|
||||
@scheme['middle],
|
||||
@scheme["center"], or
|
||||
@scheme['center].
|
||||
of @racket["left"],
|
||||
@racket['left],
|
||||
@racket["right"],
|
||||
@racket['right],
|
||||
@racket["middle"],
|
||||
@racket['middle],
|
||||
@racket["center"], or
|
||||
@racket['center].
|
||||
}
|
||||
|
||||
@defproc[(angle? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is an angle, namely
|
||||
a real number between @scheme[0] (inclusive)
|
||||
and @scheme[360] (exclusive).
|
||||
Determines if @racket[x] is an angle, namely
|
||||
a real number between @racket[0] (inclusive)
|
||||
and @racket[360] (exclusive).
|
||||
}
|
||||
|
||||
@defproc[(side-count? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is an integer
|
||||
greater than or equal to @scheme[3].
|
||||
Determines if @racket[x] is an integer
|
||||
greater than or equal to @racket[3].
|
||||
}
|
||||
|
||||
@defproc[(step-count? [x any/c]) boolean?]{
|
||||
Determines if @racket[x] is an integer greater than or equal to @racket[1].
|
||||
}
|
||||
|
||||
@defstruct[pen ([color image-color?]
|
||||
|
|
@ -971,42 +977,42 @@ The baseline of an image is the place where the bottoms any letters line up, not
|
|||
[style pen-style?]
|
||||
[cap pen-cap?]
|
||||
[join pen-join?])]{
|
||||
The @scheme[pen] struct specifies how the drawing library draws lines.
|
||||
The @racket[pen] struct specifies how the drawing library draws lines.
|
||||
|
||||
|
||||
A good default for @scheme[style] is @scheme["solid"], and
|
||||
good default values for the @scheme[cap] and @scheme[join] fields
|
||||
are @scheme["round"].
|
||||
A good default for @racket[style] is @racket["solid"], and
|
||||
good default values for the @racket[cap] and @racket[join] fields
|
||||
are @racket["round"].
|
||||
|
||||
Using @scheme[0] as a width is special; it means to always draw the
|
||||
Using @racket[0] as a width is special; it means to always draw the
|
||||
smallest possible, but visible, pen. This means that the pen will always
|
||||
be one pixel in size, no matter how the image is scaled.
|
||||
}
|
||||
|
||||
@defproc[(pen-style? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a valid pen style.
|
||||
Determines if @racket[x] is a valid pen style.
|
||||
It can be one of
|
||||
@scheme["solid"], @scheme['solid],
|
||||
@scheme["dot"], @scheme['dot],
|
||||
@scheme["long-dash"], @scheme['long-dash],
|
||||
@scheme["short-dash"], @scheme['short-dash],
|
||||
@scheme["dot-dash"], or @scheme['dot-dash].
|
||||
@racket["solid"], @racket['solid],
|
||||
@racket["dot"], @racket['dot],
|
||||
@racket["long-dash"], @racket['long-dash],
|
||||
@racket["short-dash"], @racket['short-dash],
|
||||
@racket["dot-dash"], or @racket['dot-dash].
|
||||
}
|
||||
|
||||
@defproc[(pen-cap? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a valid pen cap.
|
||||
Determines if @racket[x] is a valid pen cap.
|
||||
It can be one of
|
||||
@scheme["round"], @scheme['round],
|
||||
@scheme["projecting"], @scheme['projecting],
|
||||
@scheme["butt"], or @scheme['butt].
|
||||
@racket["round"], @racket['round],
|
||||
@racket["projecting"], @racket['projecting],
|
||||
@racket["butt"], or @racket['butt].
|
||||
}
|
||||
|
||||
@defproc[(pen-join? [x any/c]) boolean?]{
|
||||
Determines if @scheme[x] is a valid pen join.
|
||||
Determines if @racket[x] is a valid pen join.
|
||||
It can be one of
|
||||
@scheme["round"], @scheme['round],
|
||||
@scheme["bevel"], @scheme['bevel],
|
||||
@scheme["miter"], or @scheme['miter].
|
||||
@racket["round"], @racket['round],
|
||||
@racket["bevel"], @racket['bevel],
|
||||
@racket["miter"], or @racket['miter].
|
||||
}
|
||||
|
||||
@section{Equality Testing of Images}
|
||||
|
|
@ -1019,18 +1025,18 @@ Two images are equal if they draw exactly the same way, at their current size
|
|||
The image library treats coordinates as if they are in the upper-left corner
|
||||
of each pixel, and infinitesimally small.
|
||||
|
||||
Thus, when drawing a solid @scheme[square] of whose side-length is 10, the image library
|
||||
colors in all of the pixels enclosed by the @scheme[square] starting at the upper
|
||||
Thus, when drawing a solid @racket[square] of whose side-length is 10, the image library
|
||||
colors in all of the pixels enclosed by the @racket[square] starting at the upper
|
||||
left corner of (0,0) and going down to the upper left corner of (10,10),
|
||||
so the pixel whose upper left at (9,9) is colored in, but the pixel
|
||||
at (10,10) is not. All told, 100 pixels get colored in, just as expected for
|
||||
a @scheme[square] with a side length of 10.
|
||||
a @racket[square] with a side length of 10.
|
||||
|
||||
When drawing lines, however, things get a bit more complex. Specifically,
|
||||
imagine drawing the outline of that rectangle. Since the border is
|
||||
between the pixels, there really isn't a natural pixel to draw to indicate
|
||||
the border. Accordingly, when drawing an outline @scheme[square] (without a
|
||||
@scheme[pen] specification, but just a color as the last argument),
|
||||
the border. Accordingly, when drawing an outline @racket[square] (without a
|
||||
@racket[pen] specification, but just a color as the last argument),
|
||||
the image library uses a pen whose width is 1 pixel, but draws a line
|
||||
centered at the point (0.5,0.5) that goes down and around to the point (10.5,10.5).
|
||||
This means that the outline slightly exceeds the bounding box of the shape.
|
||||
|
|
@ -1038,12 +1044,12 @@ Specifically, the upper and left-hand lines around the square are within
|
|||
the bounding box, but the lower and right-hand lines are just outside.
|
||||
|
||||
The special case of adding 0.5 to each coordinate when drawing the square
|
||||
applies to all polygon-based shapes, but does not apply when a @scheme[pen]
|
||||
applies to all polygon-based shapes, but does not apply when a @racket[pen]
|
||||
is passed as the last argument to create the shape.
|
||||
In that case, not adjustment of the pixels is performed and using a one
|
||||
pixel wide pen draws the pixels above and below the line, but each with
|
||||
a color that is half of the intensity of the given color. Using a
|
||||
@scheme[pen] with with two, colors the pixels above and below the line
|
||||
@racket[pen] with with two, colors the pixels above and below the line
|
||||
with the full intensity.
|
||||
|
||||
|
||||
|
|
@ -1052,14 +1058,14 @@ with the full intensity.
|
|||
|
||||
In order to use an image as an input to another program (Photoshop, e.g., or
|
||||
a web browser), it is necessary to represent it in a format that these programs
|
||||
can understand. The @scheme[save-image] function provides this functionality,
|
||||
can understand. The @racket[save-image] function provides this functionality,
|
||||
writing an image to disk using the @tt{PNG} format. Since this
|
||||
format represents an image using a set of pixel values, an image written to disk
|
||||
generally contains less information than the image that was written, and cannot be scaled
|
||||
or manipulated as cleanly (by any image program).
|
||||
|
||||
@defproc[(save-image [image image?] [filename path-string?]) boolean?]{
|
||||
writes an image to the path specified by @scheme[filename], using the
|
||||
writes an image to the path specified by @racket[filename], using the
|
||||
@tt{PNG} format.}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -687,6 +687,23 @@
|
|||
(λ () (values 1 2))
|
||||
'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-optional24
|
||||
'(let ()
|
||||
(define (statement? s)
|
||||
(and (string? s)
|
||||
(> (string-length s) 3)))
|
||||
(define statement/c (flat-contract statement?))
|
||||
|
||||
(define new-statement
|
||||
(make-keyword-procedure
|
||||
(λ (kws kw-args . statement)
|
||||
(format "kws=~s kw-args=~s statement=~s" kws kw-args statement))))
|
||||
|
||||
(contract (->* (statement/c) (#:s string?) statement/c)
|
||||
new-statement
|
||||
'pos 'neg)))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-keyword-ordering
|
||||
'((contract (->* (integer? #:x boolean?) (string? #:y char?) any)
|
||||
|
|
|
|||
|
|
@ -21,7 +21,9 @@
|
|||
|
||||
; date->string
|
||||
(let* ([secs (find-seconds 1 2 3 4 5 2006)]
|
||||
[d (seconds->date secs)])
|
||||
[d-some-tz (seconds->date secs)]
|
||||
[d (struct-copy date d-some-tz
|
||||
[time-zone-offset -21600])])
|
||||
(define (test-string fmt time? result)
|
||||
(test (parameterize ([date-display-format fmt])
|
||||
(date->string d time?))
|
||||
|
|
|
|||
16
collects/tests/typed-scheme/fail/require-typed-missing.rkt
Normal file
16
collects/tests/typed-scheme/fail/require-typed-missing.rkt
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#;
|
||||
(exn-pred "at least one")
|
||||
#lang typed/racket
|
||||
|
||||
|
||||
(require/typed (make-main (([Listof Node] [Listof Edge] -> Graph)
|
||||
(State Number Number MouseEvent -> State)
|
||||
(State KeyEvent -> State)
|
||||
(State -> Scene)
|
||||
(Any -> Boolean)
|
||||
(State -> Boolean)
|
||||
(Stop -> Graph)
|
||||
(Any -> Edge)
|
||||
(Edge -> Graph)
|
||||
->
|
||||
(Boolean -> Graph))))
|
||||
15
collects/tests/typed-scheme/succeed/pr10470.rkt
Normal file
15
collects/tests/typed-scheme/succeed/pr10470.rkt
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
(module pr10470 typed-scheme
|
||||
|
||||
(define-type-alias (Memo alpha) (U (Option alpha) (-> (Option alpha))))
|
||||
|
||||
(define-struct: table ([val : (Memo Number)]) #:mutable)
|
||||
|
||||
(: f (table -> (Option Number)))
|
||||
(define (f tab)
|
||||
(let ([proc-or-num (table-val tab)])
|
||||
(cond
|
||||
[(procedure? proc-or-num)
|
||||
(let ([result (proc-or-num)])
|
||||
(set-table-val! tab result)
|
||||
result)]
|
||||
[else proc-or-num]))))
|
||||
|
|
@ -324,6 +324,22 @@ END
|
|||
"<!-- comment --><br />"
|
||||
"read-xml: parse-error: expected root element - received #<comment>")
|
||||
|
||||
(test-read-xml/element
|
||||
"<title><![CDATA[hello world[mp3]]]></title>"
|
||||
'(make-element
|
||||
(make-source (make-location 1 0 1) (make-location 1 43 44))
|
||||
'title
|
||||
(list)
|
||||
(list (make-cdata (make-source (make-location 1 7 8) (make-location 1 35 36)) "<![CDATA[hello world[mp3]]]>"))))
|
||||
|
||||
(test-read-xml/element
|
||||
"<title><![CDATA[]]]></title>"
|
||||
'(make-element
|
||||
(make-source (make-location 1 0 1) (make-location 1 28 29))
|
||||
'title
|
||||
(list)
|
||||
(list (make-cdata (make-source (make-location 1 7 8) (make-location 1 20 21)) "<![CDATA[]]]>"))))
|
||||
|
||||
; XXX need more read-xml/element tests
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -79,7 +79,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
#:fail-unless (eq? 'opaque (syntax-e #'opaque)) #f
|
||||
#:with opt #'(#:name-exists)))
|
||||
(syntax-parse stx
|
||||
[(_ lib (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
|
||||
[(_ lib:expr (~or sc:simple-clause strc:struct-clause oc:opaque-clause) ...)
|
||||
(unless (< 0 (length (syntax->list #'(sc ... strc ... oc ...))))
|
||||
(raise-syntax-error #f "at least one specification is required" stx))
|
||||
#'(begin
|
||||
(require/opaque-type oc.ty oc.pred lib . oc.opt) ...
|
||||
(require/typed sc.nm sc.ty lib) ...
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@
|
|||
([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
|
||||
(lambda (e) (tc-error "Internal error: ~a" e))])]
|
||||
[parameterize (;; enable fancy printing?
|
||||
[custom-printer #f]
|
||||
[custom-printer #t]
|
||||
;; a cheat to avoid units
|
||||
[infer-param infer]
|
||||
;; do we report multiple errors
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
|
||||
|
||||
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app)
|
||||
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct)
|
||||
(except typed-scheme/private/prims)
|
||||
(except typed-scheme/private/base-types-new)
|
||||
(except typed-scheme/private/base-types-extra))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
|
||||
|
||||
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
|
||||
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct)
|
||||
(except typed-scheme/private/prims)
|
||||
(except typed-scheme/private/base-types-new)
|
||||
(except typed-scheme/private/base-types-extra))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define count 0)
|
||||
(define a-date (date->string (seconds->date (current-seconds)) 'time-too))
|
||||
(define a-date (date->string (seconds->date (current-seconds)) #t))
|
||||
(define (start initial-request)
|
||||
(define other-count 0)
|
||||
|
||||
|
|
|
|||
|
|
@ -384,35 +384,49 @@
|
|||
;; uses Knuth-Morris-Pratt from
|
||||
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
|
||||
;; discards stop from input
|
||||
(define (gen-read-until-string stop)
|
||||
(let* ([len (string-length stop)]
|
||||
[prefix (make-vector len 0)]
|
||||
[fall-back
|
||||
(lambda (k c)
|
||||
(let ([k (let loop ([k k])
|
||||
(cond
|
||||
[(and (> k 0) (not (eq? (string-ref stop k) c)))
|
||||
(loop (vector-ref prefix (sub1 k)))]
|
||||
[else k]))])
|
||||
(if (eq? (string-ref stop k) c)
|
||||
(add1 k)
|
||||
k)))])
|
||||
(let init ([k 0] [q 1])
|
||||
(when (< q len)
|
||||
(let ([k (fall-back k (string-ref stop q))])
|
||||
(vector-set! prefix q k)
|
||||
(init k (add1 q)))))
|
||||
;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
|
||||
(lambda (in pos)
|
||||
(list->string
|
||||
(let/ec out
|
||||
(let loop ([matched 0] [out out])
|
||||
(let* ([c (non-eof read-char in pos)]
|
||||
[matched (fall-back matched c)])
|
||||
(cond
|
||||
[(= matched len) (out null)]
|
||||
[(zero? matched) (cons c (let/ec out (loop matched out)))]
|
||||
[else (cons c (loop matched out))]))))))))
|
||||
;; ---
|
||||
;; Modified by Jay to look more like the version on Wikipedia after discovering a bug when parsing CDATA
|
||||
;; The use of the hasheq table and the purely numeric code trades hash efficiency for stack/ec capture efficiency
|
||||
(struct hash-string (port pos ht))
|
||||
(define (hash-string-ref hs k)
|
||||
(match-define (hash-string port pos ht) hs)
|
||||
(hash-ref! ht k (lambda () (non-eof read-char port pos))))
|
||||
|
||||
(define (gen-read-until-string W)
|
||||
(define Wlen (string-length W))
|
||||
(define T (make-vector Wlen #f))
|
||||
(vector-set! T 0 -1)
|
||||
(vector-set! T 1 0)
|
||||
(let kmp-table ([pos 2] [cnd 0])
|
||||
(when (pos . < . Wlen)
|
||||
(cond
|
||||
[(char=? (string-ref W (sub1 pos)) (string-ref W cnd))
|
||||
(vector-set! T pos (add1 cnd))
|
||||
(kmp-table (add1 pos) (add1 cnd))]
|
||||
[(cnd . > . 0)
|
||||
(kmp-table pos (vector-ref T cnd))]
|
||||
[(zero? cnd)
|
||||
(vector-set! T pos 0)
|
||||
(kmp-table (add1 pos) 0)])))
|
||||
(lambda (S-as-port S-pos)
|
||||
(define S (hash-string S-as-port S-pos (make-hasheq)))
|
||||
(define W-starts-at
|
||||
(let kmp-search ([m 0] [i 0])
|
||||
(if (char=? (string-ref W i) (hash-string-ref S (+ m i)))
|
||||
(let ([i (add1 i)])
|
||||
(if (= i Wlen)
|
||||
m
|
||||
(kmp-search m i)))
|
||||
(let* ([Ti (vector-ref T i)]
|
||||
[m (+ m i (* -1 Ti))])
|
||||
(if (Ti . > . -1)
|
||||
(let ([i Ti])
|
||||
(kmp-search m i))
|
||||
(let ([i 0])
|
||||
(kmp-search m i)))))))
|
||||
(list->string
|
||||
(for/list ([i (in-range 0 W-starts-at)])
|
||||
(hash-string-ref S i)))))
|
||||
|
||||
;; "-->" makes more sense, but "--" follows the spec.
|
||||
(define lex-comment-contents (gen-read-until-string "--"))
|
||||
|
|
@ -460,4 +474,4 @@
|
|||
(define (format-source loc)
|
||||
(if (location? loc)
|
||||
(format "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
|
||||
(format "~a" loc)))
|
||||
(format "~a" loc)))
|
||||
11
src/configure
vendored
11
src/configure
vendored
|
|
@ -576,7 +576,7 @@ PACKAGE_VERSION=
|
|||
PACKAGE_STRING=
|
||||
PACKAGE_BUGREPORT=
|
||||
|
||||
ac_unique_file="PLT Scheme"
|
||||
ac_unique_file="Racket"
|
||||
ac_unique_file="racket/src/bignum.c"
|
||||
# Factoring default headers for most tests.
|
||||
ac_includes_default="\
|
||||
|
|
@ -2201,10 +2201,10 @@ else
|
|||
# Set prefix explicitly so we can use it during configure
|
||||
prefix="${ac_default_prefix}"
|
||||
fi
|
||||
libpltdir="${libdir}/plt"
|
||||
collectsdir="${libdir}/plt/collects"
|
||||
includepltdir="${includedir}/plt"
|
||||
docdir="${datadir}/plt/doc"
|
||||
libpltdir="${libdir}/racket"
|
||||
collectsdir="${libdir}/racket/collects"
|
||||
includepltdir="${includedir}/racket"
|
||||
docdir="${datadir}/racket/doc"
|
||||
MAKE_COPYTREE=copytree
|
||||
COLLECTS_PATH='${collectsdir}'
|
||||
INSTALL_ORIG_TREE=no
|
||||
|
|
@ -5855,6 +5855,7 @@ case $OS in
|
|||
FreeBSD)
|
||||
LIBS="$LIBS -rdynamic"
|
||||
DYN_CFLAGS="-fPIC"
|
||||
GC_THREADS_FLAG="-DGC_FREEBSD_THREADS"
|
||||
enable_pthread=yes
|
||||
;;
|
||||
OpenBSD)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
# it needs to include C++ flags that we don't want for Racket.
|
||||
# hence PREFLAGS, which is initialized to the original CPPFLAGS.
|
||||
|
||||
AC_INIT([PLT Scheme])
|
||||
AC_INIT([Racket])
|
||||
AC_CONFIG_SRCDIR(racket/src/bignum.c)
|
||||
AC_CONFIG_HEADERS([racket/mzconfig.h])
|
||||
|
||||
|
|
@ -234,10 +234,10 @@ else
|
|||
# Set prefix explicitly so we can use it during configure
|
||||
prefix="${ac_default_prefix}"
|
||||
fi
|
||||
libpltdir="${libdir}/plt"
|
||||
collectsdir="${libdir}/plt/collects"
|
||||
includepltdir="${includedir}/plt"
|
||||
docdir="${datadir}/plt/doc"
|
||||
libpltdir="${libdir}/racket"
|
||||
collectsdir="${libdir}/racket/collects"
|
||||
includepltdir="${includedir}/racket"
|
||||
docdir="${datadir}/racket/doc"
|
||||
MAKE_COPYTREE=copytree
|
||||
COLLECTS_PATH='${collectsdir}'
|
||||
INSTALL_ORIG_TREE=no
|
||||
|
|
|
|||
|
|
@ -454,6 +454,12 @@ GC2_EXTERN void GC_set_put_external_event_fd(void *fd);
|
|||
Sets the fd that can be passed to scheme_signal_received_at to wake up the place for GC
|
||||
*/
|
||||
|
||||
GC2_EXTERN void GC_allow_master_gc_check();
|
||||
/*
|
||||
Signals the GC after spawning a place that the places is sufficiently set up to participate
|
||||
in master gc collections
|
||||
*/
|
||||
|
||||
# ifdef __cplusplus
|
||||
};
|
||||
# endif
|
||||
|
|
|
|||
|
|
@ -1881,6 +1881,16 @@ void GC_write_barrier(void *p)
|
|||
#include "sighand.c"
|
||||
|
||||
#ifdef MZ_USE_PLACES
|
||||
typedef enum {
|
||||
SIGNALED_BUT_NOT_REGISTERED = -3,
|
||||
REAPED_SLOT_AVAILABLE = -2,
|
||||
CREATED_BUT_NOT_REGISTERED = -1,
|
||||
};
|
||||
|
||||
void GC_allow_master_gc_check() {
|
||||
NewGC *gc = GC_get_GC();
|
||||
gc->dont_master_gc_until_child_registers = 0;
|
||||
}
|
||||
static void NewGCMasterInfo_initialize() {
|
||||
int i;
|
||||
MASTERGCINFO = ofm_malloc_zero(sizeof(NewGCMasterInfo));
|
||||
|
|
@ -1889,7 +1899,7 @@ static void NewGCMasterInfo_initialize() {
|
|||
MASTERGCINFO->ready = 0;
|
||||
MASTERGCINFO->signal_fds = realloc(MASTERGCINFO->signal_fds, sizeof(void*) * MASTERGCINFO->size);
|
||||
for (i=0; i < 32; i++ ) {
|
||||
MASTERGCINFO->signal_fds[i] = (void *)-2;
|
||||
MASTERGCINFO->signal_fds[i] = (void *)REAPED_SLOT_AVAILABLE;
|
||||
}
|
||||
mzrt_rwlock_create(&MASTERGCINFO->cangc);
|
||||
mzrt_sema_create(&MASTERGCINFO->wait_sema, 0);
|
||||
|
|
@ -1925,6 +1935,11 @@ static void master_collect_initiate() {
|
|||
#endif
|
||||
count++;
|
||||
}
|
||||
else if ( signal_fd == (void*)-1) {
|
||||
/* printf("%i SIGNALED BUT NOT REGISTERED YET\n", i); */
|
||||
MASTERGCINFO->signal_fds[i] = (void*) SIGNALED_BUT_NOT_REGISTERED;
|
||||
count++;
|
||||
}
|
||||
if (count == (MASTERGCINFO->alive -1)) {
|
||||
break;
|
||||
}
|
||||
|
|
@ -2026,7 +2041,7 @@ static long NewGCMasterInfo_find_free_id() {
|
|||
int i;
|
||||
int size = MASTERGCINFO->size;
|
||||
for (i = 0; i < size; i++) {
|
||||
if (MASTERGCINFO->signal_fds[i] == (void*)-2) {
|
||||
if (MASTERGCINFO->signal_fds[i] == (void*) REAPED_SLOT_AVAILABLE) {
|
||||
MASTERGCINFO->alive++;
|
||||
return i;
|
||||
}
|
||||
|
|
@ -2042,7 +2057,7 @@ static void NewGCMasterInfo_register_gc(NewGC *newgc) {
|
|||
{
|
||||
long newid = NewGCMasterInfo_find_free_id();
|
||||
newgc->place_id = newid;
|
||||
MASTERGCINFO->signal_fds[newid] = (void *)-1;
|
||||
MASTERGCINFO->signal_fds[newid] = (void *) CREATED_BUT_NOT_REGISTERED;
|
||||
}
|
||||
GC_LOCK_DEBUG("UNMGCLOCK NewGCMasterInfo_register_gc\n");
|
||||
mzrt_rwlock_unlock(MASTERGCINFO->cangc);
|
||||
|
|
@ -2053,6 +2068,10 @@ void GC_set_put_external_event_fd(void *fd) {
|
|||
mzrt_rwlock_wrlock(MASTERGCINFO->cangc);
|
||||
GC_LOCK_DEBUG("MGCLOCK GC_set_put_external_event_fd\n");
|
||||
{
|
||||
if ( MASTERGCINFO->signal_fds[gc->place_id] == (void*) SIGNALED_BUT_NOT_REGISTERED) {
|
||||
scheme_signal_received_at(fd);
|
||||
/* printf("%i THERE WAITING ON ME\n", gc->place_id); */
|
||||
}
|
||||
MASTERGCINFO->signal_fds[gc->place_id] = fd;
|
||||
}
|
||||
GC_LOCK_DEBUG("UNMGCLOCK GC_set_put_external_event_fd\n");
|
||||
|
|
@ -2159,6 +2178,7 @@ void GC_construct_child_gc() {
|
|||
NewGC *gc = MASTERGC;
|
||||
NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag);
|
||||
newgc->primoridal_gc = MASTERGC;
|
||||
newgc->dont_master_gc_until_child_registers = 1;
|
||||
}
|
||||
|
||||
void GC_destruct_child_gc() {
|
||||
|
|
@ -2170,7 +2190,7 @@ void GC_destruct_child_gc() {
|
|||
GC_LOCK_DEBUG("MGCLOCK GC_destruct_child_gc\n");
|
||||
waiting = MASTERGC->major_places_gc;
|
||||
if (!waiting) {
|
||||
MASTERGCINFO->signal_fds[gc->place_id] = (void *)-2;
|
||||
MASTERGCINFO->signal_fds[gc->place_id] = (void *) REAPED_SLOT_AVAILABLE;
|
||||
gc->place_id = -1;
|
||||
MASTERGCINFO->alive--;
|
||||
}
|
||||
|
|
@ -2178,6 +2198,7 @@ void GC_destruct_child_gc() {
|
|||
mzrt_rwlock_unlock(MASTERGCINFO->cangc);
|
||||
|
||||
|
||||
|
||||
if (waiting) {
|
||||
garbage_collect(gc, 1, 0);
|
||||
waiting = 1;
|
||||
|
|
@ -2203,18 +2224,21 @@ void GC_switch_out_master_gc() {
|
|||
|
||||
if(!initialized) {
|
||||
NewGC *gc = GC_get_GC();
|
||||
|
||||
initialized = 1;
|
||||
garbage_collect(gc, 1, 1);
|
||||
|
||||
#ifdef MZ_USE_PLACES
|
||||
GC_gen0_alloc_page_ptr = 2;
|
||||
GC_gen0_alloc_page_end = 1;
|
||||
gc->dont_master_gc_until_child_registers = 0;
|
||||
#endif
|
||||
|
||||
MASTERGC = gc;
|
||||
MASTERGC->dumping_avoid_collection = 1;
|
||||
save_globals_to_gc(MASTERGC);
|
||||
GC_construct_child_gc();
|
||||
GC_allow_master_gc_check();
|
||||
}
|
||||
else {
|
||||
GCPRINT(GCOUTF, "GC_switch_out_master_gc should only be called once!\n");
|
||||
|
|
@ -3857,7 +3881,7 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master)
|
|||
|
||||
#ifdef MZ_USE_PLACES
|
||||
if (postmaster_and_place_gc(gc)) {
|
||||
if (gc->gc_full && master_wants_to_collect) {
|
||||
if (gc->gc_full && master_wants_to_collect && !(gc->dont_master_gc_until_child_registers)) {
|
||||
wait_if_master_in_progress(gc);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -178,6 +178,7 @@ typedef struct NewGC {
|
|||
#ifdef MZ_USE_PLACES
|
||||
int place_id;
|
||||
int major_places_gc; /* :1; */
|
||||
int dont_master_gc_until_child_registers; /* :1: */
|
||||
#endif
|
||||
|
||||
struct mpage *thread_local_pages;
|
||||
|
|
|
|||
|
|
@ -286,6 +286,10 @@ typedef struct Thread_Local_Variables {
|
|||
struct mzrt_mutex *jit_lock_;
|
||||
struct free_list_entry *free_list_;
|
||||
int free_list_bucket_count_;
|
||||
struct Scheme_Bucket_Table *prefab_table_;
|
||||
struct Scheme_Hash_Table *place_local_symbol_table_;
|
||||
struct Scheme_Hash_Table *place_local_keyword_table_;
|
||||
struct Scheme_Hash_Table *place_local_parallel_symbol_table_;
|
||||
/*KPLAKE1*/
|
||||
} Thread_Local_Variables;
|
||||
|
||||
|
|
@ -574,6 +578,10 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
|
|||
#define jit_lock XOA (scheme_get_thread_local_variables()->jit_lock_)
|
||||
#define free_list XOA (scheme_get_thread_local_variables()->free_list_)
|
||||
#define free_list_bucket_count XOA (scheme_get_thread_local_variables()->free_list_bucket_count_)
|
||||
#define prefab_table XOA (scheme_get_thread_local_variables()->prefab_table_)
|
||||
#define place_local_symbol_table XOA (scheme_get_thread_local_variables()->place_local_symbol_table_)
|
||||
#define place_local_keyword_table XOA (scheme_get_thread_local_variables()->place_local_keyword_table_)
|
||||
#define place_local_parallel_symbol_table XOA (scheme_get_thread_local_variables()->place_local_parallel_symbol_table_)
|
||||
/*KPLAKE2*/
|
||||
|
||||
/* **************************************** */
|
||||
|
|
|
|||
|
|
@ -361,6 +361,7 @@ Scheme_Env *scheme_engine_instance_init() {
|
|||
scheme_places_block_child_signal();
|
||||
|
||||
GC_switch_out_master_gc();
|
||||
|
||||
scheme_spawn_master_place();
|
||||
#endif
|
||||
|
||||
|
|
@ -463,6 +464,11 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
|
|||
|
||||
scheme_make_thread(stack_base);
|
||||
|
||||
#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
|
||||
/* each place now has a local symbol table */
|
||||
scheme_init_place_local_symbol_table();
|
||||
#endif
|
||||
|
||||
{
|
||||
Scheme_Object *sym;
|
||||
sym = scheme_intern_symbol("mzscheme");
|
||||
|
|
|
|||
|
|
@ -7695,9 +7695,7 @@ scheme_get_stack_trace(Scheme_Object *mark_set)
|
|||
name = scheme_make_pair(scheme_false, loc);
|
||||
else
|
||||
name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc);
|
||||
} else if (SCHEME_PAIRP(name)
|
||||
&& SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(name)),
|
||||
scheme_resolved_module_path_type)) {
|
||||
} else if (SCHEME_PAIRP(name) && SCHEME_RMPP(SCHEME_CAR(name))) {
|
||||
/* a resolved module path means that we're running a module body */
|
||||
const char *what;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,6 +29,8 @@
|
|||
#include "schmach.h"
|
||||
#include "schexpobs.h"
|
||||
|
||||
#define MIN(l,o) ((l) < (o) ? (l) : (o))
|
||||
|
||||
/* globals */
|
||||
SHARED_OK Scheme_Object *(*scheme_module_demand_hook)(int, Scheme_Object **);
|
||||
|
||||
|
|
@ -127,6 +129,7 @@ static void eval_exptime(Scheme_Object *names, int count,
|
|||
static Scheme_Module_Exports *make_module_exports();
|
||||
|
||||
static Scheme_Object *scheme_sys_wraps_phase_worker(long p);
|
||||
static Scheme_Object *resolved_module_path_value(Scheme_Object *rmp);
|
||||
|
||||
#define cons scheme_make_pair
|
||||
|
||||
|
|
@ -224,6 +227,7 @@ THREAD_LOCAL_DECL(static Scheme_Object *global_shift_cache);
|
|||
#endif
|
||||
|
||||
#define SCHEME_MODNAMEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)
|
||||
#define SCHEME_RMP_VAL(obj) SCHEME_PTR_VAL(obj)
|
||||
|
||||
typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name,
|
||||
Scheme_Object *nominal_modname, Scheme_Object *nominal_export,
|
||||
|
|
@ -804,6 +808,7 @@ static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv)
|
|||
if (argc == 1)
|
||||
return scheme_void; /* ignore notify */
|
||||
|
||||
/* if (quote SYMBOL) */
|
||||
if (SCHEME_PAIRP(p)
|
||||
&& SAME_OBJ(SCHEME_CAR(p), quote_symbol)
|
||||
&& SCHEME_PAIRP(SCHEME_CDR(p))
|
||||
|
|
@ -2791,7 +2796,7 @@ static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[])
|
|||
m = scheme_extract_compiled_module(argv[0]);
|
||||
|
||||
if (m) {
|
||||
return SCHEME_PTR_VAL(m->modname);
|
||||
return resolved_module_path_value(m->modname);
|
||||
}
|
||||
|
||||
scheme_wrong_type("module-compiled-name", "compiled module declaration", 0, argc, argv);
|
||||
|
|
@ -2895,65 +2900,90 @@ void scheme_init_module_path_table()
|
|||
modpath_table = scheme_make_weak_equal_table();
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o)
|
||||
static Scheme_Object *make_resolved_module_path_obj(Scheme_Object *o)
|
||||
{
|
||||
Scheme_Object *rmp;
|
||||
Scheme_Bucket *b;
|
||||
Scheme_Object *return_value;
|
||||
Scheme_Object *newo;
|
||||
|
||||
mzrt_mutex_lock(modpath_table_mutex);
|
||||
|
||||
rmp = scheme_alloc_small_object();
|
||||
rmp->type = scheme_resolved_module_path_type;
|
||||
SCHEME_PTR_VAL(rmp) = o;
|
||||
|
||||
scheme_start_atomic();
|
||||
b = scheme_bucket_from_table(modpath_table, (const char *)rmp);
|
||||
scheme_end_atomic_no_swap();
|
||||
if (!b->val)
|
||||
b->val = scheme_true;
|
||||
|
||||
return_value = (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
|
||||
|
||||
mzrt_mutex_unlock(modpath_table_mutex);
|
||||
|
||||
return return_value;
|
||||
}
|
||||
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
static Scheme_Object *scheme_intern_local_resolved_module_path_worker(Scheme_Object *o)
|
||||
{
|
||||
Scheme_Object *rmp;
|
||||
Scheme_Bucket *b;
|
||||
Scheme_Object *return_value;
|
||||
|
||||
rmp = scheme_alloc_small_object();
|
||||
rmp->type = scheme_resolved_module_path_type;
|
||||
SCHEME_PTR_VAL(rmp) = o;
|
||||
|
||||
scheme_start_atomic();
|
||||
b = scheme_bucket_from_table(place_local_modpath_table, (const char *)rmp);
|
||||
scheme_end_atomic_no_swap();
|
||||
if (!b->val)
|
||||
b->val = scheme_true;
|
||||
|
||||
return_value = (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
|
||||
|
||||
return return_value;
|
||||
}
|
||||
#if defined(MZ_USE_PLACES)
|
||||
if (SCHEME_SYMBOLP(o)) {
|
||||
newo = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(o), 0, SCHEME_SYM_LEN(o), 1);
|
||||
}
|
||||
else {
|
||||
newo = o;
|
||||
}
|
||||
#else
|
||||
newo = o;
|
||||
#endif
|
||||
|
||||
rmp = scheme_alloc_small_object();
|
||||
rmp->type = scheme_resolved_module_path_type;
|
||||
SCHEME_PTR_VAL(rmp) = newo;
|
||||
|
||||
return rmp;
|
||||
}
|
||||
|
||||
static Scheme_Object *resolved_module_path_value(Scheme_Object *rmp)
|
||||
{
|
||||
Scheme_Object *rmp_val;
|
||||
rmp_val = SCHEME_RMP_VAL(rmp);
|
||||
|
||||
/*symbols aren't equal across places now*/
|
||||
#if defined(MZ_USE_PLACES)
|
||||
if (SCHEME_BYTE_STRINGP(rmp_val))
|
||||
return scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(rmp_val), SCHEME_BYTE_STRLEN_VAL(rmp_val));
|
||||
#endif
|
||||
|
||||
return rmp_val;
|
||||
}
|
||||
|
||||
int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o) {
|
||||
Scheme_Object *rmp_val = SCHEME_RMP_VAL(rmp);
|
||||
if (SAME_OBJ(rmp_val, o)) return 1;
|
||||
else if (SCHEME_BYTE_STRINGP(rmp_val) && SCHEME_SYMBOLP(o)) {
|
||||
return !strncmp(SCHEME_BYTE_STR_VAL(rmp_val), SCHEME_SYM_VAL(o), MIN(SCHEME_BYTE_STRLEN_VAL(rmp_val), SCHEME_SYM_LEN(o)));
|
||||
}
|
||||
else {
|
||||
scheme_arg_mismatch("scheme_resolved_module_path_value_matches",
|
||||
"unknown type of resolved_module_path_value",
|
||||
rmp_val);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
|
||||
{
|
||||
Scheme_Bucket_Table *create_table;
|
||||
Scheme_Object *rmp;
|
||||
Scheme_Bucket *b;
|
||||
|
||||
|
||||
rmp = make_resolved_module_path_obj(o);
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *return_payload;
|
||||
if (SCHEME_SYMBOLP(o) && SCHEME_SYM_UNINTERNEDP(o)) {
|
||||
return scheme_intern_local_resolved_module_path_worker(o);
|
||||
if (place_local_modpath_table) {
|
||||
b = scheme_bucket_or_null_from_table(place_local_modpath_table, (const char *)rmp, 0);
|
||||
if (b) {
|
||||
return (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
|
||||
}
|
||||
}
|
||||
return_payload = scheme_master_fast_path(1, o);
|
||||
return (Scheme_Object*) return_payload;
|
||||
#endif
|
||||
return scheme_intern_resolved_module_path_worker(o);
|
||||
b = scheme_bucket_or_null_from_table(modpath_table, (const char *)rmp, 0);
|
||||
if (b) {
|
||||
return (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
|
||||
}
|
||||
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
create_table = place_local_modpath_table ? place_local_modpath_table : modpath_table;
|
||||
#else
|
||||
create_table = modpath_table;
|
||||
#endif
|
||||
|
||||
scheme_start_atomic();
|
||||
b = scheme_bucket_from_table(create_table, (const char *)rmp);
|
||||
scheme_end_atomic_no_swap();
|
||||
if (!b->val)
|
||||
b->val = scheme_true;
|
||||
return(Scheme_Object *)HT_EXTRACT_WEAK(b->key);
|
||||
}
|
||||
|
||||
static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[])
|
||||
|
|
@ -2980,7 +3010,7 @@ static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_MODNAMEP(argv[0]))
|
||||
scheme_wrong_type("resolved-module-path-name", "resolved-module-path", 0, argc, argv);
|
||||
|
||||
return SCHEME_PTR_VAL(argv[0]);
|
||||
return resolved_module_path_value(argv[0]);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -5991,7 +6021,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
|
||||
}
|
||||
|
||||
fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
|
||||
fm = scheme_stx_property(fm, module_name_symbol, resolved_module_path_value(m->modname));
|
||||
|
||||
/* phase shift to replace self_modidx of previous expansion (if any): */
|
||||
fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL);
|
||||
|
|
@ -6010,7 +6040,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
mb = scheme_datum_to_syntax(module_begin_symbol, form, scheme_false, 0, 0);
|
||||
fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null));
|
||||
fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
|
||||
fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
|
||||
fm = scheme_stx_property(fm, module_name_symbol, resolved_module_path_value(m->modname));
|
||||
/* Since fm is a newly-created syntax object, we need to re-add renamings: */
|
||||
fm = scheme_add_rename(fm, rn_set);
|
||||
|
||||
|
|
@ -10065,8 +10095,8 @@ static Scheme_Object *write_module(Scheme_Object *obj)
|
|||
l = cons(scheme_false, l);
|
||||
|
||||
l = cons(m->me->src_modidx, l);
|
||||
l = cons(SCHEME_PTR_VAL(m->modsrc), l);
|
||||
l = cons(SCHEME_PTR_VAL(m->modname), l);
|
||||
l = cons(resolved_module_path_value(m->modsrc), l);
|
||||
l = cons(resolved_module_path_value(m->modname), l);
|
||||
|
||||
return l;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -504,6 +504,7 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
|
|||
scheme_log_abort("cannot copy uninterned symbol");
|
||||
abort();
|
||||
} else
|
||||
scheme_log_abort("NEED SERIALZATION WORK");
|
||||
new_so = so;
|
||||
break;
|
||||
case scheme_pair_type:
|
||||
|
|
@ -647,6 +648,7 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
|
|||
|
||||
a[0] = scheme_places_deep_copy(place_data->module);
|
||||
a[1] = scheme_places_deep_copy(place_data->function);
|
||||
a[1] = scheme_intern_exact_symbol(SCHEME_SYM_VAL(a[1]), SCHEME_SYM_LEN(a[1]));
|
||||
if (!SAME_TYPE(SCHEME_TYPE(place_data->channel), scheme_place_bi_channel_type)) {
|
||||
channel = scheme_places_deep_copy(place_data->channel);
|
||||
}
|
||||
|
|
@ -657,6 +659,13 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
|
|||
|
||||
mzrt_sema_post(place_data->ready);
|
||||
place_data = NULL;
|
||||
# ifdef MZ_PRECISE_GC
|
||||
/* this prevents a master collection attempt from deadlocking with the
|
||||
place_data->ready semaphore above */
|
||||
GC_allow_master_gc_check();
|
||||
# endif
|
||||
|
||||
|
||||
/* at point point, don't refer to place_data or its content
|
||||
anymore, because it's allocated in the other place */
|
||||
|
||||
|
|
@ -689,13 +698,31 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
|
|||
return (void*) rc;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) {
|
||||
# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *return_payload;
|
||||
return_payload = scheme_master_fast_path(5, so);
|
||||
return (Scheme_Object*) return_payload;
|
||||
# ifdef MZ_PRECISE_GC
|
||||
Scheme_Hash_Table *force_hash(Scheme_Object *so);
|
||||
# endif
|
||||
|
||||
Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) {
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
Scheme_Object *o;
|
||||
void *original_gc;
|
||||
Scheme_Hash_Table *ht;
|
||||
|
||||
ht = force_hash(so);
|
||||
|
||||
# ifdef MZ_PRECISE_GC
|
||||
original_gc = GC_switch_to_master_gc();
|
||||
scheme_start_atomic();
|
||||
# endif
|
||||
o = scheme_places_deep_copy_worker(so, ht);
|
||||
# ifdef MZ_PRECISE_GC
|
||||
scheme_end_atomic_no_swap();
|
||||
GC_switch_back_from_master(original_gc);
|
||||
# endif
|
||||
return o;
|
||||
#else
|
||||
return so;
|
||||
#endif
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) {
|
||||
|
|
@ -824,64 +851,6 @@ void force_hash_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
|
|||
return;
|
||||
}
|
||||
|
||||
static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload)
|
||||
{
|
||||
switch(msg_type) {
|
||||
case 1:
|
||||
{
|
||||
Scheme_Object *o;
|
||||
Scheme_Object *copied_o;
|
||||
copied_o = scheme_places_deep_copy((Scheme_Object *)msg_payload);
|
||||
o = scheme_intern_resolved_module_path_worker(copied_o);
|
||||
return o;
|
||||
}
|
||||
break;
|
||||
case 3:
|
||||
{
|
||||
Scheme_Object *o;
|
||||
Scheme_Symbol_Parts *parts;
|
||||
parts = (Scheme_Symbol_Parts *) msg_payload;
|
||||
o = (Scheme_Object *)scheme_intern_exact_symbol_in_table_worker(parts->table, parts->kind, parts->name, parts->len);
|
||||
return o;
|
||||
}
|
||||
break;
|
||||
case 5:
|
||||
{
|
||||
Scheme_Object *copied_o;
|
||||
copied_o = scheme_places_deep_copy((Scheme_Object *)msg_payload);
|
||||
return copied_o;
|
||||
}
|
||||
break;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
void* scheme_master_fast_path(int msg_type, void *msg_payload) {
|
||||
Scheme_Object *o;
|
||||
void *original_gc;
|
||||
Scheme_Hash_Table *ht;
|
||||
|
||||
switch(msg_type) {
|
||||
case 1:
|
||||
case 5:
|
||||
ht = force_hash(msg_payload);
|
||||
break;
|
||||
}
|
||||
|
||||
# ifdef MZ_PRECISE_GC
|
||||
original_gc = GC_switch_to_master_gc();
|
||||
scheme_start_atomic();
|
||||
# endif
|
||||
o = scheme_master_place_handlemsg(msg_type, msg_payload);
|
||||
# ifdef MZ_PRECISE_GC
|
||||
scheme_end_atomic_no_swap();
|
||||
GC_switch_back_from_master(original_gc);
|
||||
# endif
|
||||
|
||||
return o;
|
||||
}
|
||||
|
||||
|
||||
void scheme_spawn_master_place() {
|
||||
mzrt_proc_first_thread_init();
|
||||
|
||||
|
|
|
|||
|
|
@ -4109,7 +4109,7 @@ static Scheme_Object *do_load_handler(void *data)
|
|||
m = scheme_extract_compiled_module(SCHEME_STX_VAL(d));
|
||||
if (m) {
|
||||
if (check_module_name) {
|
||||
if (!SAME_OBJ(SCHEME_PTR_VAL(m->modname), lhd->expected_module)) {
|
||||
if (!scheme_resolved_module_path_value_matches(m->modname, lhd->expected_module)) {
|
||||
other = m->modname;
|
||||
d = NULL;
|
||||
}
|
||||
|
|
@ -4139,8 +4139,9 @@ static Scheme_Object *do_load_handler(void *data)
|
|||
|
||||
/* If d is NULL, shape was wrong */
|
||||
if (!d) {
|
||||
Scheme_Object *err_msg;
|
||||
if (!other || !SCHEME_SYMBOLP(other))
|
||||
other = scheme_make_byte_string("something else");
|
||||
err_msg = scheme_make_byte_string("something else");
|
||||
else {
|
||||
char *s, *t;
|
||||
long len, slen;
|
||||
|
|
@ -4155,7 +4156,7 @@ static Scheme_Object *do_load_handler(void *data)
|
|||
s[len + slen] = '\'';
|
||||
s[len + slen + 1]= 0;
|
||||
|
||||
other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
|
||||
err_msg = scheme_make_sized_byte_string(s, len + slen + 1, 0);
|
||||
}
|
||||
|
||||
{
|
||||
|
|
@ -4164,7 +4165,7 @@ static Scheme_Object *do_load_handler(void *data)
|
|||
scheme_raise_exn(MZEXN_FAIL,
|
||||
"default-load-handler: expected a `module' declaration for `%S', found: %T in: %V",
|
||||
lhd->expected_module,
|
||||
other,
|
||||
err_msg,
|
||||
ip->name);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -263,6 +263,7 @@ void scheme_init_variable_references_constants(void);
|
|||
void scheme_init_logger(void);
|
||||
void scheme_init_file_places(void);
|
||||
void scheme_init_foreign_places(void);
|
||||
void scheme_init_place_local_symbol_table(void);
|
||||
|
||||
Scheme_Logger *scheme_get_main_logger(void);
|
||||
void scheme_init_logger_config(void);
|
||||
|
|
@ -2977,8 +2978,9 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
|
|||
Scheme_Object *shift_from_modidx,
|
||||
Scheme_Object *shift_to_modidx);
|
||||
|
||||
#define SCHEME_RMPP(o) (SAME_TYPE(SCHEME_TYPE((o)), scheme_resolved_module_path_type))
|
||||
Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o);
|
||||
Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o);
|
||||
int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object *o);
|
||||
|
||||
Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx,
|
||||
Scheme_Object *stxsym, Scheme_Object *insp,
|
||||
|
|
@ -3322,7 +3324,6 @@ void scheme_alloc_global_fdset();
|
|||
/*========================================================================*/
|
||||
|
||||
#ifdef MEMORY_COUNTING_ON
|
||||
extern Scheme_Hash_Table *scheme_symbol_table;
|
||||
extern long scheme_type_table_count;
|
||||
extern long scheme_misc_count;
|
||||
|
||||
|
|
@ -3386,7 +3387,6 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void
|
|||
|
||||
void scheme_set_root_param(int p, Scheme_Object *v);
|
||||
|
||||
Scheme_Object *scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len);
|
||||
Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, unsigned int len);
|
||||
Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2);
|
||||
Scheme_Object *scheme_copy_list(Scheme_Object *l);
|
||||
|
|
@ -3436,7 +3436,6 @@ typedef struct Scheme_Symbol_Parts {
|
|||
} Scheme_Symbol_Parts;
|
||||
|
||||
void scheme_spawn_master_place();
|
||||
void *scheme_master_fast_path(int msg_type, void *msg_payload);
|
||||
void scheme_places_block_child_signal();
|
||||
int scheme_get_child_status(int pid, int *status);
|
||||
int scheme_places_register_child(int pid, void *signal_fd, int *status);
|
||||
|
|
|
|||
|
|
@ -166,7 +166,7 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
|
|||
static void register_traversers(void);
|
||||
#endif
|
||||
|
||||
SHARED_OK static Scheme_Bucket_Table *prefab_table;
|
||||
THREAD_LOCAL_DECL(static Scheme_Bucket_Table *prefab_table);
|
||||
static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type);
|
||||
|
||||
#define cons scheme_make_pair
|
||||
|
|
@ -632,9 +632,6 @@ scheme_init_struct (Scheme_Env *env)
|
|||
REGISTER_SO(prefab_symbol);
|
||||
prefab_symbol = scheme_intern_symbol("prefab");
|
||||
|
||||
REGISTER_SO(prefab_table);
|
||||
prefab_table = scheme_make_weak_equal_table();
|
||||
|
||||
|
||||
REGISTER_SO(scheme_source_property);
|
||||
{
|
||||
|
|
@ -3677,10 +3674,12 @@ static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base,
|
|||
char *immutable_array)
|
||||
{
|
||||
#ifdef MZ_USE_PLACES
|
||||
/*
|
||||
return scheme_make_prefab_struct_type_in_master
|
||||
*/
|
||||
#else
|
||||
return scheme_make_prefab_struct_type_raw
|
||||
#endif
|
||||
return scheme_make_prefab_struct_type_raw
|
||||
(base,
|
||||
parent,
|
||||
num_fields,
|
||||
|
|
@ -4056,7 +4055,12 @@ static Scheme_Struct_Type *lookup_prefab(Scheme_Object *key) {
|
|||
static Scheme_Struct_Type *hash_prefab(Scheme_Struct_Type *type)
|
||||
{
|
||||
Scheme_Object *k, *v;
|
||||
|
||||
|
||||
if (!prefab_table) {
|
||||
REGISTER_SO(prefab_table);
|
||||
prefab_table = scheme_make_weak_equal_table();
|
||||
}
|
||||
|
||||
k = make_prefab_key(type);
|
||||
type->prefab_key = k;
|
||||
|
||||
|
|
@ -4330,7 +4334,19 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type)
|
|||
if (!SCHEME_NULLP(stack))
|
||||
key = scheme_make_pair(scheme_make_integer(icnt), key);
|
||||
|
||||
/*symbols aren't equal? across places now*/
|
||||
#if defined(MZ_USE_PLACES)
|
||||
if (SCHEME_SYMBOLP(type->name)) {
|
||||
Scheme_Object *newname;
|
||||
newname = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(type->name), 0, SCHEME_SYM_LEN(type->name), 1);
|
||||
key = scheme_make_pair(newname, key);
|
||||
}
|
||||
else {
|
||||
scheme_arg_mismatch("make_prefab_key", "unknown type of struct name", type->name);
|
||||
}
|
||||
#else
|
||||
key = scheme_make_pair(type->name, key);
|
||||
#endif
|
||||
|
||||
if (SCHEME_PAIRP(stack)) {
|
||||
type = (Scheme_Struct_Type *)SCHEME_CAR(stack);
|
||||
|
|
@ -4390,8 +4406,19 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
|
|||
int ucnt, icnt;
|
||||
char *immutable_array = NULL;
|
||||
|
||||
/*symbols aren't equal? across places now*/
|
||||
#if defined(MZ_USE_PLACES)
|
||||
if (SCHEME_SYMBOLP(key)) {
|
||||
Scheme_Object *newname;
|
||||
newname = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(key), 0, SCHEME_SYM_LEN(key), 1);
|
||||
key = scheme_make_pair(newname, scheme_null);
|
||||
}
|
||||
if (SCHEME_BYTE_STRINGP(key))
|
||||
key = scheme_make_pair(key, scheme_null);
|
||||
#else
|
||||
if (SCHEME_SYMBOLP(key))
|
||||
key = scheme_make_pair(key, scheme_null);
|
||||
#endif
|
||||
|
||||
if (scheme_proper_list_length(key) < 0)
|
||||
return NULL;
|
||||
|
|
@ -4465,9 +4492,21 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
|
|||
a = SCHEME_CAR(key);
|
||||
key = SCHEME_CDR(key);
|
||||
|
||||
/*symbols aren't equal? across places now*/
|
||||
#if defined(MZ_USE_PLACES)
|
||||
if (SCHEME_SYMBOLP(a)) {
|
||||
name = a;
|
||||
}
|
||||
else if (SCHEME_BYTE_STRINGP(a))
|
||||
name = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a));
|
||||
else
|
||||
return NULL;
|
||||
#else
|
||||
if (!SCHEME_SYMBOLP(a))
|
||||
return NULL;
|
||||
name = a;
|
||||
#endif
|
||||
|
||||
|
||||
immutable_array = mutability_data_to_immutability_data(icnt + ucnt, mutables);
|
||||
|
||||
|
|
|
|||
|
|
@ -48,18 +48,16 @@ extern MZ_DLLIMPORT void (*GC_custom_finalize)(void);
|
|||
extern int GC_is_marked(void *);
|
||||
#endif
|
||||
|
||||
SHARED_OK Scheme_Hash_Table *scheme_symbol_table = NULL;
|
||||
SHARED_OK Scheme_Hash_Table *scheme_keyword_table = NULL;
|
||||
SHARED_OK Scheme_Hash_Table *scheme_parallel_symbol_table = NULL;
|
||||
|
||||
#ifdef MZ_USE_PLACES
|
||||
SHARED_OK static mzrt_rwlock *symbol_table_lock;
|
||||
#else
|
||||
# define mzrt_rwlock_rdlock(l) /* empty */
|
||||
# define mzrt_rwlock_wrlock(l) /* empty */
|
||||
# define mzrt_rwlock_unlock(l) /* empty */
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
THREAD_LOCAL_DECL(static Scheme_Hash_Table *place_local_symbol_table = NULL;)
|
||||
THREAD_LOCAL_DECL(static Scheme_Hash_Table *place_local_keyword_table = NULL;)
|
||||
THREAD_LOCAL_DECL(static Scheme_Hash_Table *place_local_parallel_symbol_table = NULL;)
|
||||
#endif
|
||||
|
||||
SHARED_OK static Scheme_Hash_Table *symbol_table = NULL;
|
||||
SHARED_OK static Scheme_Hash_Table *keyword_table = NULL;
|
||||
SHARED_OK static Scheme_Hash_Table *parallel_symbol_table = NULL;
|
||||
|
||||
SHARED_OK static unsigned long scheme_max_symbol_length;
|
||||
|
||||
/* globals */
|
||||
|
|
@ -220,20 +218,20 @@ static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table,
|
|||
}
|
||||
|
||||
#ifndef MZ_PRECISE_GC
|
||||
static void clean_one_symbol_table(Scheme_Hash_Table *symbol_table)
|
||||
static void clean_one_symbol_table(Scheme_Hash_Table *table)
|
||||
{
|
||||
/* Clean the symbol table by removing pointers to collected
|
||||
symbols. The correct way to do this is to install a GC
|
||||
finalizer on symbol pointers, but that would be expensive. */
|
||||
|
||||
if (symbol_table) {
|
||||
Scheme_Object **buckets = (Scheme_Object **)symbol_table->keys;
|
||||
int i = symbol_table->size;
|
||||
if (table) {
|
||||
Scheme_Object **buckets = (Scheme_Object **)table->keys;
|
||||
int i = table->size;
|
||||
void *b;
|
||||
|
||||
while (i--) {
|
||||
if (buckets[WEAK_ARRAY_HEADSIZE + i] && !SAME_OBJ(buckets[WEAK_ARRAY_HEADSIZE + i], SYMTAB_LOST_CELL)
|
||||
&& (!(b = GC_base(buckets[WEAK_ARRAY_HEADSIZE + i]))
|
||||
&& (!(b = GC_base(buckets[WEAK_ARRAY_HEADSIZE + i]))
|
||||
#ifndef USE_SENORA_GC
|
||||
|| !GC_is_marked(b)
|
||||
#endif
|
||||
|
|
@ -246,9 +244,10 @@ static void clean_one_symbol_table(Scheme_Hash_Table *symbol_table)
|
|||
|
||||
static void clean_symbol_table(void)
|
||||
{
|
||||
clean_one_symbol_table(scheme_symbol_table);
|
||||
clean_one_symbol_table(scheme_keyword_table);
|
||||
clean_one_symbol_table(scheme_parallel_symbol_table);
|
||||
clean_one_symbol_table(symbol_table);
|
||||
clean_one_symbol_table(keyword_table);
|
||||
clean_one_symbol_table(parallel_symbol_table);
|
||||
|
||||
scheme_clear_ephemerons();
|
||||
# ifdef MZ_USE_JIT
|
||||
scheme_clean_native_symtab();
|
||||
|
|
@ -266,46 +265,56 @@ static void clean_symbol_table(void)
|
|||
|
||||
static Scheme_Hash_Table *init_one_symbol_table()
|
||||
{
|
||||
Scheme_Hash_Table *symbol_table;
|
||||
Scheme_Hash_Table *table;
|
||||
int size;
|
||||
Scheme_Object **ba;
|
||||
|
||||
symbol_table = scheme_make_hash_table(SCHEME_hash_ptr);
|
||||
table = scheme_make_hash_table(SCHEME_hash_ptr);
|
||||
|
||||
symbol_table->size = HASH_TABLE_INIT_SIZE;
|
||||
table->size = HASH_TABLE_INIT_SIZE;
|
||||
|
||||
size = symbol_table->size * sizeof(Scheme_Object *);
|
||||
size = table->size * sizeof(Scheme_Object *);
|
||||
#ifdef MZ_PRECISE_GC
|
||||
ba = (Scheme_Object **)GC_malloc_weak_array(size, SYMTAB_LOST_CELL);
|
||||
#else
|
||||
ba = MALLOC_N_ATOMIC(Scheme_Object *, size);
|
||||
memset((char *)ba, 0, size);
|
||||
#endif
|
||||
symbol_table->keys = ba;
|
||||
table->keys = ba;
|
||||
|
||||
return symbol_table;
|
||||
return table;
|
||||
}
|
||||
|
||||
void
|
||||
scheme_init_symbol_table ()
|
||||
{
|
||||
REGISTER_SO(scheme_symbol_table);
|
||||
REGISTER_SO(scheme_keyword_table);
|
||||
REGISTER_SO(scheme_parallel_symbol_table);
|
||||
REGISTER_SO(symbol_table);
|
||||
REGISTER_SO(keyword_table);
|
||||
REGISTER_SO(parallel_symbol_table);
|
||||
|
||||
scheme_symbol_table = init_one_symbol_table();
|
||||
scheme_keyword_table = init_one_symbol_table();
|
||||
scheme_parallel_symbol_table = init_one_symbol_table();
|
||||
|
||||
#ifdef MZ_USE_PLACES
|
||||
mzrt_rwlock_create(&symbol_table_lock);
|
||||
#endif
|
||||
symbol_table = init_one_symbol_table();
|
||||
keyword_table = init_one_symbol_table();
|
||||
parallel_symbol_table = init_one_symbol_table();
|
||||
|
||||
#ifndef MZ_PRECISE_GC
|
||||
GC_custom_finalize = clean_symbol_table;
|
||||
#endif
|
||||
}
|
||||
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void
|
||||
scheme_init_place_local_symbol_table ()
|
||||
{
|
||||
REGISTER_SO(place_local_symbol_table);
|
||||
REGISTER_SO(place_local_keyword_table);
|
||||
REGISTER_SO(place_local_parallel_symbol_table);
|
||||
|
||||
place_local_symbol_table = init_one_symbol_table();
|
||||
place_local_keyword_table = init_one_symbol_table();
|
||||
place_local_parallel_symbol_table = init_one_symbol_table();
|
||||
}
|
||||
#endif
|
||||
|
||||
void
|
||||
scheme_init_symbol_type (Scheme_Env *env)
|
||||
{
|
||||
|
|
@ -388,56 +397,94 @@ scheme_make_exact_char_symbol(const mzchar *name, unsigned int len)
|
|||
return make_a_symbol(bs, blen, 0x1);
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
scheme_intern_exact_symbol_in_table_worker(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
|
||||
typedef enum {
|
||||
enum_symbol,
|
||||
enum_keyword,
|
||||
enum_parallel_symbol,
|
||||
} enum_symbol_table_type;
|
||||
|
||||
static Scheme_Object *
|
||||
intern_exact_symbol_in_table_worker(enum_symbol_table_type type, int kind, const char *name, unsigned int len)
|
||||
{
|
||||
Scheme_Object *sym;
|
||||
Scheme_Hash_Table *table;
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
Scheme_Hash_Table *place_local_table;
|
||||
#endif
|
||||
|
||||
mzrt_rwlock_rdlock(symbol_table_lock);
|
||||
sym = symbol_bucket(symbol_table, name, len, NULL);
|
||||
mzrt_rwlock_unlock(symbol_table_lock);
|
||||
sym = NULL;
|
||||
|
||||
switch(type) {
|
||||
case enum_symbol:
|
||||
table = symbol_table;
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
place_local_table = place_local_symbol_table;
|
||||
#endif
|
||||
break;
|
||||
case enum_keyword:
|
||||
table = keyword_table;
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
place_local_table = place_local_keyword_table;
|
||||
#endif
|
||||
break;
|
||||
case enum_parallel_symbol:
|
||||
table = parallel_symbol_table;
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
place_local_table = place_local_parallel_symbol_table;
|
||||
#endif
|
||||
break;
|
||||
default:
|
||||
printf("Invalid enum_symbol_table_type %i\n", type);
|
||||
abort();
|
||||
}
|
||||
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
if (place_local_table) {
|
||||
sym = symbol_bucket(place_local_table, name, len, NULL);
|
||||
}
|
||||
#endif
|
||||
if (!sym && table) {
|
||||
sym = symbol_bucket(table, name, len, NULL);
|
||||
}
|
||||
if (!sym) {
|
||||
/* create symbol in symbol table unless a place local symbol table has been created */
|
||||
/* once the first place has been create the symbol_table becomes read-only and
|
||||
shouldn't be modified */
|
||||
|
||||
Scheme_Object *newsymbol;
|
||||
Scheme_Hash_Table *create_table;
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
create_table = place_local_table ? place_local_table : table;
|
||||
#else
|
||||
create_table = table;
|
||||
#endif
|
||||
newsymbol = make_a_symbol(name, len, kind);
|
||||
|
||||
/* we must return the result of this symbol bucket call because another
|
||||
* thread could have inserted the same symbol between the first
|
||||
* :qsymbol_bucket call above and this one */
|
||||
mzrt_rwlock_wrlock(symbol_table_lock);
|
||||
sym = symbol_bucket(symbol_table, name, len, newsymbol);
|
||||
mzrt_rwlock_unlock(symbol_table_lock);
|
||||
* symbol_bucket call above and this one */
|
||||
sym = symbol_bucket(create_table, name, len, newsymbol);
|
||||
}
|
||||
|
||||
return sym;
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
scheme_intern_exact_symbol_in_table(Scheme_Hash_Table *symbol_table, int kind, const char *name, unsigned int len)
|
||||
static Scheme_Object *
|
||||
intern_exact_symbol_in_table(enum_symbol_table_type type, int kind, const char *name, unsigned int len)
|
||||
{
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *return_payload;
|
||||
Scheme_Symbol_Parts parts;
|
||||
parts.table = symbol_table;
|
||||
parts.kind = kind;
|
||||
parts.len = len;
|
||||
parts.name = name;
|
||||
return_payload = scheme_master_fast_path(3, &parts);
|
||||
return (Scheme_Object*) return_payload;
|
||||
#endif
|
||||
return scheme_intern_exact_symbol_in_table_worker(symbol_table, kind, name, len);
|
||||
return intern_exact_symbol_in_table_worker(type, kind, name, len);
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
scheme_intern_exact_symbol(const char *name, unsigned int len)
|
||||
{
|
||||
return scheme_intern_exact_symbol_in_table(scheme_symbol_table, 0, name, len);
|
||||
return intern_exact_symbol_in_table(enum_symbol, 0, name, len);
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
scheme_intern_exact_parallel_symbol(const char *name, unsigned int len)
|
||||
{
|
||||
return scheme_intern_exact_symbol_in_table(scheme_parallel_symbol_table, 0x2, name, len);
|
||||
return intern_exact_symbol_in_table(enum_parallel_symbol, 0x2, name, len);
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
|
|
@ -446,14 +493,14 @@ scheme_intern_exact_char_symbol(const mzchar *name, unsigned int len)
|
|||
char buf[64], *bs;
|
||||
long blen;
|
||||
bs = scheme_utf8_encode_to_buffer_len(name, len, buf, 64, &blen);
|
||||
return scheme_intern_exact_symbol_in_table(scheme_symbol_table, 0, bs, blen);
|
||||
return intern_exact_symbol_in_table(enum_symbol, 0, bs, blen);
|
||||
}
|
||||
|
||||
Scheme_Object *
|
||||
scheme_intern_exact_keyword(const char *name, unsigned int len)
|
||||
{
|
||||
Scheme_Object *s;
|
||||
s = scheme_intern_exact_symbol_in_table(scheme_keyword_table, 0, name, len);
|
||||
s = intern_exact_symbol_in_table(enum_keyword, 0, name, len);
|
||||
if (s->type == scheme_symbol_type)
|
||||
s->type = scheme_keyword_type;
|
||||
return s;
|
||||
|
|
@ -465,7 +512,7 @@ Scheme_Object *scheme_intern_exact_char_keyword(const mzchar *name, unsigned int
|
|||
long blen;
|
||||
Scheme_Object *s;
|
||||
bs = scheme_utf8_encode_to_buffer_len(name, len, buf, 64, &blen);
|
||||
s = scheme_intern_exact_symbol_in_table(scheme_keyword_table, 0, bs, blen);
|
||||
s = intern_exact_symbol_in_table(enum_keyword, 0, bs, blen);
|
||||
if (s->type == scheme_symbol_type)
|
||||
s->type = scheme_keyword_type;
|
||||
return s;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user