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

Syncing

Browse Source 
svn: r12929
This commit is contained in:
Stevie Strickland 2008-12-23 03:20:02 +00:00
commit 9e4d8d08b9
45 changed files with 1286 additions and 572 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/decompile.ss
View File

@ -172,9 +172,9 @@
(define (decompile-expr expr globs stack closed)
(match expr
[(struct toplevel (depth pos const? mutated?))
[(struct toplevel (depth pos const? ready?))
(let ([id (list-ref/protect globs pos 'toplevel)])
(if const?
(if (or const? ready?)
id
`(#%checked ,id)))]
[(struct topsyntax (depth pos midpt))

6
collects/compiler/zo-parse.ss
View File

@ -37,7 +37,7 @@
(define-form-struct localref (unbox? offset clear?)) ; access local via stack
(define-form-struct toplevel (depth pos const? mutated?)) ; access binding via prefix array (which is on stack)
(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
(define-form-struct application (rator rands)) ; function call
@ -68,12 +68,12 @@
(define (read-toplevel v)
(define SCHEME_TOPLEVEL_CONST #x01)
(define SCHEME_TOPLEVEL_MUTATED #x02)
(define SCHEME_TOPLEVEL_READY #x02)
(match v
[(cons depth (cons pos flags))
(make-toplevel depth pos
(positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST))
(positive? (bitwise-and flags SCHEME_TOPLEVEL_MUTATED)))]
(positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))]
[(cons depth pos)
(make-toplevel depth pos #f #f)]))

17
collects/drscheme/private/unit.ss
View File

@ -3082,7 +3082,7 @@ module browser threading seems wrong.
(define/override (edit-menu:between-find-and-preferences edit-menu)
(super edit-menu:between-find-and-preferences edit-menu)
(new menu-item%
(new menu:can-restore-menu-item%
[label (string-constant complete-word)]
[shortcut #\/]
[parent edit-menu]
@ -3096,6 +3096,21 @@ module browser threading seems wrong.
(send (get-edit-target-object) auto-complete))])
(add-modes-submenu edit-menu))
(define/override (edit-menu:between-select-all-and-find edit-menu)
(new menu:can-restore-checkable-menu-item%
[label (string-constant overwrite-mode)]
[parent edit-menu]
[demand-callback
(λ (mi)
(let ([target (get-edit-target-object)])
(send mi enable (get-edit-target-object))
(send mi check (and target (send target get-overwrite-mode)))))]
[callback (λ (x y)
(let ([target (get-edit-target-object)])
(send target set-overwrite-mode
(not (send target get-overwrite-mode)))))])
(super edit-menu:between-select-all-and-find edit-menu))
;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key)))
(define capability-menu-items (make-hasheq))
(define/public (register-capability-menu-item key menu)

15
collects/ffi/objc.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/foreign (only-in '#%foreign ffi-call)
(require scheme/foreign
scheme/stxparam
(for-syntax scheme/base))
(unsafe!)
@ -73,12 +73,13 @@
(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
;; First type in `types' vector is the result type
(or (hash-ref msgSends types #f)
(let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0))
'(float double double*))
msgSend_fpret
msgSend)
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0))])
(let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0))
'(float double double*))
msgSend_fpret
msgSend)
(_cprocedure
(list* first-arg-type _SEL (cdr (vector->list types)))
(vector-ref types 0)))])
(hash-set! msgSends types m)
m)))

11
collects/framework/private/keymap.ss
View File

@ -860,8 +860,9 @@
[toggle-overwrite
(λ (edit event)
(send edit set-overwrite-mode
(not (send edit get-overwrite-mode))))]
(when (preferences:get 'framework:overwrite-mode-keybindings)
(send edit set-overwrite-mode
(not (send edit get-overwrite-mode)))))]
[down-into-embedded-editor
(λ (text event)
@ -1016,7 +1017,7 @@
(add "forward-to-next-embedded-editor" forward-to-next-embedded-editor)
(add "back-to-prev-embedded-editor" back-to-prev-embedded-editor)
(add "toggle-overwrite" toggle-overwrite)
(add "toggle-overwrite (when enabled in prefs)" toggle-overwrite)
(add "exit" (λ (edit event)
(let ([frame (send edit get-frame)])
@ -1241,8 +1242,8 @@
(map "c:space" "toggle-anchor")
(map "insert" "toggle-overwrite")
(map-meta "o" "toggle-overwrite")
(map "insert" "toggle-overwrite (when enabled in prefs)")
(map-meta "o" "toggle-overwrite (when enabled in prefs)")
(map-meta "g" "goto-line")

2
collects/framework/private/main.ss
View File

@ -20,6 +20,8 @@
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:overwrite-mode-keybindings #f boolean?)
(preferences:set-default 'framework:ask-about-paste-normalization #t boolean?)
(preferences:set-default 'framework:do-paste-normalization #t boolean?)

4
collects/framework/private/preferences.ss
View File

@ -447,6 +447,10 @@ the state transitions / contracts are:
'framework:do-paste-normalization
(string-constant normalize-string-preference)
values values)
(make-check editor-panel
'framework:overwrite-mode-keybindings
(string-constant enable-overwrite-mode-keybindings)
values values)
(editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel)))

2
collects/frtime/frtime.scrbl
View File

@ -14,7 +14,7 @@
@author["Greg Cooper"]
The @scheme[frtime.ss] language supports declarative construction of
The @schememodname[frtime] language supports declarative construction of
reactive systems in a syntax very similar to that of MzScheme. To
interact with FrTime, select FrTime from the "Choose Language" menu.
You can also make FrTime the language for a module:

2
collects/games/chat-noir/chat-noir-module.ss
View File

@ -1,5 +1,5 @@
(module chat-noir-module lang/htdp-intermediate-lambda
(require (lib "world.ss" "htdp"))
(require "hash.ss")
; (require "hash.ss")
(require (lib "include.ss" "scheme"))
(include "chat-noir.ss"))

819
collects/games/chat-noir/chat-noir.ss
View File

@ -1,7 +1,14 @@
(require "hash.ss")
;; constants
(define circle-radius 20)
(define circle-spacing 22)
(define normal-color 'lightskyblue)
(define on-shortest-path-color normal-color)
;(define on-shortest-path-color 'cornflowerblue)
(define blocked-color 'black)
;; data definitions
;; a world is:
@ -47,7 +54,9 @@
;; world->image : world -> image
(define (world->image w)
(chop-whiskers
(overlay (board->image (world-board w) (world-size w))
(overlay (board->image (world-board w)
(world-size w)
(on-cats-path? w))
(move-pinhole
(cond
[(equal? (world-state w) 'cat-won) happy-cat]
@ -55,7 +64,7 @@
[else thinking-cat])
(- (cell-center-x (world-cat w)))
(- (cell-center-y (world-cat w)))))))
(check-expect
(world->image
(make-world (list (make-cell (make-posn 0 1) false))
@ -64,10 +73,12 @@
2))
(overlay
(board->image (list (make-cell (make-posn 0 1) false))
2)
2
(lambda (x) true))
(move-pinhole thinking-cat
(- (cell-center-x (make-posn 0 1)))
(- (cell-center-y (make-posn 0 1))))))
(check-expect
(world->image
(make-world (list (make-cell (make-posn 0 1) false))
@ -76,10 +87,12 @@
2))
(overlay
(board->image (list (make-cell (make-posn 0 1) false))
2)
2
(lambda (x) true))
(move-pinhole happy-cat
(- (cell-center-x (make-posn 0 1)))
(- (cell-center-y (make-posn 0 1))))))
(check-expect
(world->image
(make-world (list (make-cell (make-posn 0 1) false))
@ -88,7 +101,8 @@
2))
(overlay
(board->image (list (make-cell (make-posn 0 1) false))
2)
2
(lambda (x) true))
(move-pinhole sad-cat
(- (cell-center-x (make-posn 0 1)))
(- (cell-center-y (make-posn 0 1))))))
@ -111,65 +125,108 @@
(pinhole-x
(world->image
(make-world
(list (make-cell (make-posn 0 0) false)
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false))
(empty-board 3)
(make-posn 0 0)
'playing
2)))
3)))
0)
(check-expect
(pinhole-x
(world->image
(make-world
(list (make-cell (make-posn 0 0) false)
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false))
(empty-board 3)
(make-posn 0 1)
'playing
2)))
3)))
0)
;; board->image : board number -> image
(define (board->image cs world-size)
;; board->image : board number (posn -> boolean) -> image
(define (board->image cs world-size on-cat-path?)
(foldl (lambda (x y) (overlay y x))
(nw:rectangle (world-width world-size)
(world-height world-size)
'solid
'white)
(map cell->image cs)))
(map (lambda (c) (cell->image c (on-cat-path? (cell-p c))))
cs)))
(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3)
(check-expect (board->image (list (make-cell (make-posn 0 0) false))
3
(lambda (x) false))
(overlay
(nw:rectangle (world-width 3)
(world-height 3)
'solid
'white)
(cell->image (make-cell (make-posn 0 0) false))))
(cell->image (make-cell (make-posn 0 0) false)
false)))
(check-expect (board->image (list (make-cell (make-posn 0 0) false))
3
(lambda (x) true))
(overlay
(nw:rectangle (world-width 3)
(world-height 3)
'solid
'white)
(cell->image (make-cell (make-posn 0 0) false)
true)))
;; cell->image : cell -> image
(define (cell->image c)
(check-expect (board->image (list (make-cell (make-posn 0 0) false))
3
(lambda (x) false))
(overlay
(nw:rectangle (world-width 3)
(world-height 3)
'solid
'white)
(cell->image (make-cell (make-posn 0 0) false)
false)))
(check-expect (board->image (list (make-cell (make-posn 0 0) false)
(make-cell (make-posn 0 1) false))
3
(lambda (x) (equal? x (make-posn 0 1))))
(overlay
(nw:rectangle (world-width 3)
(world-height 3)
'solid
'white)
(cell->image (make-cell (make-posn 0 0) false)
false)
(cell->image (make-cell (make-posn 0 1) false)
true)))
;; cell->image : cell boolean -> image
(define (cell->image c on-short-path?)
(local [(define x (cell-center-x (cell-p c)))
(define y (cell-center-y (cell-p c)))]
(move-pinhole
(cond
[on-short-path?
(circle circle-radius 'solid on-shortest-path-color)]
[(cell-blocked? c)
(circle circle-radius 'solid 'black)]
(circle circle-radius 'solid blocked-color)]
[else
(circle circle-radius 'solid 'lightblue)])
(circle circle-radius 'solid normal-color)])
(- x)
(- y))))
(check-expect (cell->image (make-cell (make-posn 0 0) false))
(move-pinhole (circle circle-radius 'solid 'lightblue)
(check-expect (cell->image (make-cell (make-posn 0 0) false) false)
(move-pinhole (circle circle-radius 'solid normal-color)
(- circle-radius)
(- circle-radius)))
(check-expect (cell->image (make-cell (make-posn 0 0) true))
(check-expect (cell->image (make-cell (make-posn 0 0) true) false)
(move-pinhole (circle circle-radius 'solid 'black)
(- circle-radius)
(- circle-radius)))
(check-expect (cell->image (make-cell (make-posn 0 0) false) true)
(move-pinhole (circle circle-radius 'solid on-shortest-path-color)
(- circle-radius)
(- circle-radius)))
;; world-width : number -> number
;; computes the width of the drawn world in terms of its size
@ -249,231 +306,227 @@
;; - (make-dist-cell posn (number or '∞))
(define-struct dist-cell (p n))
;; build-table/fast : world -> distance-map
(define (build-table/fast world)
(local [(define board-size (world-size world))
(define blocked (make-hash))
(define ht (make-hash))
(define (search p)
;; build-bfs-table : world (or/c 'boundary posn) -> distance-table
(define (build-bfs-table world init-point)
(local [;; posn : posn
;; dist : number
(define-struct queue-ent (posn dist))
(define neighbors/w (neighbors world))
(define (bfs queue dist-table)
(cond
[(hash-ref blocked p)
'∞]
[(on-boundary? p board-size)
((lambda (a b) b)
(hash-set! ht p 0)
0)]
[(not (boolean? (hash-ref ht p #f)))
(hash-ref ht p)]
[(empty? queue) dist-table]
[else
((lambda (a b c) c)
(hash-set! ht p '∞)
(hash-set!
ht
p
(add1/f (min-l (map search
(adjacent p board-size)))))
(hash-ref ht p))]))]
((lambda (a b c) c)
(for-each (lambda (cell)
(hash-set! blocked
(cell-p cell)
(cell-blocked? cell)))
(world-board world))
(search (world-cat world))
(hash-map ht make-dist-cell))))
(local [(define hd (first queue))]
(cond
[(boolean? (hash-ref dist-table (queue-ent-posn hd) #f))
(local [(define dist (queue-ent-dist hd))
(define p (queue-ent-posn hd))]
(bfs
(append (rest queue)
(map (lambda (p) (make-queue-ent p (+ dist 1)))
(neighbors/w p)))
(hash-set dist-table p dist)))]
[else
(bfs (rest queue) dist-table)]))]))]
(hash-map
(bfs (list (make-queue-ent init-point 0))
(make-immutable-hash/list-init))
make-dist-cell)))
;; build-table : world -> distance-map
(define (build-table world)
(build-distance (world-board world)
(world-cat world)
'()
'()
(world-size world)))
;; same-sets? : (listof X) (listof X) -> boolean
(define (same-sets? l1 l2)
(and (andmap (lambda (e1) (member e1 l2)) l1)
(andmap (lambda (e2) (member e2 l1)) l2)))
;; build-distance : board posn distance-map (listof posn) number -> distance-map
(define (build-distance board p t visited board-size)
(cond
[(cell-blocked? (lookup-board board p))
(add-to-table p '∞ t)]
[(on-boundary? p board-size)
(add-to-table p 0 t)]
[(in-table? t p)
t]
[(member p visited)
(add-to-table p '∞ t)]
[else
(local [(define neighbors (adjacent p board-size))
(define neighbors-t (build-distances
board
neighbors
t
(cons p visited)
board-size))]
(add-to-table p
(add1/f
(min-l
(map (lambda (neighbor)
(lookup-in-table neighbors-t neighbor))
neighbors)))
neighbors-t))]))
(check-expect (same-sets? (list) (list)) true)
(check-expect (same-sets? (list) (list 1)) false)
(check-expect (same-sets? (list 1) (list)) false)
(check-expect (same-sets? (list 1 2) (list 2 1)) true)
;; build-distances : board (listof posn) distance-map (listof posn) number
;; -> distance-map
(define (build-distances board ps t visited board-size)
(cond
[(empty? ps) t]
[else
(build-distances board
(rest ps)
(build-distance board (first ps) t visited board-size)
visited
board-size)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(check-expect (build-distance (list (make-cell (make-posn 0 0) false))
(make-posn 0 0)
'()
'()
1)
(list (make-dist-cell (make-posn 0 0) 0)))
(check-expect (build-distance (list (make-cell (make-posn 0 0) true))
(make-posn 0 0)
'()
'()
1)
(list (make-dist-cell (make-posn 0 0) '∞)))
(check-expect (build-distance (list (make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 1 2) false)
(make-cell (make-posn 2 0) false)
(make-cell (make-posn 2 1) false)
(make-cell (make-posn 2 2) false))
(make-posn 1 1)
'()
'()
3)
(list (make-dist-cell (make-posn 1 0) 0)
(make-dist-cell (make-posn 2 0) 0)
(make-dist-cell (make-posn 0 1) 0)
(make-dist-cell (make-posn 2 1) 0)
(make-dist-cell (make-posn 1 2) 0)
(make-dist-cell (make-posn 2 2) 0)
(make-dist-cell (make-posn 1 1) 1)))
(check-expect (build-distance (list (make-cell (make-posn 0 1) true)
(make-cell (make-posn 1 0) true)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 1 2) true)
(make-cell (make-posn 2 0) true)
(make-cell (make-posn 2 1) true)
(make-cell (make-posn 2 2) true))
(make-posn 1 1)
'()
'()
3)
(list (make-dist-cell (make-posn 1 0) '∞)
(make-dist-cell (make-posn 2 0) '∞)
(make-dist-cell (make-posn 0 1) '∞)
(make-dist-cell (make-posn 2 1) '∞)
(make-dist-cell (make-posn 1 2) '∞)
(make-dist-cell (make-posn 2 2) '∞)
(make-dist-cell (make-posn 1 1) '∞)))
(check-expect (build-distance
(append-all
(build-list
5
(lambda (i)
(build-list
5
(lambda (j)
(make-cell (make-posn i j) false))))))
(make-posn 2 2)
'()
'()
5)
(list (make-dist-cell (make-posn 1 0) 0)
(make-dist-cell (make-posn 2 0) 0)
(make-dist-cell (make-posn 0 1) 0)
(make-dist-cell (make-posn 3 0) 0)
(make-dist-cell (make-posn 1 1) 1)
(make-dist-cell (make-posn 4 0) 0)
(make-dist-cell (make-posn 2 1) 1)
(make-dist-cell (make-posn 4 1) 0)
(make-dist-cell (make-posn 3 1) 1)
(make-dist-cell (make-posn 2 2) 2)
(make-dist-cell (make-posn 4 2) 0)
(make-dist-cell (make-posn 3 2) 1)
(make-dist-cell (make-posn 0 2) 0)
(make-dist-cell (make-posn 0 3) 0)
(make-dist-cell (make-posn 1 3) 1)
(make-dist-cell (make-posn 1 2) 1)
(make-dist-cell (make-posn 2 3) 1)
(make-dist-cell (make-posn 1 4) 0)
(make-dist-cell (make-posn 2 4) 0)
(make-dist-cell (make-posn 4 3) 0)
(make-dist-cell (make-posn 3 4) 0)
(make-dist-cell (make-posn 4 4) 0)
(make-dist-cell (make-posn 3 3) 1)))
;; lookup-board : board posn -> cell-or-false
(define (lookup-board board p)
(cond
[(empty? board) (error 'lookup-board "did not find posn")]
[else
(cond
[(equal? (cell-p (first board)) p)
(first board)]
[else
(lookup-board (rest board) p)])]))
(check-expect (lookup-board (list (make-cell (make-posn 2 2) false))
(make-posn 2 2))
(make-cell (make-posn 2 2) false))
(check-error (lookup-board '() (make-posn 0 0))
"lookup-board: did not find posn")
;; add-to-table : posn (number or '∞) distance-map -> distance-map
(define (add-to-table p n t)
(cond
[(empty? t) (list (make-dist-cell p n))]
[else
(cond
[(equal? p (dist-cell-p (first t)))
(cons (make-dist-cell p (min/f (dist-cell-n (first t)) n))
(rest t))]
[else
(cons (first t) (add-to-table p n (rest t)))])]))
(check-expect (add-to-table (make-posn 1 2) 3 '())
(list (make-dist-cell (make-posn 1 2) 3)))
(check-expect (add-to-table (make-posn 1 2)
3
(list (make-dist-cell (make-posn 1 2) 4)))
(list (make-dist-cell (make-posn 1 2) 3)))
(check-expect (add-to-table (make-posn 1 2)
3
(list (make-dist-cell (make-posn 1 2) 2)))
(list (make-dist-cell (make-posn 1 2) 2)))
(check-expect (add-to-table (make-posn 1 2)
3
(list (make-dist-cell (make-posn 2 2) 2)))
(list (make-dist-cell (make-posn 2 2) 2)
(make-dist-cell (make-posn 1 2) 3)))
;; in-table : distance-map posn -> boolean
(define (in-table? t p) (number? (lookup-in-table t p)))
(check-expect (in-table? empty (make-posn 1 2)) false)
(check-expect (in-table? (list (make-dist-cell (make-posn 1 2) 3))
(make-posn 1 2))
(check-expect (same-sets?
(build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3)
'boundary)
(list
(make-dist-cell 'boundary 0)
(make-dist-cell (make-posn 1 0) 1)
(make-dist-cell (make-posn 2 0) 1)
(make-dist-cell (make-posn 0 1) 1)
(make-dist-cell (make-posn 1 1) 2)
(make-dist-cell (make-posn 2 1) 1)
(make-dist-cell (make-posn 1 2) 1)
(make-dist-cell (make-posn 2 2) 1)))
true)
(check-expect (in-table? (list (make-dist-cell (make-posn 2 1) 3))
(make-posn 1 2))
false)
(check-expect (same-sets?
(build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3)
(make-posn 1 1))
(list
(make-dist-cell 'boundary 2)
(make-dist-cell (make-posn 1 0) 1)
(make-dist-cell (make-posn 2 0) 1)
(make-dist-cell (make-posn 0 1) 1)
(make-dist-cell (make-posn 1 1) 0)
(make-dist-cell (make-posn 2 1) 1)
(make-dist-cell (make-posn 1 2) 1)
(make-dist-cell (make-posn 2 2) 1)))
true)
(check-expect (same-sets?
(build-bfs-table (make-world (list
(make-cell (make-posn 0 1) true)
(make-cell (make-posn 1 0) true)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 1 2) true)
(make-cell (make-posn 2 0) true)
(make-cell (make-posn 2 1) true)
(make-cell (make-posn 2 2) true))
(make-posn 1 1)
'playing
3)
'boundary)
(list
(make-dist-cell 'boundary 0)))
true)
(check-expect (same-sets?
(build-bfs-table (make-world (empty-board 5)
(make-posn 2 2)
'playing
5)
'boundary)
(list
(make-dist-cell 'boundary 0)
(make-dist-cell (make-posn 1 0) 1)
(make-dist-cell (make-posn 2 0) 1)
(make-dist-cell (make-posn 3 0) 1)
(make-dist-cell (make-posn 4 0) 1)
(make-dist-cell (make-posn 0 1) 1)
(make-dist-cell (make-posn 1 1) 2)
(make-dist-cell (make-posn 2 1) 2)
(make-dist-cell (make-posn 3 1) 2)
(make-dist-cell (make-posn 4 1) 1)
(make-dist-cell (make-posn 0 2) 1)
(make-dist-cell (make-posn 1 2) 2)
(make-dist-cell (make-posn 2 2) 3)
(make-dist-cell (make-posn 3 2) 2)
(make-dist-cell (make-posn 4 2) 1)
(make-dist-cell (make-posn 0 3) 1)
(make-dist-cell (make-posn 1 3) 2)
(make-dist-cell (make-posn 2 3) 2)
(make-dist-cell (make-posn 3 3) 2)
(make-dist-cell (make-posn 4 3) 1)
(make-dist-cell (make-posn 1 4) 1)
(make-dist-cell (make-posn 2 4) 1)
(make-dist-cell (make-posn 3 4) 1)
(make-dist-cell (make-posn 4 4) 1)))
true)
(check-expect (same-sets?
(build-bfs-table (make-world (block-cell
(make-posn 4 2)
(empty-board 5))
(make-posn 2 2)
'playing
5)
'boundary)
(list
(make-dist-cell 'boundary 0)
(make-dist-cell (make-posn 1 0) 1)
(make-dist-cell (make-posn 2 0) 1)
(make-dist-cell (make-posn 3 0) 1)
(make-dist-cell (make-posn 4 0) 1)
(make-dist-cell (make-posn 0 1) 1)
(make-dist-cell (make-posn 1 1) 2)
(make-dist-cell (make-posn 2 1) 2)
(make-dist-cell (make-posn 3 1) 2)
(make-dist-cell (make-posn 4 1) 1)
(make-dist-cell (make-posn 0 2) 1)
(make-dist-cell (make-posn 1 2) 2)
(make-dist-cell (make-posn 2 2) 3)
(make-dist-cell (make-posn 3 2) 3)
(make-dist-cell (make-posn 0 3) 1)
(make-dist-cell (make-posn 1 3) 2)
(make-dist-cell (make-posn 2 3) 2)
(make-dist-cell (make-posn 3 3) 2)
(make-dist-cell (make-posn 4 3) 1)
(make-dist-cell (make-posn 1 4) 1)
(make-dist-cell (make-posn 2 4) 1)
(make-dist-cell (make-posn 3 4) 1)
(make-dist-cell (make-posn 4 4) 1)))
true)
(check-expect (same-sets?
(build-bfs-table (make-world (empty-board 5)
(make-posn 2 2)
'playing
5)
(make-posn 2 2))
(list
(make-dist-cell 'boundary 3)
(make-dist-cell (make-posn 1 0) 2)
(make-dist-cell (make-posn 2 0) 2)
(make-dist-cell (make-posn 3 0) 2)
(make-dist-cell (make-posn 4 0) 3)
(make-dist-cell (make-posn 0 1) 2)
(make-dist-cell (make-posn 1 1) 1)
(make-dist-cell (make-posn 2 1) 1)
(make-dist-cell (make-posn 3 1) 2)
(make-dist-cell (make-posn 4 1) 3)
(make-dist-cell (make-posn 0 2) 2)
(make-dist-cell (make-posn 1 2) 1)
(make-dist-cell (make-posn 2 2) 0)
(make-dist-cell (make-posn 3 2) 1)
(make-dist-cell (make-posn 4 2) 2)
(make-dist-cell (make-posn 0 3) 2)
(make-dist-cell (make-posn 1 3) 1)
(make-dist-cell (make-posn 2 3) 1)
(make-dist-cell (make-posn 3 3) 2)
(make-dist-cell (make-posn 4 3) 3)
(make-dist-cell (make-posn 1 4) 2)
(make-dist-cell (make-posn 2 4) 2)
(make-dist-cell (make-posn 3 4) 2)
(make-dist-cell (make-posn 4 4) 3)))
true)
(check-expect (lookup-in-table
(build-bfs-table (make-world (empty-board 5)
(make-posn 2 2)
'playing
5)
(make-posn 2 2))
(make-posn 1 4))
2)
;; lookup-in-table : distance-map posn -> number or '∞
;; looks for the distance as recorded in the table t,
@ -495,40 +548,123 @@
(make-posn 1 2))
'∞)
;; on-boundary? : posn number -> boolean
(define (on-boundary? p board-size)
(or (= (posn-x p) 0)
(= (posn-y p) 0)
(= (posn-x p) (- board-size 1))
(= (posn-y p) (- board-size 1))))
(check-expect (on-boundary? (make-posn 0 1) 13) true)
(check-expect (on-boundary? (make-posn 1 0) 13) true)
(check-expect (on-boundary? (make-posn 12 1) 13) true)
(check-expect (on-boundary? (make-posn 1 12) 13) true)
(check-expect (on-boundary? (make-posn 1 1) 13) false)
(check-expect (on-boundary? (make-posn 10 10) 13) false)
;; on-cats-path? : world -> posn -> boolean
;; returns true when the posn is on the shortest path
;; from the cat to the edge of the board, in the given world
(define (on-cats-path? w)
(local [(define edge-distance-map (build-bfs-table w 'boundary))
(define cat-distance-map (build-bfs-table w (world-cat w)))
(define cat-distance (lookup-in-table edge-distance-map
(world-cat w)))]
(lambda (p)
(equal? (+/f (lookup-in-table cat-distance-map p)
(lookup-in-table edge-distance-map p))
cat-distance))))
(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5))
(make-posn 1 0))
true)
(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5))
(make-posn 2 1))
false)
;; neighbors : world (or/c 'boundary posn) -> (listof (or/c 'boundary posn))
;; computes the neighbors of a posn, for a given board size
(define (neighbors w)
(local [(define blocked (map cell-p
(filter cell-blocked?
(world-board w))))
(define boundary-cells (filter (lambda (p)
(and (not (member p blocked))
(on-boundary? p (world-size w))))
(map cell-p (world-board w))))]
(lambda (p)
(cond
[(member p blocked)
'()]
[(equal? p 'boundary)
boundary-cells]
[else
(local [(define x (posn-x p))
(define y (posn-y p))
(define adjacent-posns (adjacent p (world-size w)))
(define in-bounds
(filter (lambda (x) (in-bounds? x (world-size w)))
adjacent-posns))]
(filter
(lambda (x) (not (member x blocked)))
(cond
[(equal? in-bounds adjacent-posns)
in-bounds]
[else
(cons 'boundary in-bounds)])))]))))
(check-expect ((neighbors (empty-world 11)) (make-posn 1 1))
(adjacent (make-posn 1 1) 11))
(check-expect ((neighbors (empty-world 11)) (make-posn 2 2))
(adjacent (make-posn 2 2) 11))
(check-expect ((neighbors (empty-world 3)) 'boundary)
(list (make-posn 0 1)
(make-posn 1 0)
(make-posn 1 2)
(make-posn 2 0)
(make-posn 2 1)
(make-posn 2 2)))
(check-expect ((neighbors (empty-world 11)) (make-posn 1 0))
(list 'boundary
(make-posn 2 0)
(make-posn 0 1)
(make-posn 1 1)))
(check-expect ((neighbors (make-world (list
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false)
(make-cell (make-posn 1 1) true)
(make-cell (make-posn 1 2) false)
(make-cell (make-posn 2 0) false)
(make-cell (make-posn 2 1) false)
(make-cell (make-posn 2 2) false))
(make-posn 1 1)
'playing
3))
(make-posn 1 1))
'())
(check-expect ((neighbors (make-world (list
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false)
(make-cell (make-posn 1 1) true)
(make-cell (make-posn 1 2) false)
(make-cell (make-posn 2 0) false)
(make-cell (make-posn 2 1) false)
(make-cell (make-posn 2 2) false))
(make-posn 1 1)
'playing
3))
(make-posn 1 0))
(list 'boundary (make-posn 2 0) (make-posn 0 1)))
;; adjacent : posn number -> (listof posn)
;; returns a list of the posns that are adjacent to
;; `p' on an infinite hex grid
(define (adjacent p board-size)
(local [(define x (posn-x p))
(define y (posn-y p))]
(filter (lambda (x) (in-bounds? x board-size))
(cond
[(even? y)
(list (make-posn (- x 1) (- y 1))
(make-posn x (- y 1))
(make-posn (- x 1) y)
(make-posn (+ x 1) y)
(make-posn (- x 1) (+ y 1))
(make-posn x (+ y 1)))]
[else
(list (make-posn x (- y 1))
(make-posn (+ x 1) (- y 1))
(make-posn (- x 1) y)
(make-posn (+ x 1) y)
(make-posn x (+ y 1))
(make-posn (+ x 1) (+ y 1)))]))))
(cond
[(even? y)
(list (make-posn (- x 1) (- y 1))
(make-posn x (- y 1))
(make-posn (- x 1) y)
(make-posn (+ x 1) y)
(make-posn (- x 1) (+ y 1))
(make-posn x (+ y 1)))]
[else
(list (make-posn x (- y 1))
(make-posn (+ x 1) (- y 1))
(make-posn (- x 1) y)
(make-posn (+ x 1) y)
(make-posn x (+ y 1))
(make-posn (+ x 1) (+ y 1)))])))
(check-expect (adjacent (make-posn 1 1) 11)
(list (make-posn 1 0)
@ -545,6 +681,23 @@
(make-posn 1 3)
(make-posn 2 3)))
;; on-boundary? : posn number -> boolean
(define (on-boundary? p board-size)
(or (= (posn-x p) 0)
(= (posn-y p) 0)
(= (posn-x p) (- board-size 1))
(= (posn-y p) (- board-size 1))))
(check-expect (on-boundary? (make-posn 0 1) 13) true)
(check-expect (on-boundary? (make-posn 1 0) 13) true)
(check-expect (on-boundary? (make-posn 12 1) 13) true)
(check-expect (on-boundary? (make-posn 1 12) 13) true)
(check-expect (on-boundary? (make-posn 1 1) 13) false)
(check-expect (on-boundary? (make-posn 10 10) 13) false)
;; in-bounds? : posn number -> boolean
(define (in-bounds? p board-size)
(and (<= 0 (posn-x p) (- board-size 1))
@ -562,37 +715,29 @@
(check-expect (in-bounds? (make-posn 10 0) 11) true)
(check-expect (in-bounds? (make-posn 0 10) 11) false)
;; min-l : (listof number-or-symbol) -> number-or-symbol
(define (min-l ls) (foldr (lambda (x y) (min/f x y)) '∞ ls))
(check-expect (min-l (list)) '∞)
(check-expect (min-l (list 10 1 12)) 1)
;; <=/f : (number or '∞) (number or '∞) -> boolean
(define (<=/f a b) (equal? a (min/f a b)))
(define (<=/f a b)
(cond
[(equal? b '∞) true]
[(equal? a '∞) false]
[else (<= a b)]))
(check-expect (<=/f 1 2) true)
(check-expect (<=/f 2 1) false)
(check-expect (<=/f '∞ 1) false)
(check-expect (<=/f 1 '∞) true)
(check-expect (<=/f '∞ '∞) true)
;; min/f : (number or '∞) (number or '∞) -> (number or '∞)
(define (min/f x y)
(define (+/f x y)
(cond
[(equal? x '∞) y]
[(equal? y '∞) x]
[else (min x y)]))
(check-expect (min/f '∞ 1) 1)
(check-expect (min/f 1 '∞) 1)
(check-expect (min/f '∞ '∞) '∞)
(check-expect (min/f 1 2) 1)
[(or (equal? x '∞) (equal? y '∞))
'∞]
[else
(+ x y)]))
;; add1/f : number or '∞ -> number or '∞
(define (add1/f n)
(cond
[(equal? n '∞) '∞]
[else (add1 n)]))
(check-expect (add1/f 1) 2)
(check-expect (add1/f '∞) '∞)
(check-expect (+/f '∞ '∞) '∞)
(check-expect (+/f '∞ 1) '∞)
(check-expect (+/f 1 '∞) '∞)
(check-expect (+/f 1 2) 3)
;
;
@ -675,7 +820,7 @@
;; move-cat : world -> world
(define (move-cat world)
(local [(define cat-position (world-cat world))
(define table (build-table/fast world))
(define table (build-bfs-table world 'boundary))
(define neighbors (adjacent cat-position (world-size world)))
(define next-cat-positions
(find-best-positions neighbors
@ -1003,38 +1148,84 @@
(random (length unblocked-cells))))]
(add-n-random-blocked-cells
(sub1 n)
(map (lambda (c) (if (equal? to-block c)
(make-cell (cell-p c) true)
c))
all-cells)
(block-cell (cell-p to-block) all-cells)
board-size))]))
;; block-cell : posn board -> board
(define (block-cell to-block board)
(map (lambda (c) (if (equal? to-block (cell-p c))
(make-cell to-block true)
c))
board))
(check-expect (block-cell (make-posn 1 1)
(list (make-cell (make-posn 0 0) false)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 2 2) false)))
(list (make-cell (make-posn 0 0) false)
(make-cell (make-posn 1 1) true)
(make-cell (make-posn 2 2) false)))
(check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) true)) 10)
(list (make-cell (make-posn 0 0) true)))
(check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) false)) 10)
(list (make-cell (make-posn 0 0) true)))
;; empty-board : number -> (listof cell)
(define (empty-board board-size)
(filter
(lambda (c)
(not (and (= 0 (posn-x (cell-p c)))
(or (= 0 (posn-y (cell-p c)))
(= (- board-size 1)
(posn-y (cell-p c)))))))
(append-all
(build-list
board-size
(lambda (i)
(build-list
board-size
(lambda (j)
(make-cell (make-posn i j)
false))))))))
(check-expect (empty-board 3)
(list
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 1 2) false)
(make-cell (make-posn 2 0) false)
(make-cell (make-posn 2 1) false)
(make-cell (make-posn 2 2) false)))
;; empty-world : number -> world
(define (empty-world board-size)
(make-world (empty-board board-size)
(make-posn (quotient board-size 2)
(quotient board-size 2))
'playing
board-size))
(check-expect (empty-world 3)
(make-world (list
(make-cell (make-posn 0 1) false)
(make-cell (make-posn 1 0) false)
(make-cell (make-posn 1 1) false)
(make-cell (make-posn 1 2) false)
(make-cell (make-posn 2 0) false)
(make-cell (make-posn 2 1) false)
(make-cell (make-posn 2 2) false))
(make-posn 1 1)
'playing
3))
(define dummy
(local
[(define board-size 11)
(define initial-board
(add-n-random-blocked-cells
6
(filter
(lambda (c)
(not (and (= 0 (posn-x (cell-p c)))
(or (= 0 (posn-y (cell-p c)))
(= (- board-size 1)
(posn-y (cell-p c)))))))
(append-all
(build-list
board-size
(lambda (i)
(build-list
board-size
(lambda (j)
(make-cell (make-posn i j)
false)))))))
(empty-board board-size)
board-size))
(define initial-world
(make-world initial-board
@ -1043,7 +1234,7 @@
'playing
board-size))]
(and ;((lambda (x) true) (time (build-table initial-world))) ;((lambda (x) true) (time (build-table/fast initial-world)))
(and
(big-bang (world-width board-size)
(world-height board-size)
1

8
collects/games/chat-noir/hash.ss
View File

@ -1,2 +1,8 @@
#lang scheme/base
(provide make-hash hash-set! hash-ref hash-map)
(provide make-immutable-hash/list-init
hash-set hash-ref hash-map)
(define (make-immutable-hash/list-init [init '()])
(make-immutable-hash
(map (λ (x) (cons (car x) (cadr x)))
init)))

11
collects/games/scribblings/chat-noir.scrbl
View File

@ -12,8 +12,14 @@ completely boxed in and thus unable reach the border, you win. If the
cat does reach the border, you lose.
The game was inspired by this one the one at
@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design}
and has essentailly the same rules.
@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game
Design} and has essentially the same rules. It also inspired the final
project for the introductory programming course at the University of
Chicago in the fall of 2008.
@;{
This is commented out, waiting for the literate programming stuff.
This game is written in the
@link["http://www.htdp.org/"]{How to Design Programs}
@ -54,3 +60,4 @@ the fall of 2008, as below.
#:mode 'text))
@m[]
}

18
collects/mzlib/foreign.ss
View File

@ -62,7 +62,7 @@
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
_bool _pointer _scheme _fpointer
_bool _pointer _scheme _fpointer function-ptr
(unsafe memcpy) (unsafe memmove) (unsafe memset)
(unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
@ -676,12 +676,22 @@
(syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
(define (function-ptr p fun-ctype)
(if (or (cpointer? p) (procedure? p))
(if (eq? (ctype->layout fun-ctype) 'fpointer)
(if (procedure? p)
((ctype-scheme->c fun-ctype) p)
((ctype-c->scheme fun-ctype) p))
(raise-type-error 'function-ptr "function ctype" fun-ctype))
(raise-type-error 'function-ptr "cpointer" p)))
;; ----------------------------------------------------------------------------
;; String types
;; The internal _string type uses the native ucs-4 encoding, also providing a
;; utf-16 type (note: these do not use #f as NULL).
(provide _string/ucs-4 _string/utf-16)
;; utf-16 type (note: the non-/null variants do not use #f as NULL).
(provide _string/ucs-4 _string/utf-16
_string/ucs-4/null _string/utf-16/null)
;; 8-bit string encodings, #f is NULL
(define ((false-or-op op) x) (and x (op x)))
@ -1477,7 +1487,7 @@
(identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
[(_ (_TYPE _SUPER) ([slot slot-type] ...))
(and (_-identifier? #'_TYPE) (identifiers? #'(slot ...)))
(and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
(with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))

97
collects/planet/planet.scrbl
View File

@ -16,10 +16,6 @@
@author["Jacob Matthews"]
@PLaneT is PLT Scheme's centralized package repository. It consists of
two parts: , which contains packages contributed by users, and
the @PLaneT client, which is built in to PLT Scheme.
The @PLaneT system is a method for automatically sharing code packages,
both as libraries and as full applications, that gives every user of a
@PLaneT client the illusion of having a local copy of every code
@ -60,7 +56,7 @@ package (a library for interacting with the
@link["http://www.postgresql.org/"]{PostgresQL} database), as of this
writing you would copy and paste the line:
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
into your program. This line requires the file @filepath{spgsql.ss} in package
version 2.3 of the @filepath{spgsql.plt} package written by
@ -72,7 +68,7 @@ installed. Second, it requires the module in file @filepath{spgsql.ss}
from that package, making all of its exported bindings available for use.
Unlike with most package-distribution systems, package downloading and
installation in PLaneT is @italic{transparent} --- there's no need for
installation in PLaneT is @emph{transparent}: there's no need for
you to do anything special the first time you want to use a package,
and there's no need for you to even know whether or not a particular
package is installed on your computer or the computers where your code
@ -80,10 +76,10 @@ will be deployed.
@subsection{Shorthand Syntax}
As of PLT Scheme version 4.0, the code snippet in section
@secref{finding-a-package} can also be written using a new shorter syntax:
As of PLT Scheme version 4.0, the code snippet above can also be
written using a new shorter syntax:
@scheme[(require (planet schematics/spgsql:2:3/spgsql))]
@schemeblock[(require (planet schematics/spgsql:2:3/spgsql))]
The two forms behave identically. In the abbreviated syntax, however,
it is illegal to write the trailing @scheme{.ss} suffix on the file
@ -108,11 +104,11 @@ number that encodes backwards-compatibility information.}
The most basic planet require line, which is what is used in the form
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
in longhand notation, or
@scheme[(require (planet schematics/spgsql:2:3/spgsql))]
@schemeblock[(require (planet schematics/spgsql:2:3/spgsql))]
in shorthand notation, should be read ``Require from PLaneT
@italic{any} release of Schematics' @filepath{spgsql.plt} package that
@ -121,11 +117,11 @@ package version used is determined by @seclink["search-order"]{the
PLaneT search order}.) To signal this explicitly, it is possible to
write
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 (+ 3))))]
@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 (+ 3))))]
or
@scheme[(require (planet schematics/spgsql:2:>=3/spgsql))]
@schemeblock[(require (planet schematics/spgsql:2:>=3/spgsql))]
both of which mean the same thing as the first pair of require lines.
@ -148,11 +144,12 @@ in third-party libraries was already working around. In those cases,
it may help to make use of the ``upper bound'' form of the planet
require, in longhand form:
@scheme[(require (planet "reduction-semantics.ss" ("robby" "redex.plt" 4 (- 3))))]
@schemeblock[(require (planet "reduction-semantics.ss"
("robby" "redex.plt" 4 (- 3))))]
and using shorthand notation:
@scheme[(require (planet robby/redex:4:<=3/reduction-semantics))]
@schemeblock[(require (planet robby/redex:4:<=3/reduction-semantics))]
In this require line, any version of the package @filepath{redex.plt}
from package version 4.0 to package version 4.3 will match the require
@ -163,11 +160,11 @@ which package is actually loaded).
It is also possible to specify both an upper and a lower bound, using
the planet require's ``range'' form:
@scheme[(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 (9 10))))]
@schemeblock[(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 (9 10))))]
or
@scheme[(require (planet schematics/schemeunit:2:9-10/test))]
@schemeblock[(require (planet schematics/schemeunit:2:9-10/test))]
This form matches any package in the specified range (inclusive on
both ends), in this example the specifications match either package
@ -180,11 +177,11 @@ a package as a special case (choosing the upper and lower bounds to be
equal), but this is a common enough case that it has special support
with the ``exact-match'' form:
@scheme[(require (planet "unzip.ss" ("dherman" "zip.plt" 2 (= 1))))]
@schemeblock[(require (planet "unzip.ss" ("dherman" "zip.plt" 2 (= 1))))]
or
@scheme[(require (planet dherman/zip:2:=1/unzip))]
@schemeblock[(require (planet dherman/zip:2:=1/unzip))]
match only the exact package version 2.1 of the @filepath{zip.plt} package.
@ -384,25 +381,39 @@ within the PLaneT archive named by <plt-file>, to the standard output port.
This command does not unpack or install the named .plt file.
@section[#:tag "hash-lang-planet"]{The @schememodname[planet] Language}
@defmodulelang[planet]
When used with @hash-lang[], @schememodname[planet] must be followed
by a short-form PLaneT path. The path is used in the same way that
@hash-lang[] uses plain identifiers: @schemeidfont{/lang/reader} is
added to the given path to determine a module that supplies a module
reader.
The @schememodname[planet] module (as opposed to the reader used with
@hash-lang[]) implements the @exec{planet} command-line tool.
@section{Utility Libraries}
The planet collection provides configuration and utilities for using PLaneT.
@subsection{config.ss: Client Configuration}
The config.ss library provides several parameters useful for configuring how
PLaneT works.
Note that while these parameters can be useful to modify
programmatically, PLaneT code runs at module-expansion time and so
most user programs cannot set them until PLaneT has already
run. Therefore to meaningfully change these settings it is best to
manually edit the config.ss file.
@subsection{Client Configuration}
@defmodule[planet/config]
The @schememodname[planet/config] library provides several parameters
useful for configuring how PLaneT works.
Note that while these parameters can be useful to modify
programmatically, PLaneT code runs at module-expansion time, so
most user programs cannot set them until PLaneT has already
run. Therefore, to meaningfully change these settings, it is best to
manually edit the config.ss file.
@defparam[PLANET-DIR dir path-string?]{
The root PLaneT directory. If the environment variable PLTPLANETDIR is
The root PLaneT directory. If the environment variable
@indexed-envvar{PLTPLANETDIR} is
set, default is its value; otherwise the default is the directory in
which @filepath{config.ss} is found.}
@ -455,33 +466,42 @@ The port on the server the client should connect to if
@scheme[USE-HTTP-DOWNLOADS?] is @scheme[#f]. The default value for this parameter is
@scheme[270].}
@subsection[#:tag "util.ss"]{util.ss: Utilities}
@subsection[#:tag "util.ss"]{Utilities}
The @filepath{util.ss} library supports examination of the pieces of
@defmodule[planet/util]
The @schememodname[planet/util] library supports examination of the pieces of
PLaneT. It is meant primarily to support debugging and to allow easier
development of higher-level package-management tools. The
functionality exposed by @seclink["cmdline"]{the @exec{planet} command-line tool} is
also available programmatically through this library.
@defmodule[planet/util]
@defproc[(download/install-pkg [owner string?]
[pkg string?]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg? false/c)]{
(or/c pkg? #f)]{
Downloads and installs the package specifed by the given owner name,
package name, major and minor version number. Returns false if no such
package is available; otherwise returns a package structure for the
installed package.}
@defparam[current-cache-contents contents
((string? ((string? ((natural-number/c (natural-number/c ...)) ...)) ...)) ...)]{
(listof
(list/c string?
(listof
(list/c string?
(cons/c natural-number/c
(listof natural-number/c))))))]{
Holds a listing of all package names and versions installed in the
local cache.}
@defproc[(current-linkage)
((path-string? (string? (string?) natural-number/c natural-number/c) ...) ...)]{
(listof (list/c path-string?
(list/c string?
(list/c string?)
natural-number/c
natural-number/c)))]{
Returns the current linkage table.
The linkage table is an association between file locations (encoded as path strings)
@ -489,7 +509,8 @@ and concrete planet package versions. If a require line in the associated file r
this table is consulted to determine a particular concrete package to satisfy the request.}
@defproc[(make-planet-archive [directory path-string?]
[output-file (or/c path? path-string?) (string-append (path->string name) ".plt")])
[output-file (or/c path? path-string?)
(string-append (path->string name) ".plt")])
path-string?]{
Makes a .plt archive file suitable for PLaneT whose contents are all
files in the given directory and returns that file's name. If the

78
collects/planet/util.ss
View File

@ -299,6 +299,44 @@
;; or the scribble renderer gets very confused
(define SCRIBBLE-DOCUMENT-DIR "planet-docs/")
;; scribble-entry? : Any -> Boolean
;; Recognizes valid list entries in info.ss's scribblings field.
(define scribble-entry?
(match-lambda
[(or (list (? string?))
(list (? string?) (? scribble-flags?))
(list (? string?) (? scribble-flags?) (? scribble-category?))
(list (? string?) (? scribble-flags?) (? scribble-category?) (? string?)))
#t]
[_ #f]))
;; scribble-flags? : Any -> Boolean
;; Recognizes a list of flags from an info.ss scribblings entry.
(define scribble-flags?
(match-lambda
[(list (? symbol?) ...) #t]
[_ #f]))
;; scribble-category : Any -> Boolean
;; Recognizes a category descriptor from an info.ss scribblings entry.
(define scribble-category?
(match-lambda
[(or (list (? symbol?))
(list (? symbol?) (? real?))) #t]
[_ #f]))
;; scribble-entry-file : ScribbleEntry -> String
;; Produces the filename of an info.ss scribblings entry.
(define scribble-entry-file
(match-lambda [(list file _ ...) file]))
;; scribble-entry-flags : ScribbleEntry -> (Listof Symbol)
;; Produces the list of flags from an info.ss scribblings entry.
(define scribble-entry-flags
(match-lambda
[(list _) null]
[(list _ flags _ ...) flags]))
;; make-planet-archive: path<directory> [path<file>] -> path<file>
;; Makes a .plt archive file suitable for PLaneT whose contents are
;; all files in the given directory and returns that file's name.
@ -327,7 +365,7 @@
(λ (bad) (set! warnings (cons bad warnings)))
(λ (err) (set! critical-errors (cons err critical-errors))))])
(or real-info (λ (x [y (λ () (error 'info.ss (format "undefined field: ~a" x)))]) (y)))))
(let ([scribble-files (info.ss 'scribblings (λ () '()))])
(define (outdir file-str)
@ -346,21 +384,22 @@
(error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e"
scribble-files)))
(for ([entry scribble-files])
(match entry
[`(,(? string? filename) (,(? symbol? flags) ...))
(unless (and (relative-path? filename)
(subpath? abs-dir filename)
(bytes=? (filename-extension filename) #"scrbl"))
(error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
(unless (file-exists? (build-path abs-dir filename))
(error (format "scribblings file ~a not found" filename)))
(printf "Building: ~a\n" filename)
(let* ([name.scrbl (file-name-from-path filename)]
[name (path-replace-suffix name.scrbl #"")])
(render (build-path filename)
(build-path SCRIBBLE-DOCUMENT-DIR name)
(memq 'multi-page flags)))]
[_ (error "malformed scribblings entry")])))))
(unless (scribble-entry? entry)
(error "malformed scribblings entry"))
(let* ([filename (scribble-entry-file entry)]
[flags (scribble-entry-flags entry)])
(unless (and (relative-path? filename)
(subpath? abs-dir filename)
(bytes=? (filename-extension filename) #"scrbl"))
(error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
(unless (file-exists? (build-path abs-dir filename))
(error (format "scribblings file ~a not found" filename)))
(printf "Building: ~a\n" filename)
(let* ([name.scrbl (file-name-from-path filename)]
[name (path-replace-suffix name.scrbl #"")])
(render (build-path filename)
(build-path SCRIBBLE-DOCUMENT-DIR name)
(memq 'multi-page flags))))))))
(unless
(or (null? critical-errors)
@ -591,12 +630,7 @@
[scribblings
(lambda (s)
(and (list? s)
(andmap
(lambda (item)
(match item
[`(,(? string?) (,(? symbol?) ...)) #t]
[_ #f]))
s)))
(andmap scribble-entry? s)))
(void)
(unless scribblings
(warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))]

6
collects/r5rs/r5rs.scrbl
View File

@ -25,6 +25,10 @@ on the Algorithmic Language Scheme} defines a dialect of Scheme. We
use @defterm{@|r5rs|} to refer to both the standard and the language
defined by the standard.
@margin-note{See @seclink[#:doc '(lib "scribblings/guide/guide.scrbl")
"dialects"] for general information about different
dialects of Scheme within PLT Scheme.}
The default dialect of Scheme provided by @exec{mzscheme} and other
PLT Scheme tools differs from @|r5rs| in many ways, but PLT Scheme
includes tools and libraries for running @|r5rs| programs.
@ -161,7 +165,7 @@ containing the bindings of @schememodname[r5rs]. Procedure values are
installed into the namespace using @scheme[namespace-require/copy], so
that they can be redefined.
The @scheme[scheme-null-environment] function returns a namespace
The @scheme[null-environment] function returns a namespace
containing the syntactic forms of @schememodname[r5rs], not including
@scheme[#%module-begin] (which is not useful outside of a module).

40
collects/r6rs/scribblings/r6rs.scrbl
View File

@ -9,6 +9,7 @@
rnrs/conditions-6
rnrs/io/simple-6
rnrs/r5rs-6
r6rs
(only-in scheme/base
lib
current-library-collection-paths
@ -27,6 +28,10 @@ on the Algorithmic Language Scheme} defines a dialect of Scheme. We
use @defterm{@|r6rs|} to refer to both the standard and the language
defined by the standard.
@margin-note{See @seclink[#:doc '(lib "scribblings/guide/guide.scrbl")
"dialects"] for general information about different
dialects of Scheme within PLT Scheme.}
@|r6rs| defines both @defterm{libraries} and @defterm{top-level
programs}. Both correspond to PLT Scheme @defterm{modules} (see
@secref[#:doc guide-src "modules"]). That is, although @|r6rs| defines
@ -167,6 +172,41 @@ are searched in order, and before the installation's collections.
@; ----------------------------------------
@section[#:tag "r6rs-mod"]{@|r6rs| Module Language}
@defmodulelang[r6rs]
The @schememodname[r6rs] language is usually used in the form
@schememetafont{#!}@schememodname[r6rs], which is equivalent to
@scheme[#, @hash-lang[] #, @schememodname[r6rs]] and is also valid
@|r6rs| syntax.
The @schememodname[r6rs] module language provides only a
@schemeidfont{#%module-begin} binding, which is used to process the
entire module body (see @scheme[module]). It allows the body of a
module to use the syntax of either a @|r6rs| library or a @|r6rs|
top-level program.
@defform*[#:literals (library import export)
[(#%module-begin
(library library-name
(export export-spec ...)
(import import-spec ...)
library-body ...))
(#%module-begin
(import import-spec ...)
program-body ...)]]{
An @schememodname[r6rs] module that contains a single @scheme[library]
form defines an @|r6rs| library, while a module body that starts with
an @scheme[import] form defined an @|r6rs| top-level program.
The @scheme[library], @scheme[export], and @scheme[import] identifiers
are not exported by the @schememodname[r6rs] library; they are
recognized through equivalence to unbound identifiers.}
@; ----------------------------------------
@section[#:tag "libpaths"]{Libraries and Collections}
An @|r6rs| library name is sequence of symbols, optionally followed by

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "18dec2008")
#lang scheme/base (provide stamp) (define stamp "22dec2008")

26
collects/rnrs/base-6.ss
View File

@ -403,13 +403,25 @@
(define vector-map
(make-mapper "vector" for/list map in-vector vector-length vector->list list->vector))
(define (add-irritants msg irritants)
(if (null? irritants)
msg
(apply
string-append
msg
"\n irritants:"
(map (lambda (s)
(format "\n ~e" s))
irritants))))
(define (r6rs:error who msg . irritants)
(raise
(make-exn:fail:r6rs
(if who
(format "~a: ~a" who msg)
msg)
(add-irritants
(if who
(format "~a: ~a" who msg)
msg)
irritants)
(current-continuation-marks)
msg
who
@ -418,9 +430,11 @@
(define (assertion-violation who msg . irritants)
(raise
(make-exn:fail:contract:r6rs
(if who
(format "~a: ~a" who msg)
msg)
(add-irritants
(if who
(format "~a: ~a" who msg)
msg)
irritants)
(current-continuation-marks)
msg
who

38
collects/scribblings/foreign/types.scrbl
View File

@ -163,15 +163,24 @@ strings, which corresponds to C's @cpp{char*} type. In addition to
translating byte strings, @scheme[#f] corresponds to the @cpp{NULL}
pointer.
@defthing[_string/ucs-4 ctype?]{
@deftogether[(
@defthing[_string/ucs-4 ctype?]
@defthing[_string/ucs-4/null ctype?]
)]{
A type for Scheme's native Unicode strings, which are in UCS-4 format.
These correspond to the C @cpp{mzchar*} type used by PLT Scheme.}
These correspond to the C @cpp{mzchar*} type used by PLT Scheme. The
@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and
vice-versa.}
@defthing[_string/utf-16 ctype?]{
@deftogether[(
@defthing[_string/utf-16 ctype?]
@defthing[_string/utf-16/null ctype?]
)]{
Unicode strings in UTF-16 format.}
Unicode strings in UTF-16 format. The @schemeidfont{/null} variant
treats @scheme[#f] as @cpp{NULL} and vice-versa.}
@defthing[_path ctype?]{
@ -270,15 +279,14 @@ PLT Scheme's C API.}
@defthing[_fpointer ctype?]{
Similar to @scheme[_pointer], except that it should be used with
function pointers. Using these pointers avoids one dereferencing,
which is the proper way of dealing with function pointers. This type
should be used only in rare situations where you need to pass a
foreign function pointer to a foreign function; using a
@scheme[_cprocedure] type is possible for such situations, but
inefficient, as every call will go through Scheme unnecessarily.
Otherwise, @scheme[_cprocedure] should be used (it is based on
@scheme[_fpointer]).}
Similar to @scheme[_pointer], except that when an @scheme[_fpointer]
is extracted from a pointer produced by @scheme[ffi-obj-ref], then a
level of indirection is skipped. A level of indirection is similarly
skipped when extracting a pointer via @scheme[get-ffi-obj].
A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
and normally @scheme[_cprocedure] should be used instead of
@scheme[_fpointer].}
@; ------------------------------------------------------------
@ -431,6 +439,10 @@ For example,
specifies a function that receives an integer and a string, but the
foreign function receives the string first.}
@defproc[(function-ptr [ptr cpointer?] [fun-type ctype?]) cpointer?]{
Casts @scheme[ptr] to a function pointer of type @scheme[fun-type].}
@; ----------------------------------------------------------------------
@subsection[#:tag "foreign:custom-types"]{Custom Function Types}

2
collects/scribblings/guide/compile.scrbl
View File

@ -14,7 +14,7 @@ So far, we have talked about three main PLT Scheme executables:
running PLT Scheme programs (and that can be used as a
development environment in interactive mode);}
@item{@exec{mred}, which is like @scheme{mzscheme}, but for GUI
@item{@exec{mred}, which is like @exec{mzscheme}, but for GUI
applications.}
]

155
collects/scribblings/guide/dialects.scrbl Normal file
View File

@ -0,0 +1,155 @@
#lang scribble/doc
@(require scribble/manual
"guide-utils.ss")
@(define r6rs @elem{R@superscript{6}RS})
@(define r5rs @elem{R@superscript{5}RS})
@title[#:tag "dialects" #:style 'toc]{Dialects of Scheme}
PLT Scheme is one dialect of the Scheme programming language, and
there are many others. Indeed, ``Scheme'' is perhaps more of an idea
than a specific language.
The @hash-lang[] prefix on modules is a particular feature of PLT
Scheme, and programs that start with @hash-lang[] are unlikely to run
in other implementations of Scheme. At the same time, programs that do
not start with @hash-lang[] (or another PLT Scheme module form) do not
work with the default mode of most PLT Scheme tools.
``PLT Scheme'' is not, however, the only dialect of Scheme that is supported
by PLT Scheme tools. On the contrary, PLT Scheme tools are designed to
support multiple dialects of Scheme and even multiple languages, which
allows the PLT Scheme tool suite to serve multiple communities. PLT
Scheme also gives programmers and researchers the tools they need to
explore and create new languages.
@local-table-of-contents[]
@; --------------------------------------------------
@section[#:tag "standards"]{Standards}
Standard dialects of Scheme include the ones defined by @|r5rs| and
@|r6rs|.
@subsection{@|r5rs|}
``@|r5rs|'' stands for @link["../r5rs-std/index.html"]{The
Revised@superscript{5} Report on the Algorithmic Language Scheme}, and
it is currently the most widely implemented Scheme standard.
PLT Scheme tools in their default modes do not conform to @|r5rs|,
mainly because PLT Scheme tools generally expect modules, and @|r5rs|
does not define a module system. Typical single-file @|r5rs| programs
can be converted to PLT Scheme programs by prefixing them with
@scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme
systems do not recognize @scheme[#, @hash-lang[] #,
@schememodname[r5rs]] (which is not part of the @|r5rs| standard). The
@exec{plt-r5rs} executable more directly conforms to the @|r5rs|
standard.
Aside from the module system, the syntactic forms and functions of
@|r5rs| and PLT Scheme differ. Only simple @|r5rs| become PLT Scheme
programs when prefixed with @scheme[#, @hash-lang[] scheme], and
relatively few PLT Scheme programs become @|r5rs| programs when a
@hash-lang[] line is removed. Also, when mixing ``@|r5rs| modules''
with PLT Scheme modules, beware that @|r5rs| pairs correspond to PLT
Scheme mutable pairs (as constructed with @scheme[mcons]).
See @other-manual['(lib "r5rs/r5rs.scrbl")] for more
information about running @|r5rs| programs with PLT Scheme.
@subsection{@|r6rs|}
``@|r6rs|'' stands for @link["../r6rs-std/index.html"]{The
Revised@superscript{6} Report on the Algorithmic Language Scheme},
which extends @|r5rs| with a module system that is similar to the PLT
Scheme module system.
When an @|r6rs| library or top-level program is prefixed with
@schememetafont{#!}@schememodname[r6rs] (which is valid @|r6rs|
syntax), then it can also be used as a PLT Scheme program. This works
because @schememetafont{#!} in PLT Scheme is treated as a shorthand
for @hash-lang[] followed by a space, so
@schememetafont{#!}@schememodname[r6rs] selects the
@schememodname[r6rs] module language. As with @|r5rs|, however, beware
that the syntactic forms and functions of @|r6rs| differ from PLT
Scheme, and @|r6rs| pairs are mutable pairs.
See @other-manual['(lib "r6rs/scribblings/r6rs.scrbl")] for more
information about running @|r6rs| programs with PLT Scheme.
@; --------------------------------------------------
@section[#:tag "more-hash-lang"]{More PLT Schemes}
Like ``Scheme'' itself, even ``PLT Scheme'' is more of an idea about
programming languages than a language in the usual sense. Macros can
extend a base language (as described in @secref["macros"]), but macros
and alternate parsers can construct an entirely new language from the
ground up.
The @hash-lang[] line that starts a PLT Scheme module declares the
base language of the module. By ``PLT Scheme,'' we usually mean
@hash-lang[] followed by the base language @schememodname[scheme] or
@schememodname[scheme/base] (of which @schememodname[scheme] is an
extension). The PLT Scheme distribution provides additional languages,
including the following:
@itemize[
@item{@schememodname[typed-scheme] --- like
@schememodname[scheme/base], but statically typed; see
@other-manual['(lib "typed-scheme/ts-guide.scrbl")]}
@item{@schememodname[lazy] --- like @schememodname[scheme/base], but
avoids evaluating an expression until its value is needed; see
@other-manual['(lib "lazy/lazy.scrbl")]}
@item{@schememodname[frtime] --- changes evaluation in an even more
radical way to support reactive programming; see
@other-manual['(lib "frtime/frtime.scrbl")]}
@item{@schememodname[scribble/doc] --- a language, which looks more
like Latex than Scheme, for writing documentation; see
@other-manual['(lib "scribblings/scribble/scribble.scrbl")]}
]
Each of these languages is used by starting module with the language
name after @hash-lang[]. For example, this source of this very
document starts with @scheme[#, @hash-lang[] scribble/doc].
PLT Scheme users can define their own languages. A language name maps
to its implementation through a module path by adding
@schemeidfont{/lang/reader}. For example, the language name
@schememodname[scribble/doc] is expanded to
@scheme[scribble/doc/lang/reader], which is the module that implements
the surface-syntax parser. The parser, in turn, generates a
@scheme[module] form, which determines the base language at the level
of syntactic forms an functions.
Some language names act as language loaders. For example,
@schememodname[s-exp] as a language uses the usual PLT Scheme parser
for surface-syntax reading, and then it uses the module path after
@schememodname[s-exp] for the language's syntactic forms. Thus,
@scheme[#, @hash-lang[] #, @schememodname[s-exp] "mylang.ss"] parses
the module body using the normal PLT Scheme reader, by then imports
the initial syntax and functions for the module body from
@scheme["mylang.ss"]. Similarly, @scheme[#, @hash-lang[] #,
@schememodname[planet] _planet-path] loads a language via
@seclink["top" #:doc '(lib "planet/planet.scrbl")]{@|PLaneT|}.
@; --------------------------------------------------
@section[#:tag "teaching-langs"]{Teaching}
The @|HtDP| textbook relies on pedagogic variants of Scheme that
smooth the introduction of programming concepts for new programmers.
The languages are documented in @other-manual['(lib
"scribblings/htdp-langs/htdp-langs.scrbl")].
The @|HtDP| languages are typically not used with @hash-lang[]
prefixes, but are instead used within DrScheme by selecting the
language from the @onscreen{Choose Language...} dialog.

23
collects/scribblings/guide/guide.scrbl
View File

@ -58,28 +58,9 @@ precise details to @|MzScheme| and other reference manuals.
@include-section["compile.scrbl"]
@; ----------------------------------------------------------------------
@section{More Libraries}
@include-section["other.scrbl"]
@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the PLT
Scheme graphics toolbox, whose core is implemented by the @exec{mred}
executable.
@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes
tools for using Scheme to access libraries that are normally used by C
programs.
@other-manual['(lib "web-server/scribblings/web-server.scrbl")]
describes the PLT Scheme web server, which supports servlets
implemented in Scheme.
@link["../index.html"]{PLT Scheme Documentation} lists documentation
for many other installed libraries. Run @exec{plt-help} to find
documentation for libraries that are installed on your system and
specific to your user account.
@link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more
downloadable packages contributed by PLT Scheme users.
@include-section["dialects.scrbl"]
@; ----------------------------------------------------------------------

25
collects/scribblings/guide/other.scrbl Normal file
View File

@ -0,0 +1,25 @@
#lang scribble/doc
@(require scribble/manual
"guide-utils.ss")
@title{More Libraries}
@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the PLT
Scheme graphics toolbox, whose core is implemented by the @exec{mred}
executable.
@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes
tools for using Scheme to access libraries that are normally used by C
programs.
@other-manual['(lib "web-server/scribblings/web-server.scrbl")]
describes the PLT Scheme web server, which supports servlets
implemented in Scheme.
@link["../index.html"]{PLT Scheme Documentation} lists documentation
for many other installed libraries. Run @exec{plt-help} to find
documentation for libraries that are installed on your system and
specific to your user account.
@link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more
downloadable packages contributed by PLT Scheme users.

8
collects/scribblings/guide/welcome.scrbl
View File

@ -13,7 +13,10 @@ Depending on how you look at it, @bold{PLT Scheme} is
@itemize{
@item{a @defterm{programming language}---a descendant of Scheme, which
is a dialect of Lisp;}
is a dialect of Lisp;
@margin-note{See @secref["dialects"] for more information on
other dialects of Scheme and how they relate to PLT Scheme.}}
@item{a @defterm{family} of programming languages---variants of
Scheme, and more; or}
@ -54,6 +57,9 @@ that's above the text area. DrScheme then understands that you mean to
work in the normal variant of Scheme (as opposed to the smaller
@schememodname[scheme/base], or many other possibilities).
@margin-note{@secref["more-hash-lang"] describes some of the other
possibilities.}
If you've used DrScheme before with something other than a program
that starts @hash-lang[], DrScheme will remember the last language
that you used, instead of inferring the language from the @hash-lang[]

16
collects/scribblings/reference/read.scrbl
View File

@ -27,8 +27,8 @@ See @secref["reader"] for information on the default reader in
@scheme[read-syntax] mode.}
@defproc[(read/recursive [in input-port? (current-input-port)]
[start (or/c character? #f) #f]
[readtable readtable? (current-readtable)]
[start (or/c char? #f) #f]
[readtable (or/c readtable? #f) (current-readtable)]
[graph? any/c #f])
any]{
@ -75,8 +75,8 @@ See @secref["readtables"] for an extended example that uses
@defproc[(read-syntax/recursive [source-name any/c (object-name in)]
[in input-port? (current-input-port)]
[start (or/c character? #f) #f]
[readtable readtable? (current-readtable)]
[start (or/c char? #f) #f]
[readtable (or/c readtable? #f) (current-readtable)]
[graph? any/c #f])
any]{
@ -315,8 +315,8 @@ Like @scheme[read-syntax], but for Honu mode (see
@secref["parse-honu"]).}
@defproc[(read-honu/recursive [in input-port? (current-input-port)]
[start (or/c character? #f) #f]
[readtable readtable? (current-readtable)]
[start (or/c char? #f) #f]
[readtable (or/c readtable? #f) (current-readtable)]
[graph? any/c #f])
any]{
@ -325,8 +325,8 @@ Like @scheme[read/recursive], but for Honu mode (see
@defproc[(read-honu-syntax/recursive [source-name any/c (object-name in)]
[in input-port? (current-input-port)]
[start (or/c character? #f) #f]
[readtable readtable? (current-readtable)]
[start (or/c char? #f) #f]
[readtable (or/c readtable? #f) (current-readtable)]
[graph? any/c #f])
any]{

10
collects/scribblings/scribble/basic.scrbl
View File

@ -189,7 +189,13 @@ strings for a hierarchy, such as @scheme['("strings" "plain")] for a
the strings are ``cleaned'' using @scheme[clean-up-index-strings]. The
strings (without clean-up) also serve as the text to render in the
index. The @tech{decode}d @scheme[pre-content] is the text to appear
inline as the index target.}
inline as the index target.
Use @scheme[index] when an index entry should point to a specific word
or phrase within the typeset document (i.e., the
@scheme[pre-content]). Use @scheme[section-index], instead, to create
an index entry that leads to a section, instead of a specific word or
phrase within the section.}
@defproc[(index* [words (listof string?)]
@ -213,7 +219,7 @@ Like @scheme[index], but the word to index is determined by applying
Creates a @scheme[part-index-decl] to be associated with the enclosing
section by @scheme[decode]. The @scheme[word]s serve as both the keys
and as the rendered forms of the keys.}
and as the rendered forms of the keys within the index.}
@defproc[(index-section [#:tag tag (or/c false/c string?) "doc-index"])

2
collects/stepper/private/xml-snip-helpers.ss
View File

@ -53,7 +53,7 @@
(let* ([source-name (get-source-name editor)]
[port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
[xml (read-xml port)]
[xexpr (xml->xexpr (document-element xml))]
[xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))]
[clean-xexpr (if eliminate-whitespace-in-empty-tags?
(eliminate-whitespace-in-empty-tags xexpr)
xexpr)]

5
collects/string-constants/english-string-constants.ss
View File

@ -676,6 +676,9 @@ please adhere to these guidelines:
(complete-word "Complete Word") ; the complete word menu item in the edit menu
(no-completions "... no completions available") ; shows up in the completions menu when there are no completions (in italics)
(overwrite-mode "Overwrite Mode")
(enable-overwrite-mode-keybindings "Enable overwrite mode keybindings")
(preferences-info "Configure your preferences")
(preferences-menu-item "Preferences...")
@ -845,7 +848,7 @@ please adhere to these guidelines:
(close-tab "Close Tab") ;; must not have any &s in it.
(close-tab-amp "&Close Tab") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item
;;; edit-menu
;;; edit menu
(split-menu-item-label "&Split")
(collapse-menu-item-label "C&ollapse")

18
collects/string-constants/german-string-constants.ss
View File

@ -574,8 +574,10 @@
(complete-word "Wort vervollständigen") ; the complete word menu item in the edit menu
(no-completions "... keine Vervollständigungen verfügbar") ; shows up in the completions menu when there are no completions (in italics)
(overwrite-mode "Überschreib-Modus")
(enable-overwrite-mode-keybindings "Tastenbelegungen für Überschreib-Modus aktivieren")
(preferences-info "Konfiguriere die Einstellungen")
(preferences-info "Die Einstellungen konfigurieren")
(preferences-menu-item "Einstellungen...")
(keybindings-info "Aktuelle Tastaturbelegung anzeigen")
@ -741,7 +743,7 @@
(close-tab-amp "Tab &schließen") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item
;;; edit-menu
;;; edit menu
(split-menu-item-label "&Splitten")
(collapse-menu-item-label "Einfalten")
@ -763,7 +765,7 @@
(force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen")
(limit-memory-menu-item-label "Speicherverbrauch einschränken...")
(limit-memory-msg-1 "Das Limit wird beim nächsten Programmstart aktiv")
(limit-memory-msg-2 "und muß mindestens 1 Megabyte betragen.")
(limit-memory-msg-2 "und muss mindestens ein Megabyte betragen.")
(limit-memory-unlimited "nicht einschränken")
(limit-memory-limited "einschränken")
(limit-memory-megabytes "Megabytes")
@ -802,9 +804,9 @@
(create "Erzeugen")
(please-specify-a-filename "Bitte einen Dateinamen angeben.")
(~a-must-end-with-~a
"Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Der Dateiname muß auf \".~a\" enden.")
"Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Der Dateiname muss auf \".~a\" enden.")
(macosx-executables-must-end-with-app
"Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Unter Mac OS X muß der Dateiname auf \".app\" enden.")
"Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Unter Mac OS X muss der Dateiname auf \".app\" enden.")
(warning-directory-will-be-replaced
"WARNUNG: Das Verzeichnis:\n\n ~a\n\nsoll überschrieben werden. Weitermachen?")
@ -837,9 +839,9 @@
(whole-part "Ganzzahliger Anteil")
(numerator "Zähler")
(denominator "Nenner")
(insert-number/bad-whole-part "Der ganzzahlige Anteil muß eine ganze Zahl sein")
(insert-number/bad-numerator "Der Zähler einer Zahl muß eine nichtnegative ganze Zahl sein")
(insert-number/bad-denominator "Der Nenner einer Zahl muß eine nichtnegative ganze Zahl sein")
(insert-number/bad-whole-part "Der ganzzahlige Anteil muss eine ganze Zahl sein")
(insert-number/bad-numerator "Der Zähler einer Zahl muss eine nichtnegative ganze Zahl sein")
(insert-number/bad-denominator "Der Nenner einer Zahl muss eine nichtnegative ganze Zahl sein")
(insert-fraction-menu-item-label "Bruch einfügen...")

8
collects/tests/mzscheme/foreign-test.ss
View File

@ -101,9 +101,15 @@
(test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int))
(lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10)))
;; ---
(test* 4 'g2 _int (lambda (p) p))
;; ---
(set-ffi-obj! "g3" test-lib (_fun _int -> _int) add1)
(t 4 'use_g3 (_fun _int -> _int) 3)
(test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3)))
(test* 4 'g3 _pointer (lambda (p) ((function-ptr p (_fun _int -> _int)) 3)))
;; Equivalentlly, 'g3 is a static variable that holds a function pointer. By
;; looking it up with _fpointer, we get its address, which then works
;; with ptr-ref to extract the function.
(test* 7 'g3 _fpointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 6)))
;; ---
(test ((lambda (x f) ((f (+ x 1)) (- x 1)))
3 (lambda (x) (lambda (y) (+ y (* x x)))))

11
collects/tests/mzscheme/testing.ss
View File

@ -79,11 +79,12 @@ transcript.
(define (load-in-sandbox file)
(define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id))
(let ([e ((S call-with-trusted-sandbox-configuration)
(parameterize ([(S sandbox-input) current-input-port]
[(S sandbox-output) current-output-port]
[(S sandbox-error-output) current-error-port]
[(S sandbox-memory-limit) 100]) ; 100mb per box
((S make-evaluator) '(begin) #:requires (list 'scheme))))])
(lambda ()
(parameterize ([(S sandbox-input) current-input-port]
[(S sandbox-output) current-output-port]
[(S sandbox-error-output) current-error-port]
[(S sandbox-memory-limit) 100]) ; 100mb per box
((S make-evaluator) '(begin) #:requires (list 'scheme)))))])
(e `(load-relative "testing.ss"))
(e `(define real-error-port (quote ,real-error-port)))
(e `(define Section-prefix ,Section-prefix))

2
collects/typed-scheme/ts-guide.scrbl
View File

@ -14,6 +14,8 @@
@author["Sam Tobin-Hochstadt"]
@section-index["typechecking"]
Typed Scheme is a Scheme-like language, with a type system that
supports common Scheme programming idioms. Explicit type declarations
are required --- that is, there is no type inference. The language

1
collects/xml/private/sig.ss
View File

@ -41,6 +41,7 @@
xexpr->string
xexpr-drop-empty-attributes
xexpr?
permissive?
correct-xexpr?
validate-xexpr
(struct exn:invalid-xexpr (code))

4
collects/xml/private/xexpr.ss
View File

@ -146,6 +146,9 @@
(pair? (cdr b))
(string? (cadr b))
(null? (cddr b))))
; permissive? : parameter bool
(define permissive? (make-parameter #f))
;; xml->xexpr : Content -> Xexpr
(define (xml->xexpr x)
@ -169,6 +172,7 @@
[(entity? x) (entity-text x)]
[(or (comment? x) (pi? x) (cdata? x)) x]
[(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)]
[(permissive?) x]
[else (error 'xml->xexpr "Expected content, given ~e" x)]))))
;; attribute->srep : Attribute -> Attribute-srep

37
collects/xml/test.ss
View File

@ -3,13 +3,13 @@
(module test mzscheme
(require xml/xml)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; utils
;;
;; test-bad-read-input : format-str str -> void
;; First argument is the input, second is the error message
(define (test-bad-read-input format-str err-string)
@ -20,11 +20,11 @@
(report-err format-str (exn-message x) err-string)))])
(read-xml (open-input-string str))
(report-err str "no error" err-string))))
;; tests-failed : number
;; incremened for each test that fails
(define tests-failed 0)
;; report-err : string string string -> void
;; reports an error in the test suite
;; increments tests-failed.
@ -32,7 +32,7 @@
(set! tests-failed (+ tests-failed 1))
(printf "FAILED test: ~a~n got: ~a~n expected: ~a~n"
test got expected))
;; done : -> void
;; prints out a message saying the tests are done.
;; if any tests failed, prints a message saying how many
@ -40,13 +40,13 @@
(if (= tests-failed 0)
(printf "All tests passed~n")
(printf "~a tests failed~n" tests-failed)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; reader error tests
;;
(test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof")
(test-bad-read-input "<a>" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]")
(test-bad-read-input
@ -54,7 +54,7 @@
"read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]")
(test-bad-read-input
"<a <a>" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'")
(test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof")
(test-bad-read-input "~n<a>" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]")
(test-bad-read-input
@ -62,8 +62,21 @@
"read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]")
(test-bad-read-input
"~n<a <a>" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'")
;; permissive?
(with-handlers ([exn?
(lambda (exn)
(regexp-match #rx"Expected content," (exn-message exn)))])
(report-err "Non-permissive" (xml->xexpr #f) "Exception"))
(with-handlers ([exn?
(lambda (exn)
(report-err "Permissive" "Exception" "#f"))])
(parameterize ([permissive? #t])
(let ([tmp (xml->xexpr #f)])
(when tmp
(report-err "Permissive" tmp "#f")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; done

9
collects/xml/xml.scrbl
View File

@ -235,9 +235,16 @@ like @scheme[display-xml].}
@section{XML and X-expression Conversions}
@defboolparam[permissive? v]{
If this is set to non-false, then @scheme[xml->xexpr] will allow
non-XML objects, such as other structs, in the content of the converted XML
and leave them in place in the resulting ``@tech{X-expression}''.
}
@defproc[(xml->xexpr [content content?]) xexpr?]{
Converts document content into an @tech{X-expression}.}
Converts document content into an @tech{X-expression}, using
@scheme[permissive?] to determine if foreign objects are allowed.}
@defproc[(xexpr->xml [xexpr xexpr?]) content?]{

176
src/foreign/foreign.c
View File

@ -461,7 +461,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
#endif
#endif
unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return SCHEME_CHAR_STR_VAL(ucs);
}
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
{
long ulen;
unsigned short *res;
@ -471,11 +479,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
return res;
}
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return ucs4_string_to_utf16_pointer(ucs);
}
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
long ulen;
mzchar *res;
int end;
if (!utf) return scheme_false;
for (end=0; utf[end] != 0; end++) { /**/ }
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
return scheme_make_sized_char_string(res, ulen, 0);
@ -696,7 +711,17 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_utf_16 (19)
#define FOREIGN_string_ucs_4_null (19)
/* Type Name: string/ucs-4/null (string_ucs_4_null)
* LibFfi type: ffi_type_pointer
* C type: mzchar*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_utf_16 (20)
/* Type Name: string/utf-16 (string_utf_16)
* LibFfi type: ffi_type_pointer
* C type: unsigned short*
@ -706,10 +731,20 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
*/
#define FOREIGN_string_utf_16_null (21)
/* Type Name: string/utf-16/null (string_utf_16_null)
* LibFfi type: ffi_type_pointer
* C type: unsigned short*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_utf16_pointer(<Scheme>)
* S->C offset: 0
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
*/
/* Byte strings -- not copying C strings, #f is NULL.
* (note: these are not like char* which is just a pointer) */
#define FOREIGN_bytes (20)
#define FOREIGN_bytes (22)
/* Type Name: bytes
* LibFfi type: ffi_type_pointer
* C type: char*
@ -719,7 +754,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
*/
#define FOREIGN_path (21)
#define FOREIGN_path (23)
/* Type Name: path
* LibFfi type: ffi_type_pointer
* C type: char*
@ -729,7 +764,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
*/
#define FOREIGN_symbol (22)
#define FOREIGN_symbol (24)
/* Type Name: symbol
* LibFfi type: ffi_type_pointer
* C type: char*
@ -742,7 +777,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is for any C pointer: #f is NULL, cpointer values as well as
* ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */
#define FOREIGN_pointer (23)
#define FOREIGN_pointer (25)
/* Type Name: pointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -754,7 +789,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */
#define FOREIGN_scheme (24)
#define FOREIGN_scheme (26)
/* Type Name: scheme
* LibFfi type: ffi_type_pointer
* C type: Scheme_Object*
@ -767,10 +802,10 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
#define FOREIGN_fpointer (25)
#define FOREIGN_fpointer (27)
/* Type Name: fpointer
* LibFfi type: ffi_type_pointer
* C type: -none-
* C type: void*
* Predicate: -none-
* Scheme->C: -none-
* S->C offset: 0
@ -795,16 +830,19 @@ typedef union _ForeignAny {
double x_doubleS;
int x_bool;
mzchar* x_string_ucs_4;
mzchar* x_string_ucs_4_null;
unsigned short* x_string_utf_16;
unsigned short* x_string_utf_16_null;
char* x_bytes;
char* x_path;
char* x_symbol;
void* x_pointer;
Scheme_Object* x_scheme;
void* x_fpointer;
} ForeignAny;
/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (26)
#define FOREIGN_struct (28)
/*****************************************************************************/
/* Type objects */
@ -925,13 +963,15 @@ static int ctype_sizeof(Scheme_Object *type)
case FOREIGN_doubleS: return sizeof(double);
case FOREIGN_bool: return sizeof(int);
case FOREIGN_string_ucs_4: return sizeof(mzchar*);
case FOREIGN_string_ucs_4_null: return sizeof(mzchar*);
case FOREIGN_string_utf_16: return sizeof(unsigned short*);
case FOREIGN_string_utf_16_null: return sizeof(unsigned short*);
case FOREIGN_bytes: return sizeof(char*);
case FOREIGN_path: return sizeof(char*);
case FOREIGN_symbol: return sizeof(char*);
case FOREIGN_pointer: return sizeof(void*);
case FOREIGN_scheme: return sizeof(Scheme_Object*);
case FOREIGN_fpointer: return 0;
case FOREIGN_fpointer: return sizeof(void*);
/* for structs */
default: return CTYPE_PRIMTYPE(type)->size;
}
@ -1180,8 +1220,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the REF_CTYPE trick for pointers */
return (Scheme_Object*)W_OFFSET(src, delta);
return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
case FOREIGN_void: return scheme_void;
case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
@ -1201,13 +1240,15 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
case FOREIGN_string_ucs_4_null: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
case FOREIGN_string_utf_16_null: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
case FOREIGN_fpointer: return scheme_void;
case FOREIGN_fpointer: return (REF_CTYPE(void*));
case FOREIGN_struct:
return scheme_make_foreign_cpointer(W_OFFSET(src, delta));
default: scheme_signal_error("corrupt foreign type: %V", type);
@ -1239,7 +1280,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
type = CTYPE_BASETYPE(type);
}
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val))
@ -1465,6 +1506,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_ucs_4_null:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(mzchar*));
}
#endif
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL ||tmp == NULL) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_ucs_4_null;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/ucs-4/null",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
@ -1486,6 +1548,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16_null:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*));
}
#endif
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
if (basetype_p == NULL ||tmp == NULL) {
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_utf_16_null;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/utf-16/null",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_bytes:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(char*)<sizeof(int) && ret_loc) {
@ -2119,19 +2202,24 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 2)
scheme_signal_error
(MYNAME": referencing fpointer with extra arguments");
else
if (SCHEME_FFIOBJP(argv[0])) {
/* The ffiobj pointer is the function pointer. */
ptr = argv[0];
} else if (size < 0) {
delta = (long)&(((ffi_obj_struct*)0x0)->obj);
}
}
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 3) {
}
if (argc > 3) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
@ -2140,6 +2228,8 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
} else if (argc > 2) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
return C2SCHEME(argv[1], ptr, delta, 0);
@ -2165,33 +2255,26 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 3) {
scheme_signal_error
(MYNAME": setting fpointer value with extra arguments");
} else if (SCHEME_CPTRP(argv[0])) {
ptr = SCHEME_CPTR_VAL(argv[0]);
} else if SCHEME_FFIOBJP(argv[0]) {
ptr = ((ffi_obj_struct*)(argv[0]))->obj;
} else {
scheme_signal_error
(MYNAME": bad lvalue (NULL or string)");
}
} else if (size < 0) {
size = ctype_sizeof(base);
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 4) {
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
@ -2388,9 +2471,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
avalues = NULL;
switch (CTYPE_PRIMLABEL(base)) {
case FOREIGN_fpointer: /* need to allocate a pointer */
p = scheme_make_foreign_cpointer(oval.x_pointer);
break;
case FOREIGN_struct:
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
free(p);
@ -2897,6 +2977,13 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4/null");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4_null);
scheme_add_global("_string/ucs-4/null", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
@ -2904,6 +2991,13 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16/null");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16_null);
scheme_add_global("_string/utf-16/null", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;

89
src/foreign/foreign.ssc
View File

@ -392,7 +392,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v)
#endif
#endif
unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o))
static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return SCHEME_CHAR_STR_VAL(ucs);
}
static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
{
long ulen;
unsigned short *res;
@ -402,11 +410,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs)
return res;
}
static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs)
{
if (SCHEME_FALSEP(ucs)) return NULL;
return ucs4_string_to_utf16_pointer(ucs);
}
Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
{
long ulen;
mzchar *res;
int end;
if (!utf) return scheme_false;
for (end=0; utf[end] != 0; end++) { /**/ }
res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0);
return scheme_make_sized_char_string(res, ulen, 0);
@ -644,6 +659,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
's->c "SCHEME_CHAR_STR_VAL"
'c->s "scheme_make_char_string_without_copying")
(defctype 'string/ucs-4/null
'ftype "pointer"
'ctype "mzchar*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
's->c "ucs4_string_or_null_to_ucs4_pointer"
'c->s "scheme_make_char_string_without_copying")
(defctype 'string/utf-16
'ftype "pointer"
'ctype "unsigned short*"
@ -651,6 +673,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
's->c "ucs4_string_to_utf16_pointer"
'c->s "utf16_pointer_to_ucs4_string")
(defctype 'string/utf-16/null
'ftype "pointer"
'ctype "unsigned short*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
's->c "ucs4_string_or_null_to_utf16_pointer"
'c->s "utf16_pointer_to_ucs4_string")
(~ "/* Byte strings -- not copying C strings, #f is NULL." \\
" * (note: these are not like char* which is just a pointer) */" \\
)
@ -714,7 +743,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
(~ "/* Special type, not actually used for anything except to mark values" \\
" * that are treated like pointers but not referenced. Used for" \\
" * creating function types. */")
(defctype 'fpointer 'ftype "pointer" 'ctype #f)
(defctype 'fpointer 'ftype "pointer" 'ctype "void*")
:}
typedef union _ForeignAny {
@ -993,8 +1022,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
else
return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
} else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the REF_CTYPE trick for pointers */
return (Scheme_Object*)W_OFFSET(src, delta);
return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
} else switch (CTYPE_PRIMLABEL(type)) {
{:(for-each-type
(~ "case FOREIGN_"cname": return "
@ -1033,7 +1061,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
type = CTYPE_BASETYPE(type);
}
if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
/* No need for the SET_CTYPE trick for pointers */
/* No need for the SET_CTYPE trick for pointers. */
if (SCHEME_FFICALLBACKP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback;
else if (SCHEME_CPTRP(val))
@ -1047,7 +1075,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
(define (wrong-type obj type)
(list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));"))
(~ "case FOREIGN_"cname":")
(if ctype
(if (and ctype (not (equal? stype "fpointer")))
(let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")]
[f (lambda (p)
(if (procedure? p) (p "val" x) (list p"(val)")))])
@ -1571,19 +1599,24 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 2)
scheme_signal_error
(MYNAME": referencing fpointer with extra arguments");
else
if (SCHEME_FFIOBJP(argv[0])) {
/* The ffiobj pointer is the function pointer. */
ptr = argv[0];
} else if (size < 0) {
delta = (long)&(((ffi_obj_struct*)0x0)->obj);
}
}
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 3) {
}
if (argc > 3) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
@ -1592,6 +1625,8 @@ static Scheme_Object *do_memop(const char *who, int mode,
} else if (argc > 2) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
return C2SCHEME(argv[1], ptr, delta, 0);
@ -1615,33 +1650,26 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1])))
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
else size = ctype_sizeof(base);
if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
if (argc > 3) {
scheme_signal_error
(MYNAME": setting fpointer value with extra arguments");
} else if (SCHEME_CPTRP(argv[0])) {
ptr = SCHEME_CPTR_VAL(argv[0]);
} else if SCHEME_FFIOBJP(argv[0]) {
ptr = ((ffi_obj_struct*)(argv[0]))->obj;
} else {
scheme_signal_error
(MYNAME": bad lvalue (NULL or string)");
}
} else if (size < 0) {
size = ctype_sizeof(base);
if (size < 0) {
/* should not happen */
scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
} else if (size == 0) {
scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
} else if (argc > 4) {
}
if (argc > 4) {
if (!SAME_OBJ(argv[2],abs_sym))
scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
if (!SCHEME_INTP(argv[3]))
scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
delta += SCHEME_INT_VAL(argv[3]);
} else if (argc > 3) {
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type(MYNAME, "integer", 2, argc, argv);
if (!size)
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2]));
}
SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0);
@ -1834,9 +1862,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
avalues = NULL;
switch (CTYPE_PRIMLABEL(base)) {
case FOREIGN_fpointer: /* need to allocate a pointer */
p = scheme_make_foreign_cpointer(oval.x_pointer);
break;
case FOREIGN_struct:
memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
free(p);

4
src/mzscheme/gc2/mem_account.c
View File

@ -213,7 +213,7 @@ inline static void clean_up_owner_table(NewGC *gc)
inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
{
OTEntry **owner_table = gc->owner_table;
OTEntry **owner_table;
unsigned long retval = 0;
int i;
@ -226,6 +226,8 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian)
}
i = custodian_to_owner_set(gc, (Scheme_Custodian *)custodian);
owner_table = gc->owner_table;
if (owner_table[i])
retval = owner_table[i]->memory_use;
else

7
src/mzscheme/src/env.c
View File

@ -3690,7 +3690,7 @@ int scheme_resolve_quote_syntax_pos(Resolve_Info *info)
return info->prefix->num_toplevels;
}
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr)
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready)
{
int skip;
@ -3699,7 +3699,10 @@ Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr)
return make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */
SCHEME_TOPLEVEL_POS(expr),
1,
SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_CONST);
SCHEME_TOPLEVEL_FLAGS(expr) & (SCHEME_TOPLEVEL_CONST
| (keep_ready
? SCHEME_TOPLEVEL_READY
: 0)));
}
Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta)

13
src/mzscheme/src/eval.c
View File

@ -778,6 +778,17 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
}
}
if (vtype == scheme_compiled_toplevel_type) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
if (SCHEME_TOPLEVEL_FLAGS(o)
& (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))
return 1;
else
return 0;
}
}
if ((vtype == scheme_syntax_type)
&& (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD)) {
note_match(1, vals, warn_info);
@ -1906,7 +1917,7 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
case scheme_compiled_let_void_type:
return scheme_resolve_lets(expr, info);
case scheme_compiled_toplevel_type:
return scheme_resolve_toplevel(info, expr);
return scheme_resolve_toplevel(info, expr, 1);
case scheme_compiled_quote_syntax_type:
{
Scheme_Quote_Syntax *qs;

23
src/mzscheme/src/module.c
View File

@ -4803,7 +4803,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
int start_simltaneous = 0, i_m, cnt;
Scheme_Object *cl_first = NULL, *cl_last = NULL;
Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL;
int cont;
int cont, next_pos_ready = -1;
old_context = info->context;
info->context = (Scheme_Object *)m;
@ -4887,14 +4887,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
/* Test for ISCONST to indicate no set!: */
if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
pos = SCHEME_TOPLEVEL_POS(a);
if (!ready_table) {
ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
}
scheme_hash_set(ready_table, scheme_make_integer(pos), scheme_true);
next_pos_ready = pos;
}
}
}
@ -4966,6 +4960,17 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
re_consts = NULL;
start_simltaneous = i_m + 1;
}
if (next_pos_ready > -1) {
if (!ready_table) {
ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
}
scheme_hash_set(ready_table, scheme_make_integer(next_pos_ready), scheme_true);
next_pos_ready = -1;
}
}
/* Check one more time for expressions that we can omit: */

2
src/mzscheme/src/schpriv.h
View File

@ -2225,7 +2225,7 @@ int scheme_resolve_toplevel_pos(Resolve_Info *info);
int scheme_resolve_is_toplevel_available(Resolve_Info *info);
int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info);
int scheme_resolve_quote_syntax_pos(Resolve_Info *info);
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr);
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready);
Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info);
Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl);
Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta);

2
src/mzscheme/src/syntax.c
View File

@ -1010,7 +1010,7 @@ define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
&& (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) {
a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST);
}
a = scheme_resolve_toplevel(rslv, a);
a = scheme_resolve_toplevel(rslv, a, 0);
SCHEME_CAR(l) = a;
cnt++;
}