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

Racket experiments

Browse Source 
svn: r18725
This commit is contained in:
Matthew Flatt 2010-04-02 21:29:59 +00:00
parent 2a87df9e5c
commit 2cb9f378aa
51 changed files with 1875 additions and 982 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/compiler/embed-unit.ss
View File

@ -746,21 +746,19 @@
;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port.
(define (do-write-module-bundle outp verbose? modules literal-files literal-expressions collects-dest
(define (do-write-module-bundle outp verbose? modules config? literal-files literal-expressions collects-dest
on-extension program-name compiler expand-namespace
src-filter get-extra-imports)
(let* ([module-paths (map cadr modules)]
[files (map
(lambda (mp)
[resolve-one-path (lambda (mp)
(let ([f (resolve-module-path mp #f)])
(unless f
(error 'write-module-bundle "bad module path: ~e" mp))
(normalize f)))
module-paths)]
[collapsed-mps (map
(lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))
module-paths)]
(normalize f)))]
[files (map resolve-one-path module-paths)]
[collapse-one (lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))]
[collapsed-mps (map collapse-one module-paths)]
[prefix-mapping (map (lambda (f m)
(cons f (let ([p (car m)])
(cond
@ -774,13 +772,27 @@
files modules)]
;; Each element is created with `make-mod'.
;; As we descend the module tree, we append to the front after
;; loasing imports, so the list in the right order.
[codes (box null)])
(for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose? collects-dest
;; loading imports, so the list in the right order.
[codes (box null)]
[get-code-at (lambda (f mp)
(get-code f mp codes prefix-mapping verbose? collects-dest
on-extension compiler expand-namespace
get-extra-imports))
files
collapsed-mps)
get-extra-imports))]
[__
;; Load all code:
(for-each get-code-at files collapsed-mps)]
[config-info (and config?
(let ([a (assoc (car files) (unbox codes))])
(let ([info (module-compiled-language-info (mod-code a))])
(when info
(let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1))
(vector-ref info 2))])
(get-info 'configure-runtime #f))))))])
;; Add module for runtime configuration:
(when config-info
(let ([mp (vector-ref config-info 0)])
(get-code-at (resolve-one-path mp)
(collapse-one mp))))
;; Drop elements of `codes' that just record copied libs:
(set-box! codes (filter mod-code (unbox codes)))
;; Bind `module' to get started:
@ -917,6 +929,12 @@
(write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp)
(write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
(newline outp)
(when config-info
(let ([a (assoc (resolve-one-path (vector-ref config-info 0)) (unbox codes))])
(write (compile-using-kernel `((dynamic-require '',(mod-full-name a)
',(vector-ref config-info 1))
',(vector-ref config-info 2)))
outp)))
(for-each (lambda (f)
(when verbose?
(fprintf (current-error-port) "Copying from ~s~n" f))
@ -928,6 +946,7 @@
(define (write-module-bundle #:verbose? [verbose? #f]
#:modules [modules null]
#:configure-via-first-module? [config? #f]
#:literal-files [literal-files null]
#:literal-expressions [literal-expressions null]
#:on-extension [on-extension #f]
@ -937,7 +956,7 @@
(compile expr)))]
#:src-filter [src-filter (lambda (filename) #f)]
#:get-extra-imports [get-extra-imports (lambda (filename code) null)])
(do-write-module-bundle (current-output-port) verbose? modules literal-files literal-expressions
(do-write-module-bundle (current-output-port) verbose? modules config? literal-files literal-expressions
#f ; collects-dest
on-extension
"?" ; program-name
@ -970,6 +989,7 @@
#:mred? [mred? #f]
#:verbose? [verbose? #f]
#:modules [modules null]
#:configure-via-first-module? [config? #f]
#:literal-files [literal-files null]
#:literal-expression [literal-expression #f]
#:literal-expressions [literal-expressions
@ -1086,7 +1106,7 @@
(let ([write-module
(lambda (s)
(do-write-module-bundle s
verbose? modules literal-files literal-expressions collects-dest
verbose? modules config? literal-files literal-expressions collects-dest
on-extension
(file-name-from-path dest)
compiler

1
collects/compiler/main.ss
View File

@ -569,6 +569,7 @@
#:modules (cons `(#%mzc: (file ,(car source-files)))
(map (lambda (l) `(#t (lib ,l)))
(exe-embedded-libraries)))
#:configure-via-first-module? #t
#:literal-expression
(parameterize ([current-namespace (make-base-namespace)])
(compile

14
collects/mzlib/pconvert.ss
View File

@ -1,10 +1,8 @@
(module pconvert mzscheme
(require (only "string.ss" expr->string)
(only "list.ss" sort)
(require (only "list.ss" sort)
scheme/mpair
"etc.ss"
"pconvert-prop.ss"
"class.ss")
@ -169,7 +167,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define map-share-name
(lambda (name)
(string->symbol (string-append "-" (expr->string name) "-"))))
(string->symbol (format "-~s-" name))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; prints an expression given that it has already been hashed. This
@ -458,8 +456,7 @@
[str-name (if (string? name)
name
(symbol->string name))])
(string->symbol (string-append "make-" str-name))))]
[uniq (begin-lifted (box #f))])
(string->symbol (string-append "make-" str-name))))])
`(,constructor
,@(map (lambda (x)
(if (eq? uniq x)
@ -497,6 +494,7 @@
[(null? x) null]
[else (f x)]))
(define uniq (gensym))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these functions get the list of shared items. If just-circular is
@ -536,8 +534,8 @@
(get-shared-helper csi))
(get-shared-helper csi))]
[cmp (lambda (x y)
(string<? (expr->string (share-info-name (car x)))
(expr->string (share-info-name (car y)))))])
(string<? (format "~s" (share-info-name (car x)))
(format "~s" (share-info-name (car y)))))])
(map cdr (sort shared-listss cmp)))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
collects/racket/base.ss Normal file
View File

@ -0,0 +1,6 @@
#lang racket/private
(require "private/define-struct.ss")
(provide (except-out (all-from-out scheme/base)
define-struct)
(rename-out [new-define-struct define-struct]))

5
collects/racket/base/lang/reader.ss Normal file
View File

@ -0,0 +1,5 @@
#lang s-exp syntax/module-reader
racket/base
#:info get-info
(require racket/private/get-info)

15
collects/racket/init.ss Normal file
View File

@ -0,0 +1,15 @@
#lang racket
(require scheme/enter
scheme/help
"private/runtime.ss")
;; Set the printer:
(current-print (let ([pretty-printer
(lambda (v)
(unless (void? v)
(pretty-print v)))])
pretty-printer))
(provide (all-from-out racket
scheme/enter
scheme/help))

6
collects/racket/lang/reader.ss Normal file
View File

@ -0,0 +1,6 @@
#lang s-exp syntax/module-reader
racket
#:info get-info
(require racket/private/get-info)

8
collects/racket/main.ss Normal file
View File

@ -0,0 +1,8 @@
#lang racket/private
(require scheme)
(require "private/define-struct.ss")
(provide (except-out (all-from-out scheme)
define-struct)
(rename-out [new-define-struct define-struct]))

23
collects/racket/private/define-struct.ss Normal file
View File

@ -0,0 +1,23 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide new-define-struct)
(define-syntax (new-define-struct stx)
(define (config-has-name? config)
(cond
[(syntax? config) (config-has-name? (syntax-e config))]
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
(config-has-name? (cdr config)))]
[else #f]))
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ id+super fields . config)
(not (config-has-name? #'config))
(with-syntax ([id (syntax-case #'id+super ()
[(id super) #'id]
[else #'id+super])])
(syntax/loc stx
(define-struct/derived orig id+super fields #:constructor-name id . config)))]
[_ (syntax/loc stx
(define-struct/derived orig id+super fields . config))])))

12
collects/racket/private/get-info.ss Normal file
View File

@ -0,0 +1,12 @@
#lang scheme/base
(provide get-info)
(define get-info
(lambda (key def get-default)
(case key
[(configure-runtime)
'#(racket/private/runtime configure #f)]
[else
(get-default key def)])))

5
collects/racket/private/lang/reader.ss Normal file
View File

@ -0,0 +1,5 @@
#lang s-exp syntax/module-reader
scheme/base
#:info get-info
(require racket/private/get-info)

7
collects/racket/private/runtime.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(require mzlib/pconvert)
(provide configure)
(define (configure config)
(print-as-quasiquote #t))

346
collects/scheme/pretty.ss
View File

@ -13,6 +13,7 @@
(require mzlib/private/port)
(provide pretty-print
pretty-write
pretty-display
pretty-print-columns
pretty-print-depth
@ -202,7 +203,7 @@
res)))))
(define make-pretty-print
(lambda (display?)
(lambda (display? as-qq?)
(letrec ([pretty-print
(case-lambda
[(obj port)
@ -220,6 +221,7 @@
(pretty-print-print-line))
(print-graph) (print-struct) (print-hash-table)
(and (not display?) (print-vector-length)) (print-box)
(and (not display?) as-qq? (print-as-quasiquote))
(pretty-print-depth)
(lambda (o display?)
(size-hook o display? port)))
@ -227,8 +229,9 @@
[(obj) (pretty-print obj (current-output-port))])])
pretty-print)))
(define pretty-print (make-pretty-print #f))
(define pretty-display (make-pretty-print #t))
(define pretty-print (make-pretty-print #f #t))
(define pretty-display (make-pretty-print #t #f))
(define pretty-write (make-pretty-print #f #f))
(define-struct mark (str def))
(define-struct hide (val))
@ -398,8 +401,11 @@
(vector-set! v 0 d)
#t))))
(define-struct unquoted (val))
(define (generic-write obj display? width pport
print-graph? print-struct? print-hash-table? print-vec-length? print-box?
print-graph? print-struct? print-hash-table? print-vec-length?
print-box? print-as-qq?
depth size-hook)
(define pair-open (if (print-pair-curly-braces) "{" "("))
@ -589,17 +595,20 @@
(expr-found pport ref))
(n-k)))))))
(define (write-custom recur obj pport depth display? width)
(define (write-custom recur obj pport depth display? width qd)
(let-values ([(l c p) (port-next-location pport)])
(let ([p (relocate-output-port pport l c p)])
(port-count-lines! p)
(let ([writer (lambda (v port)
(recur port v (dsub1 depth) #f))]
(recur port v (dsub1 depth) #f qd))]
[displayer (lambda (v port)
(recur port v (dsub1 depth) #t))])
(recur port v (dsub1 depth) #t qd))]
[printer (case-lambda
[(v port) (recur port v (dsub1 depth) #t qd)]
[(v port qd) (recur port v (dsub1 depth) #t qd)])])
(port-write-handler p writer)
(port-display-handler p displayer)
(port-print-handler p writer))
(port-print-handler p printer))
(register-printing-port-like p pport)
(parameterize ([pretty-printing #t]
[pretty-print-columns (or width 'infinity)])
@ -607,23 +616,23 @@
;; ------------------------------------------------------------
;; wr: write on a single line
(define (wr* pport obj depth display?)
(define (wr* pport obj depth display? qd)
(define (out str)
(write-string str pport))
(define (wr obj depth)
(wr* pport obj depth display?))
(define (wr obj depth qd)
(wr* pport obj depth display? qd))
(define (wr-expr expr depth pair? car cdr open close)
(if (and (read-macro? expr pair? car cdr)
(define (wr-expr expr depth pair? car cdr open close qd)
(if (and (read-macro? expr pair? car cdr qd)
(equal? open "("))
(begin
(out (read-macro-prefix expr car))
(wr (read-macro-body expr car cdr) depth))
(wr-lst expr #t depth pair? car cdr open close)))
(wr (read-macro-body expr car cdr) depth (reader-adjust-qd (car expr) qd)))
(wr-lst expr #t depth pair? car cdr open close qd)))
(define (wr-lst l check? depth pair? car cdr open close)
(define (wr-lst l check? depth pair? car cdr open close qd)
(if (pair? l)
(check-expr-found
l pport check?
@ -636,33 +645,35 @@
(out close))
(begin
(out open)
(wr (car l) (dsub1 depth))
(wr (car l) (dsub1 depth) qd)
(let loop ([l (cdr l)])
(check-expr-found
l pport (and check? (pair? l))
(lambda (s) (out " . ") (out s) (out close))
(lambda ()
(out " . ")
(wr-lst l check? (dsub1 depth) pair? car cdr open close)
(wr-lst l check? (dsub1 depth) pair? car cdr open close qd)
(out close))
(lambda ()
(cond
[(pair? l)
(if (and (eq? (car l) 'unquote)
(if (and (eq? (do-remap (car l)) 'unquote)
(not (equal? qd 1))
(pair? (cdr l))
(null? (cdr (cdr l))))
(begin
(out " . ,")
(wr (car (cdr l)) (dsub1 depth))
(wr (car (cdr l)) (dsub1 depth)
(reader-adjust-qd (car l) qd))
(out close))
(begin
(out " ")
(wr (car l) (dsub1 depth))
(wr (car l) (dsub1 depth) qd)
(loop (cdr l))))]
[(null? l) (out close)]
[else
(out " . ")
(wr l (dsub1 depth))
(wr l (dsub1 depth) qd)
(out close)]))))))))
(begin
(out open)
@ -681,28 +692,33 @@
(output-hooked pport obj len display?))]
[(pair? obj)
(wr-expr obj depth pair? car cdr pair-open pair-close)]
(let ([qd (to-quoted out qd "`")])
(wr-expr obj depth pair? car cdr pair-open pair-close qd))]
[(mpair? obj)
(wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close)]
(let ([qd (to-quoted out qd "`")])
(wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close qd))]
[(null? obj)
(wr-lst obj #f depth pair? car cdr "(" ")")]
(let ([qd (to-quoted out qd "'")])
(wr-lst obj #f depth pair? car cdr "(" ")" qd))]
[(vector? obj)
(check-expr-found
obj pport #t
#f #f
(lambda ()
(let ([qd (to-quoted out qd "`")])
(out "#")
(when print-vec-length?
(out (number->string (vector-length obj))))
(wr-lst (vector->repeatless-list obj) #f depth pair? car cdr "(" ")")))]
(wr-lst (vector->repeatless-list obj) #f depth pair? car cdr "(" ")" qd))))]
[(and (box? obj)
print-box?)
(check-expr-found
obj pport #t
#f #f
(lambda ()
(let ([qd (to-quoted out qd "`")])
(out "#&")
(wr (unbox obj) (dsub1 depth))))]
(wr (unbox obj) (dsub1 depth) qd))))]
[(and (custom-write? obj)
(not (struct-type? obj)))
(check-expr-found
@ -710,7 +726,7 @@
#f #f
(lambda ()
(parameterize ([pretty-print-columns 'infinity])
(write-custom wr* obj pport depth display? width))))]
(write-custom wr* obj pport depth display? width qd))))]
[(struct? obj)
(if (and print-struct?
(not (and depth
@ -719,11 +735,21 @@
obj pport #t
#f #f
(lambda ()
(let* ([v (struct->vector obj)]
[pf? (prefab?! obj v)])
(let ([qd (if pf?
(to-quoted out qd "`")
(to-unquoted out qd))])
(when (or (not qd) pf?)
(out "#")
(let ([v (struct->vector obj)])
(when (prefab?! obj v)
(out "s"))
(wr-lst (vector->list v) #f (dsub1 depth) pair? car cdr "(" ")"))))
(when pf? (out "s")))
(wr-lst (let ([l (vector->list v)])
(if (and qd (not pf?))
(cons (make-unquoted (object-name obj))
(cdr l))
l))
#f (dsub1 depth) pair? car cdr "(" ")"
qd)))))
(parameterize ([print-struct #f])
((if display? orig-display orig-write) obj pport)))]
[(hash-table? obj)
@ -734,6 +760,7 @@
obj pport #t
#f #f
(lambda ()
(let ([qd (to-quoted out qd "`")])
(out (if (hash-table? obj 'equal)
"#hash"
(if (hash-table? obj 'eqv)
@ -742,11 +769,11 @@
(wr-lst (hash-table-map obj (lambda (k v)
(cons k (make-hide v))))
#f depth
pair? car cdr "(" ")")))
pair? car cdr "(" ")" qd))))
(parameterize ([print-hash-table #f])
((if display? orig-display orig-write) obj pport)))]
[(hide? obj)
(wr* pport (hide-val obj) depth display?)]
(wr* pport (hide-val obj) depth display? qd)]
[(boolean? obj)
(out (if obj "#t" "#f"))]
[(number? obj)
@ -760,6 +787,18 @@
[(and (pretty-print-.-symbol-without-bars)
(eq? obj '|.|))
(out ".")]
[(and (equal? qd 1)
(or (eq? 'unquote obj)
(eq? 'unquote-splicing obj)))
(out ",'")
(orig-write obj pport)]
[(and qd (or (symbol? obj)
(keyword? obj)))
(to-quoted out qd "'")
(orig-write obj pport)]
[(unquoted? obj)
(let ([qd (to-unquoted out qd)])
(orig-write (unquoted-val obj) pport))]
[else
((if display? orig-display orig-write) obj pport)]))
(unless (hide? obj)
@ -767,10 +806,10 @@
;; ------------------------------------------------------------
;; pp: write on (potentially) multiple lines
(define (pp* pport obj depth display?)
(define (pp* pport obj depth display? qd)
(define (pp obj depth)
(pp* pport obj depth display?))
(pp* pport obj depth display? qd))
(define (out str)
(write-string str pport))
@ -790,7 +829,7 @@
(spaces (- to col))))
(spaces (max 0 (- to col))))))
(define (pr obj extra pp-pair depth)
(define (pr obj extra pp-pair depth qd)
;; may have to split on multiple lines
(let* ([can-multi (and width
(not (size-hook obj display?))
@ -819,7 +858,7 @@
(- width extra)
(lambda () (esc a-pport)))])
;; Here's the attempt to write on one line:
(wr* a-pport obj depth display?)
(wr* a-pport obj depth display? qd)
a-pport))])
(let-values ([(l c p) (port-next-location a-pport)])
(if (<= c (- width extra))
@ -835,43 +874,62 @@
(pre-print pport obj)
(cond
[(pair? obj) (pp-pair obj extra depth
pair? car cdr pair-open pair-close)]
pair? car cdr pair-open pair-close
qd)]
[(mpair? obj) (pp-pair obj extra depth
mpair? mcar mcdr mpair-open mpair-close)]
mpair? mcar mcdr mpair-open mpair-close
qd)]
[(vector? obj)
(let ([qd (to-quoted out qd "`")])
(out "#")
(when print-vec-length?
(out (number->string (vector-length obj))))
(pp-list (vector->repeatless-list obj) extra pp-expr #f depth
pair? car cdr pair-open pair-close)]
pair? car cdr pair-open pair-close
qd))]
[(and (custom-write? obj)
(not (struct-type? obj)))
(write-custom pp* obj pport depth display? width)]
(let ([qd (to-unquoted out qd)])
(write-custom pp* obj pport depth display? width qd))]
[(struct? obj) ; print-struct is on if we got here
(let* ([v (struct->vector obj)]
[pf? (prefab?! obj v)])
(let ([qd (if pf?
(to-quoted out qd "`")
(to-unquoted out qd))])
(when (or (not qd) pf?)
(out "#")
(let ([v (struct->vector obj)])
(when (prefab?! obj v)
(out "s"))
(pp-list (vector->list v) extra pp-expr #f depth
pair? car cdr pair-open pair-close))]
(when pf? (out "s")))
(pp-list (let ([l (vector->list v)])
(if (and qd (not pf?))
(cons (make-unquoted (object-name v))
(cdr l))
l))
extra pp-expr #f depth
pair? car cdr pair-open pair-close
qd)))]
[(hash-table? obj)
(let ([qd (to-quoted out qd "`")])
(out (if (hash-table? obj 'equal)
"#hash"
(if (hash-table? obj 'eqv)
"#hasheqv"
"#hasheq")))
(pp-list (hash-table-map obj cons) extra pp-expr #f depth
pair? car cdr pair-open pair-close)]
pair? car cdr pair-open pair-close
qd))]
[(and (box? obj) print-box?)
(let ([qd (to-quoted out qd "`")])
(out "#&")
(pr (unbox obj) extra pp-pair depth)])
(pr (unbox obj) extra pp-pair depth qd))])
(post-print pport obj)))))
;; Not possible to split obj across lines; so just write directly
(wr* pport obj depth display?))))
(wr* pport obj depth display? qd))))
(define (pp-expr expr extra depth
apair? acar acdr open close)
(if (and (read-macro? expr apair? acar acdr)
apair? acar acdr open close
qd)
(if (and (read-macro? expr apair? acar acdr qd)
(equal? open "(")
(not (and found (hash-table-get found (acdr expr) #f))))
(begin
@ -879,15 +937,18 @@
(pr (read-macro-body expr acar acdr)
extra
pp-expr
depth))
depth
(reader-adjust-qd (acar expr) qd)))
(let ((head (acar expr)))
(if (or (and (symbol? head)
(not (size-hook head display?)))
((pretty-print-remap-stylable) head))
(let ((proc (style head expr apair? acar acdr)))
(if proc
(let ([qd (to-quoted out qd "`")])
(proc expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd))
(if (and #f
;; Why this special case? Currently disabled.
(> (string-length
@ -897,62 +958,74 @@
((pretty-print-remap-stylable) head))))
max-call-head-width))
(pp-general expr extra #f #f #f pp-expr depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-list expr extra pp-expr #t depth
apair? acar acdr open close))))
apair? acar acdr open close
qd))))
(pp-list expr extra pp-expr #t depth
apair? acar acdr open close)))))
apair? acar acdr open close
qd)))))
(define (wr obj depth)
(wr* pport obj depth display?))
(define (wr obj depth qd)
(wr* pport obj depth display? qd))
;; (head item1
;; item2
;; item3)
(define (pp-call expr extra pp-item depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(out open)
(wr (acar expr) (dsub1 depth))
(wr (acar expr) (dsub1 depth) qd)
(let ([col (+ (ccol) 1)])
(pp-down close (acdr expr) col col extra pp-item #t #t depth
apair? acar acdr open close)))
apair? acar acdr open close
qd)))
;; (head item1 item2
;; item3
;; item4)
(define (pp-two-up expr extra pp-item depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(out open)
(let ([col (ccol)])
(wr (acar expr) (dsub1 depth))
(wr (acar expr) (dsub1 depth) qd)
(out " ")
(wr (acar (acdr expr)) (dsub1 depth))
(wr (acar (acdr expr)) (dsub1 depth) qd)
(pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
apair? acar acdr open close)))
apair? acar acdr open close
qd)))
;; (head item1
;; item2
;; item3)
(define (pp-one-up expr extra pp-item depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(out open)
(let ([col (ccol)])
(wr (acar expr) (dsub1 depth))
(wr (acar expr) (dsub1 depth) qd)
(pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
apair? acar acdr open close)))
apair? acar acdr open close
qd)))
;; (item1
;; item2
;; item3)
(define (pp-list l extra pp-item check? depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(out open)
(let ([col (ccol)])
(pp-down close l col col extra pp-item #f check? depth
apair? acar acdr open close)))
apair? acar acdr open close
qd)))
(define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(let loop ([l l] [icol col1] [check? check-first?])
(check-expr-found
l pport (and check? (apair? l))
@ -966,7 +1039,7 @@
(indent col2)
(out ".")
(indent col2)
(pr l extra pp-item depth)
(pr l extra pp-item depth qd)
(out closer))
(lambda ()
(cond
@ -974,7 +1047,7 @@
(let ([rest (acdr l)])
(let ([extra (if (null? rest) (+ extra 1) 0)])
(indent icol)
(pr (acar l) extra pp-item (dsub1 depth))
(pr (acar l) extra pp-item (dsub1 depth) qd)
(loop rest col2 check-rest?)))]
[(null? l)
(out closer)]
@ -982,11 +1055,12 @@
(indent col2)
(out ".")
(indent col2)
(pr l (+ extra 1) pp-item (dsub1 depth))
(pr l (+ extra 1) pp-item (dsub1 depth) qd)
(out closer)])))))
(define (pp-general expr extra named? pp-1 pp-2 pp-3 depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(define (tail1 rest col1 col3)
(if (and pp-1 (apair? rest))
@ -994,7 +1068,7 @@
(rest (acdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(indent col3)
(pr val1 extra pp-1 depth)
(pr val1 extra pp-1 depth qd)
(tail2 rest col1 col3))
(tail2 rest col1 col3)))
@ -1004,88 +1078,113 @@
(rest (acdr rest))
(extra (if (null? rest) (+ extra 1) 0)))
(indent col3)
(pr val1 extra pp-2 depth)
(pr val1 extra pp-2 depth qd)
(tail3 rest col1))
(tail3 rest col1)))
(define (tail3 rest col1)
(pp-down close rest col1 col1 extra pp-3 #f #t depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(let* ([head (acar expr)]
[rest (acdr expr)]
[col (ccol)])
(out open)
(wr head (dsub1 depth))
(wr head (dsub1 depth) qd)
(if (and named? (apair? rest))
(let* ((name (acar rest))
(rest (acdr rest)))
(out " ")
(wr name (dsub1 depth))
(wr name (dsub1 depth) qd)
(tail1 rest (+ col indent-general) (+ (ccol) 1)))
(tail1 rest (+ col indent-general) (+ (ccol) 1)))))
(define (pp-expr-list l extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-list l extra pp-expr #t depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-lambda expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-general expr extra #f pp-expr-list #f pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-if expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-general expr extra #f pp-expr #f pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-cond expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-list expr extra pp-expr-list #t depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-syntax-case expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-two-up expr extra pp-expr-list depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-module expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-two-up expr extra pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-make-object expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-one-up expr extra pp-expr-list depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-case expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-general expr extra #f pp-expr #f pp-expr-list depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-and expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-call expr extra pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-let expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(let* ((rest (acdr expr))
(named? (and (apair? rest) (symbol? (do-remap (acar rest))))))
(pp-general expr extra named? pp-expr-list #f pp-expr depth
apair? acar acdr open close)))
apair? acar acdr open close
qd)))
(define (pp-begin expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-general expr extra #f #f #f pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
(define (pp-do expr extra depth
apair? acar acdr open close)
apair? acar acdr open close
qd)
(pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth
apair? acar acdr open close))
apair? acar acdr open close
qd))
;; define formatting style (change these to suit your style)
@ -1155,16 +1254,33 @@
(else #f)))
(pr obj 0 pp-expr depth))
(pr obj 0 pp-expr depth qd))
(define (to-quoted out qd str)
(and qd
(if (zero? qd)
(begin
(out str)
(add1 qd))
qd)))
(define (to-unquoted out qd)
(and qd
(if (zero? qd)
qd
(begin
(out ",")
(to-unquoted out (sub1 qd))))))
;; ------------------------------------------------------------
;; This is where generic-write's body expressions start
((printing-port-print-line pport) #t 0 width)
(let ([qd (if print-as-qq? 0 #f)])
(let-values ([(l col p) (port-next-location pport)])
(if (and width (not (eq? width 'infinity)))
(pp* pport obj depth display?)
(wr* pport obj depth display?)))
(pp* pport obj depth display? qd)
(wr* pport obj depth display? qd))))
(let-values ([(l col p) (port-next-location pport)])
((printing-port-print-line pport) #f col width)))
@ -1183,16 +1299,26 @@
values]
[else raw-head]))
(define (read-macro? l pair? car cdr)
(define (read-macro? l pair? car cdr qd)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(and (pretty-print-abbreviate-read-macros)
(let ((head (do-remap (car l))) (tail (cdr l)))
(case head
((quote quasiquote unquote unquote-splicing syntax
((quote quasiquote syntax
quasisyntax unsyntax unsyntax-splicing)
(length1? tail))
((unquote unquote-splicing)
(and (not (equal? qd 1))
(length1? tail)))
(else #f)))))
(define (reader-adjust-qd v qd)
(and qd
(case (do-remap v)
[(quasiquote) (add1 qd)]
[(unquote unquote-splciing) (sub1 qd)]
[else qd])))
(define (read-macro-body l car cdr)
(car (cdr l)))

82
collects/scheme/private/define-struct.ss
View File

@ -39,6 +39,34 @@
"procedure (arity 0)"
proc)))))
(define-for-syntax (self-ctor-transformer orig stx)
(with-syntax ([orig orig])
(syntax-case stx ()
[(_ arg ...) (datum->syntax stx
(syntax-e (syntax (orig arg ...)))
stx
stx)]
[_ (syntax orig)])))
(define-values-for-syntax (make-self-ctor-struct-info)
(letrec-values ([(struct: make- ? ref set!)
(make-struct-type 'self-ctor-struct-info struct:struct-info
1 0 #f
(list (cons prop:procedure
(lambda (v stx)
(self-ctor-transformer (ref v 0) stx))))
(current-inspector) #f '(0))])
make-))
(define-values-for-syntax (make-self-ctor-checked-struct-info)
(letrec-values ([(struct: make- ? ref set!)
(make-struct-type 'self-ctor-checked-struct-info struct:checked-struct-info
1 0 #f
(list (cons prop:procedure
(lambda (v stx)
(self-ctor-transformer (ref v 0) stx))))
(current-inspector) #f '(0))])
make-))
(define-syntax-parameter struct-field-index
(lambda (stx)
(raise-syntax-error #f "allowed only within a structure type definition" stx)))
@ -92,15 +120,16 @@
stx
(if (null? alt) kw (car alt))))
(define (check-exprs orig-n ps)
(define (check-exprs orig-n ps what)
(let loop ([nps (cdr ps)][n orig-n])
(unless (zero? n)
(unless (and (pair? nps)
(not (keyword? (syntax-e (car nps)))))
(raise-syntax-error
#f
(format "expected ~a expression~a after keyword~a"
(format "expected ~a ~a~a after keyword~a"
orig-n
(or what "expression")
(if (= orig-n 1) "" "s")
(if (pair? nps)
", found a keyword"
@ -129,7 +158,7 @@
(loop (cdr ps) def-val auto? #t)]
#;
[(eq? #:default (syntax-e (car ps)))
(check-exprs 1 ps)
(check-exprs 1 ps #f)
(when def-val
(bad "multiple" (car ps) " for field"))
(loop (cddr ps) (cadr ps) auto? mutable?)]
@ -173,13 +202,14 @@
(#:props . ())
(#:mutable . #f)
(#:guard . #f)
(#:constructor-name . #f)
(#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))]
[nongen? #f])
(cond
[(null? p) config]
[(eq? '#:super (syntax-e (car p)))
(check-exprs 1 p)
(check-exprs 1 p #f)
(when (lookup config '#:super)
(bad "multiple" (car p) "s"))
(when super-id
@ -196,7 +226,7 @@
[(memq (syntax-e (car p))
'(#:guard #:auto-value))
(let ([key (syntax-e (car p))])
(check-exprs 1 p)
(check-exprs 1 p #f)
(when (lookup config key)
(bad "multiple" (car p) "s"))
(when (and nongen?
@ -206,7 +236,7 @@
(extend-config config key (cadr p))
nongen?))]
[(eq? '#:property (syntax-e (car p)))
(check-exprs 2 p)
(check-exprs 2 p #f)
(when nongen?
(bad "cannot use" (car p) " for prefab structure type"))
(loop (cdddr p)
@ -216,7 +246,7 @@
(lookup config '#:props)))
nongen?)]
[(eq? '#:inspector (syntax-e (car p)))
(check-exprs 1 p)
(check-exprs 1 p #f)
(when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p)))
(loop (cddr p)
@ -229,6 +259,15 @@
(loop (cdr p)
(extend-config config '#:inspector #'#f)
nongen?)]
[(eq? '#:constructor-name (syntax-e (car p)))
(check-exprs 1 p "identifier")
(when (lookup config '#:constructor-name)
(bad "multiple #:constructor-name keys" (car p)))
(unless (identifier? (cadr p))
(bad "need an identifier after #:constructor-name" (cadr p)))
(loop (cddr p)
(extend-config config '#:constructor-name (cadr p))
nongen?)]
[(eq? '#:prefab (syntax-e (car p)))
(when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p)))
@ -321,7 +360,7 @@
(car field-stxes))]
[else
(loop (cdr fields) (cdr field-stxes) #f)]))])
(let-values ([(inspector super-expr props auto-val guard mutable?
(let*-values ([(inspector super-expr props auto-val guard ctor-name mutable?
omit-define-values? omit-define-syntaxes?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector)
@ -329,9 +368,12 @@
(lookup config '#:props)
(lookup config '#:auto-value)
(lookup config '#:guard)
(lookup config '#:constructor-name)
(lookup config '#:mutable)
(lookup config '#:omit-define-values)
(lookup config '#:omit-define-syntaxes)))])
(lookup config '#:omit-define-syntaxes)))]
[(self-ctor?)
(and ctor-name (bound-identifier=? id ctor-name))])
(when mutable?
(for-each (lambda (f f-stx)
(when (field-mutable? f)
@ -342,7 +384,11 @@
f-stx)))
fields field-stxes))
(let ([struct: (build-name id "struct:" id)]
[make- (build-name id "make-" id)]
[make- (if ctor-name
(if self-ctor?
(car (generate-temporaries (list id)))
ctor-name)
(build-name id "make-" id))]
[? (build-name id id "?")]
[sels (map (lambda (f)
(build-name id ; (field-id f)
@ -407,7 +453,8 @@
[(not (or mutable? (field-mutable? (car fields))))
(cons i (loop (add1 i) (cdr fields)))]
[else (loop (add1 i) (cdr fields))]))
#,guard))])
#,guard
'#,ctor-name))])
(values struct: make- ?
#,@(let loop ([i 0][fields fields])
(if (null? fields)
@ -429,8 +476,12 @@
#`(quote-syntax #,(prune sel))
sel)))]
[mk-info (if super-info-checked?
#'make-checked-struct-info
#'make-struct-info)])
(if self-ctor?
#'make-self-ctor-checked-struct-info
#'make-checked-struct-info)
(if self-ctor?
#'make-self-ctor-struct-info
#'make-struct-info))])
(quasisyntax/loc stx
(define-syntaxes (#,id)
(#,mk-info
@ -465,7 +516,10 @@
(protect super-id)
(if super-expr
#f
#t)))))))))])
#t))))
#,@(if self-ctor?
(list #`(quote-syntax #,make-))
null))))))])
(let ([result
(cond
[(and (not omit-define-values?) (not omit-define-syntaxes?))

9
collects/scribblings/mzc/exe-api.scrbl
View File

@ -46,6 +46,9 @@ parameter is true.
(listof (list/c (or/c symbol? (one-of/c #t #f))
module-path?))
null]
[#:configure-via-first-module? config-via-first?
any/c
#f]
[#:literal-files literal-files
(listof path-string?)
null]
@ -119,6 +122,12 @@ bindings; use compiled expressions to bootstrap the namespace. If
included in the executable. The @scheme[#:literal-expression]
(singular) argument is for backward compatibility.
If the @scheme[#:configure-via-first-module?] argument is specified as
true, then the language of the first module in @scheme[mod-list] is
used to configure the run-time environment before the expressions
added by @scheme[#:literal-files] and @scheme[#:literal-expressions]
are evaluated.
The @scheme[#:cmdline] argument @scheme[cmdline] contains command-line
strings that are prefixed onto any actual command-line arguments that
are provided to the embedding executable. A command-line argument that

35
collects/scribblings/reference/custom-write.scrbl
View File

@ -6,19 +6,22 @@
@defthing[prop:custom-write struct-type-property?]{
Associates a procedure to a structure type to used by the default
printer to @scheme[display] or @scheme[write] (or @scheme[print])
printer to @scheme[display], @scheme[write], or @scheme[print]
instances of the structure type.
@moreref["structprops"]{structure type properties}
The procedure for a @scheme[prop:custom-write] value takes three
arguments: the structure to be printed, the target port, and a boolean
that is @scheme[#t] for @scheme[write] mode and @scheme[#f] for
@scheme[display] mode. The procedure should print the value to the
given port using @scheme[write], @scheme[display], @scheme[fprintf],
arguments: the structure to be printed, the target port, and an
argument that is @scheme[#t] for @scheme[write] mode, @scheme[#f] for
@scheme[display] mode, or an exact non-negative integer representing
the current @scheme[quasiquote] depth for @scheme[print] mode. The
procedure should print the value to the given port using
@scheme[write], @scheme[display], @scheme[print], @scheme[fprintf],
@scheme[write-special], etc.
The write handler, display handler, and print handler are specially
The @tech{port write handler}, @tech{port display handler},
and @tech{print handler} are specially
configured for a port given to a custom-write procedure. Printing to
the port through @scheme[display], @scheme[write], or @scheme[print]
prints a value recursively with sharing annotations. To avoid a
@ -41,21 +44,25 @@ limited width).
The following example definition of a @scheme[tuple] type includes
custom-write procedures that print the tuple's list content using
angle brackets in @scheme[write] mode and no brackets in
angle brackets in @scheme[write] and @scheme[print] mode and no brackets in
@scheme[display] mode. Elements of the tuple are printed recursively,
so that graph and cycle structure can be represented.
@defexamples[
(define (tuple-print tuple port write?)
(when write? (write-string "<" port))
(let ([l (tuple-ref tuple 0)])
(define (tuple-print tuple port mode)
(when mode (write-string "<" port))
(let ([l (tuple-ref tuple 0)]
[recur (case mode
[(#t) write]
[(#f) display]
[else (lambda (p port) (print p port mode))])])
(unless (zero? (vector-length l))
((if write? write display) (vector-ref l 0) port)
(recur (vector-ref l 0) port)
(for-each (lambda (e)
(write-string ", " port)
((if write? write display) e port))
(recur e port))
(cdr (vector->list l)))))
(when write? (write-string ">" port)))
(when mode (write-string ">" port)))
(define-values (s:tuple make-tuple tuple? tuple-ref tuple-set!)
(make-struct-type 'tuple #f 1 0 #f
@ -63,6 +70,8 @@ so that graph and cycle structure can be represented.
(display (make-tuple #(1 2 "a")))
(print (make-tuple #(1 2 "a")))
(let ([t (make-tuple (vector 1 2 "a"))])
(vector-set! (tuple-ref t 0) 0 t)
(write t))

14
collects/scribblings/reference/define-struct.scrbl
View File

@ -24,6 +24,7 @@
(code:line #:property prop-expr val-exr)
(code:line #:transparent)
(code:line #:prefab)
(code:line #:constructor-name constructor-id)
#:omit-define-syntaxes
#:omit-define-values]
[field-option #:mutable
@ -41,7 +42,8 @@ to @math{4+2n} names:
@item{@schemeidfont{struct:}@scheme[id], a @deftech{structure type
descriptor} value that represents the @tech{structure type}.}
@item{@schemeidfont{make-}@scheme[id], a @deftech{constructor}
@item{@scheme[constructor-id] (which defaults to
@schemeidfont{make-}@scheme[id]), a @deftech{constructor}
procedure that takes @math{m} arguments and returns a new
instance of the @tech{structure type}, where @math{m} is the
number of @scheme[field]s that do not include an
@ -72,7 +74,10 @@ to @math{4+2n} names:
is used to define subtypes, and it also works with the
@scheme[shared] and @scheme[match] forms. For detailed
information about the binding of @scheme[id], see
@secref["structinfo"].}
@secref["structinfo"].
The @scheme[constructor-id] and @scheme[id] can be the same, in
which case @scheme[id] performs both roles.}
]
@ -119,8 +124,9 @@ must also be a @tech{prefab} structure type.
If the @scheme[#:omit-define-syntaxes] option is supplied, then
@scheme[id] is not bound as a transformer. If the
@scheme[#:omit-define-values] option is supplied, then none of the
usual variables are bound. If both are supplied, then the
@scheme[define-struct] form is equivalent to @scheme[(begin)].
usual variables are bound, but @scheme[id] is bound. If both are
supplied, then the @scheme[define-struct] form is equivalent to
@scheme[(begin)].
If @scheme[#:auto] is supplied as a @scheme[field-option], then the
@tech{constructor} procedure for the structure type does not accept an

24
collects/scribblings/reference/module-reflect.scrbl
View File

@ -305,11 +305,11 @@ module's declaration though the @indexed-scheme['module-language]
If no information is available for the module, the result is
@scheme[#f]. Otherwise, the result is @scheme[(vector _mp _name _val)]
such that @scheme[((dynamic-require _mp _name) _val)] should return
function that takes a single argument. The function's argument is a
key for reflected information, and the result is a value associated
with that key. Acceptable keys and the interpretation of results is
up to external tools, such as DrScheme. If no information is
available for a given key, the result should be @scheme[#f].
function that takes two arguments. The function's arguments are a key
for reflected information and a default value. Acceptable keys and
the interpretation of results is up to external tools, such as
DrScheme. If no information is available for a given key, the result
should be the given default value.
See also @scheme[module->language-info].}
@ -367,14 +367,18 @@ more than the namespace's @tech{base phase}.}
@defproc[(module->language-info
[mod (or/c module-path? path? resolved-module-path?)])
[mod (or/c module-path? path? resolved-module-path?)]
[load? any/c #f])
(or/c #f (vector/c module-path? symbol? any/c))]{
Returns information intended to reflect the ``language'' of the
implementation of @scheme[mod], which must be declared (but not
necessarily @tech{instantiate}d or @tech{visit}ed) in the current
namespace. The information is the same as would have been returned by
@scheme[module-compiled-language-info] applied to the module's
implementation of @scheme[mod]. If @scheme[load?] is @scheme[#f], the
module named by @scheme[mod] must be declared (but not necessarily
@tech{instantiate}d or @tech{visit}ed) in the current namespace;
otherwise, @scheme[mod] may be loaded (as for @scheme[dynamic-require]
and other functions). The information returned by
@scheme[module->language-info] is the same as would have been returned
by @scheme[module-compiled-language-info] applied to the module's
implementation as compiled code.}

24
collects/scribblings/reference/pretty-print.scrbl
View File

@ -9,19 +9,20 @@
@defproc[(pretty-print [v any/c] [port output-port? (current-output-port)])
void?]{
Pretty-prints the value @scheme[v] using the same printed form as
@scheme[write], but with newlines and whitespace inserted to avoid
lines longer than @scheme[(pretty-print-columns)], as controlled by
@scheme[(pretty-print-current-style-table)]. The printed form ends in
a newline, unless the @scheme[pretty-print-columns] parameter is set
to @scheme['infinity].
Pretty-prints the value @scheme[v] using the same printed form as the
default @scheme[print] mode, but with newlines and whitespace inserted
to avoid lines longer than @scheme[(pretty-print-columns)], as
controlled by @scheme[(pretty-print-current-style-table)]. The printed
form ends in a newline, unless the @scheme[pretty-print-columns]
parameter is set to @scheme['infinity].
In addition to the parameters defined in this section,
@scheme[pretty-print] conforms to the @scheme[print-graph],
@scheme[print-struct], @scheme[print-hash-table],
@scheme[print-vector-length], and @scheme[print-box] parameters.
@scheme[print-vector-length], @scheme[print-box], and
@scheme[print-as-quasiquote] parameters.
The pretty printer also detects structures that have the
The pretty printer detects structures that have the
@scheme[prop:custom-write] property and it calls the corresponding
custom-write procedure. The custom-write procedure can check the
parameter @scheme[pretty-printing] to cooperate with the
@ -37,12 +38,17 @@ called appropriately). Use
@scheme[make-tentative-pretty-print-output-port] to obtain a port for
tentative recursive prints (e.g., to check the length of the output).}
@defproc[(pretty-write [v any/c] [port output-port? (current-output-port)])
void?]{
Same as @scheme[pretty-print], but @scheme[v] is printed like
@scheme[write] instead of like @scheme[print].}
@defproc[(pretty-display [v any/c][port output-port? (current-output-port)])
void?]{
Same as @scheme[pretty-print], but @scheme[v] is printed like
@scheme[display] instead of like @scheme[write].}
@scheme[display] instead of like @scheme[print].}
@defproc[(pretty-format [v any/c][columns exact-nonnegative-integer? (pretty-print-columns)])

111
collects/scribblings/reference/printer.scrbl
View File

@ -9,7 +9,11 @@ using @scheme[read] on the output produces a value that is
@scheme[equal?] to the printed value---when the printed is used in
@scheme[write]. When the printer is used in @scheme[display] mode, the
printing of strings, byte strings, characters, and symbols changes to
render the character/byte content directly to the output port.
render the character/byte content directly to the output port. The
printer's @scheme[print] mode is similar to @scheme[write], but it is
sensitive to the @scheme[print-as-quasiquote] parameter for printing
values in a way that @scheme[read] plus @scheme[eval] on the output
can be @scheme[equal?] to the printed value.
When the @scheme[print-graph] parameter is set to @scheme[#t], then
the printer first scans an object to detect cycles. The scan traverses
@ -63,10 +67,18 @@ Symbols @scheme[display] without escaping or quoting special
characters. That is, the display form of a symbol is the same as the
display form of @scheme[symbol->string] applied to the symbol.
Symbols @scheme[print] the same as they @scheme[write], unless
@scheme[print-as-quasiquote] is set to @scheme[#t] and the current
@scheme[quasiquote] depth is @scheme[0]. In that case, the symbol's
@scheme[print]ed form is prefixed with @litchar{'}. If the current
@scheme[quasiquote] depth is @scheme[1], and if the symbol is
@scheme['unquote] or @scheme[quasiquote], then the @scheme[print]ed
form is prefixed with @litchar{,'}.
@section{Printing Numbers}
A number prints the same way in @scheme[write] and @scheme[display]
modes.
A number prints the same way in @scheme[write], @scheme[display], and
@scheme[print] modes.
A @tech{complex number} that is not a @tech{real number} always prints
as @nonterm{m}@litchar{+}@nonterm{n}@litchar{i}, where @nonterm{m} and
@ -94,14 +106,15 @@ printed form of its exact negation.
@section{Printing Booleans}
The constant @scheme[#t] prints as @litchar{#t}, and the constant
@scheme[#f] prints as @litchar{#f} in both @scheme[display] and
@scheme[write] modes.
@scheme[#f] prints as @litchar{#f} in all modes (@scheme[display],
@scheme[write], and @scheme[print]).
@section{Printing Pairs and Lists}
@section[#:tag "print-pairs"]{Printing Pairs and Lists}
A pair prints starting with @litchar{(} followed by the printed form
of its @scheme[car]. The rest of the printed form depends on the
@scheme[cdr]:
In @scheme[write] and @scheme[display] modes, an empty list prints as
@litchar{()}. A pair normally prints starting with @litchar{(}
followed by the printed form of its @scheme[car]. The rest of the
printed form depends on the @scheme[cdr]:
@itemize[
@ -116,9 +129,33 @@ of its @scheme[car]. The rest of the printed form depends on the
]
If @scheme[print-reader-abbreviations] is set to @scheme[#t], then
pair printing is adjusted in the case of a pair that starts a
two-element list whose first element is @scheme[quote],
@scheme['quasiquote], @scheme['unquote], @scheme['unquote-splicing],
@scheme['syntax], @scheme['quasisyntax], @scheme['unsyntax],
@scheme['unsyntax-splicing]. In that case, the pair is printed with
the corresponding reader syntax: @litchar{'}, @litchar{`},
@litchar{,}, @litchar[",@"], @litchar{#'}, @litchar{#`}, @litchar{#,},
or @litchar["#,@"], respectively. After the reader syntax, the second
element of the list is printed. When the list is a tail of an
enclosing list, the tail is printed after a @litchar{.} in the
enclosing list (after which the reader abbreviations work), instead of
including the tail as two elements of the enclosing list.
The printed form of a pair is the same in both @scheme[write] and
@scheme[display] modes, except as the printed form of the pair's
@scheme[car]and @scheme[cdr] vary with the mode.
@scheme[car] and @scheme[cdr] vary with the mode. The @scheme[print]
form is also the same is @scheme[print-as-quasiquote] is @scheme[#f].
When @scheme[print-as-quasiquote] is @scheme[#t] and the current
@scheme[quasiquote] depth is @scheme[0], then the empty list prints as
@litchar{'()} and a pair's output is prefixed with @litchar{`}; the
pair's content is printed at @scheme[quasiquote] depth is
@scheme[1]. In addition, when @scheme['quasiquote], @scheme['unquote],
or @scheme['unquote-splicing] appears as the first element of a
two-element list, the @scheme[quasiquote] depth is adjusted
appropriately for printing the second element of the list.
By default, mutable pairs (as created with @scheme[mcons]) print the
same as pairs, except that @litchar["{"] and @litchar["}"] are used
@ -136,7 +173,7 @@ set to @scheme[#f], then mutable pairs print using @litchar{(} and
All strings @scheme[display] as their literal character sequences.
The @scheme[write] form of a string starts with @litchar{"} and ends
The @scheme[write] or @scheme[print] form of a string starts with @litchar{"} and ends
with another @litchar{"}. Between the @litchar{"}s, each character is
represented. Each graphic or blank character is represented as itself,
with two exceptions: @litchar{"} is printed as @litchar{\"}, and
@ -154,7 +191,7 @@ All byte strings @scheme[display] as their literal byte sequence; this
byte sequence may not be a valid UTF-8 encoding, so it may not
correspond to a sequence of characters.
The @scheme[write] form a byte string starts with @litchar{#"} and
The @scheme[write] or @scheme[print] form a byte string starts with @litchar{#"} and
ends with another @litchar{"}. Between the @litchar{"}s, each byte is
written using the corresponding ASCII decoding if the byte is between
0 and 127 and the character is graphic or blank (according to
@ -171,7 +208,13 @@ followed by the printed form of @scheme[vector->list] applied to the
vector. In @scheme[write] mode, the printed form is the same, except
that when the @scheme[print-vector-length] parameter is @scheme[#t], a
decimal integer is printed after the @litchar{#}, and a repeated last
element is printed only once..
element is printed only once.
Vectors @scheme[print] the same as they @scheme[write], unless
@scheme[print-as-quasiquote] is set to @scheme[#t] and the current
@scheme[quasiquote] depth is @scheme[0]. In that case, the vector's
@scheme[print]ed form is prefixed with @litchar{`}, and its content is
printed with @scheme[quasiquote] depth @scheme[1].
@section[#:tag "print-structure"]{Printing Structures}
@ -185,7 +228,13 @@ for which the structure is an instance:
@item{If the structure type is a @techlink{prefab} structure type,
then it prints using @litchar{#s(} followed by the @tech{prefab}
structure type key, then the printed form each field in the
structure, and then @litchar{)}.}
structure, and then @litchar{)}.
In @scheme[print] mode when @scheme[print-as-quasiquote] is set
to @scheme[#t] and the current @scheme[quasiquote] depth is
@scheme[0], the structure's @scheme[print]ed form is prefixed
with @litchar{`} and its content is printed with
@scheme[quasiquote] depth @scheme[1].}
@item{If the structure has a @scheme[prop:custom-write] property
value, then the associated procedure is used to print the
@ -193,7 +242,18 @@ for which the structure is an instance:
@item{If the structure type is transparent, or if any ancestor is
transparent, then the structure prints as the vector produced
by @scheme[struct->vector].}
by @scheme[struct->vector] in @scheme[display] mode, in
@scheme[write] mode, or in @scheme[print] mode when
@scheme[print-as-quasiquote] is set to @scheme[#f].
In @scheme[print] mode with @scheme[print-as-quasiquote] as
@scheme[#t], then the printed form is prefixed with as many
@litchar{,}s as the current @scheme[quasiquote] depth. Instead
of printing as a vector, the structure content is printed as a
list, where the first element is the list is the structure's
type name (as determined by @scheme[object-name]) printed in
@scheme[write] mode, while the remaining elements are
@scheme[print]ed at @scheme[quasiquote] depth @scheme[0].}
@item{For any other structure type, the structure prints as an
unreadable value; see @secref["print-unreadable"] for more
@ -217,6 +277,14 @@ additional space if the key--value pair is not the last to be printed.
After all key-value pairs, the printed form completes with
@litchar{)}.
In @scheme[print] mode when @scheme[print-as-quasiquote] is
@scheme[#t] and the current quasiquote depth is @scheme[0], then the
printed form is prefixed with @litchar{`} and the hash table's content
is printed at @scheme[quasiquote] depth @scheme[1]. In the printed
form, keys may be printed with @litchar{,} escapes, even though
@scheme[quasiquote] does not support @scheme[unquote] escapes in the
key position.
When the @scheme[print-hash-table] parameter is set to @scheme[#f], a
hash table prints (un@scheme[read]ably) as @litchar{#<hash>}.
@ -224,6 +292,10 @@ hash table prints (un@scheme[read]ably) as @litchar{#<hash>}.
When the @scheme[print-box] parameter is set to @scheme[#t],
a box prints as @litchar{#&} followed by the printed form of its content.
In @scheme[print] mode when @scheme[print-as-quasiquote] is
@scheme[#t] and the current quasiquote depth is @scheme[0], then the
printed form is prefixed with @litchar{`} and the box's content
is printed at @scheme[quasiquote] depth @scheme[1].
When the @scheme[print-box] parameter is set to @scheme[#f], a box
prints (un@scheme[read]ably) as @litchar{#<box>}.
@ -231,7 +303,7 @@ prints (un@scheme[read]ably) as @litchar{#<box>}.
@section{Printing Characters}
Characters with the special names described in
@secref["parse-character"] @scheme[write] using the same name.
@secref["parse-character"] @scheme[write] and @scheme[print] using the same name.
(Some characters have multiple names; the @scheme[#\newline] and
@scheme[#\nul] names are used instead of @scheme[#\linefeed] and
@scheme[#\null]). Other graphic characters (according to
@ -246,15 +318,16 @@ character).
@section{Printing Keywords}
Keywords @scheme[write] and @scheme[display] the same as symbols,
except (see @secref["print-symbol"]) with a leading @litchar{#:},
Keywords @scheme[write], @scheme[print], and @scheme[display] the same as symbols,
except (see @secref["print-symbol"]) with a leading @litchar{#:} (after any
@litchar{'} prefix added in @scheme[print] mode),
and without special handing for an initial @litchar{#} or when the
printed form would matches a number or a delimited @litchar{.} (since
@litchar{#:} distinguishes the keyword).
@section{Printing Regular Expressions}
Regexp values in both @scheme[write] and @scheme[display] mode print
Regexp values in all modes (@scheme[write], @scheme[display], and @scheme[print])
starting with @litchar{#px} (for @scheme[pregexp]-based regexps) or
@litchar{#rx} (for @scheme[regexp]-based regexps) followed by the
@scheme[write] form of the regexp's source string or byte string.

46
collects/scribblings/reference/startup.scrbl
View File

@ -62,15 +62,22 @@ command line does not specify a @scheme[require] flag
@Flag{u}/@DFlag{require-script}) before any @scheme[eval],
@scheme[load], or read-eval-print-loop flag (@Flag{e}/@DFlag{eval},
@Flag{f}/@DFlag{load}, @Flag{r}/@DFlag{script}, @Flag{m}/@DFlag{main},
or @Flag{i}/@DFlag{repl}). The
initialization library can be changed with the @Flag{I}
@tech{configuration option}.
or @Flag{i}/@DFlag{repl}). The initialization library can be changed
with the @Flag{I} @tech{configuration option}. The
@scheme['configure-runtime] property of the initialization library's
language is used before the library is instantiated; see
@secref["configure-runtime"].
After potentially loading the initialization module, expression
@scheme[eval]s, files @scheme[load]s, and module @scheme[require]s are
executed in the order that they are provided on the command line. If
any raises an uncaught exception, then the remaining @scheme[eval]s,
@scheme[load]s, and @scheme[require]s are skipped.
@scheme[load]s, and @scheme[require]s are skipped. If the first
@scheme[require] precedes any @scheme[eval] or @scheme[load] so that
the initialization library is skipped, then the
@scheme['configure-runtime] property of the required module's library
language is used before the module is instantiated; see
@secref["configure-runtime"].
After running all command-line expressions, files, and modules,
MzScheme or MrEd then starts a read-eval-print loop for interactive
@ -362,3 +369,34 @@ of the collapsed set.
Extra arguments following the last option are available from the
@indexed-scheme[current-command-line-arguments] parameter.
@; ----------------------------------------------------------------------
@section[#:tag "configure-runtime"]{Language Run-Time Configuration}
When a module is implemented using @hash-lang{}, the language after
@hash-lang{} can specify configuration actions to perform when a
module using the language is the main module of a program. The
language specifies run-time configuration by
@itemlist[
@item{attaching a @scheme['module-language] @tech{syntax property} to
the module as read from its source (see @scheme[module] and
@scheme[module-compiled-language-info]);}
@item{having the function indicated by the @scheme['module-language]
@tech{syntax property} recognize the
@scheme['configure-runtime] key, for which it returns another
vector: @scheme[(vector _mp _name _val)] where @scheme[_mp] is
a @tech{module path}, @scheme[_name] is a symbol, and
@scheme[_val] is an arbitrary value; and}
@item{having the function called as @scheme[((dynamic-require _mp
_name) _val)] configure the run-time environment, typically by
setting parameters such as @scheme[current-print].}
]
The @schememodname[scheme/base] and @schememodname[scheme] languages
do not currently specify a run-time configuration action.

7
collects/scribblings/reference/struct.scrbl
View File

@ -99,7 +99,8 @@ override the default @scheme[equal?] definition through the
#f]
[immutables (listof exact-nonnegative-integer?)
null]
[guard (or/c procedure? #f) #f])
[guard (or/c procedure? #f) #f]
[constructor-name (or/c symbol? #f) #f])
(values struct-type?
struct-constructor-procedure?
struct-predicate-procedure?
@ -169,6 +170,10 @@ values produced by the subtype's guard procedure become the first
@math{n} arguments to @scheme[guard]. When @scheme[inspector] is
@scheme['prefab], then @scheme[guard] must be @scheme[#f].
If @scheme[constructor-name] is not @scheme[#f], it is used as the
name of the generated @tech{constructor} procedure as returned by
@scheme[object-name] or in the printed form of the constructor value.
The result of @scheme[make-struct-type] is five values:
@itemize[

21
collects/scribblings/reference/stx-trans.scrbl
View File

@ -67,18 +67,25 @@ A @tech{structure type property} to identify structure types that act
as @tech{assignment transformers} like the ones created by
@scheme[make-set!-transformer].
The property value must be an exact integer or procedure of one
argument. In the former case, the integer designates a field within
The property value must be an exact integer or procedure of one or two
arguments. In the former case, the integer designates a field within
the structure that should contain a procedure; the integer must be
between @scheme[0] (inclusive) and the number of non-automatic fields
in the structure type (exclusive, not counting supertype fields), and
the designated field must also be specified as immutable.
If the property value is an procedure, then the procedure serves as a
@tech{syntax transformer} and for @scheme[set!] transformations. If
the property value is an integer, the target identifier is extracted
from the structure instance; if the field value is not a procedure of
one argument, then a procedure that always calls
If the property value is an procedure of one argument, then the
procedure serves as a @tech{syntax transformer} and for @scheme[set!]
transformations. If the property value is a procedure of two
arguments, then the first argument is the structure whose type has
@scheme[prop:set!-transformer] property, and the second argument is a
syntax object as for a @tech{syntax transformer} and for @scheme[set!]
transformations; @scheme[set!-transformer-procedure] applied to the
structure produces a new function that accepts just the syntax object
and call the procedure associated through the property. Finally, if the
property value is an integer, the target identifier is extracted from
the structure instance; if the field value is not a procedure of one
argument, then a procedure that always calls
@scheme[raise-syntax-error] is used, instead.
If a value has both the @scheme[prop:set!-transformer] and

54
collects/scribblings/reference/write.scrbl
View File

@ -43,7 +43,8 @@ printer. In particular, note that @scheme[display] may require memory
proportional to the depth of the value being printed, due to the
initial cycle check.}
@defproc[(print [datum any/c][out output-port? (current-output-port)])
@defproc[(print [datum any/c][out output-port? (current-output-port)]
[exact-nonnegative-integer? qq-depth 0])
void?]{
Writes @scheme[datum] to @scheme[out], normally the same way as
@ -52,12 +53,18 @@ Writes @scheme[datum] to @scheme[out], normally the same way as
the handler specified by @scheme[global-port-print-handler] is called;
the default handler uses the default printer in @scheme[write] mode.
The optional @scheme[qq-depth] argument adjust printing when the
@scheme[print-as-quasiquote] parameter is set to @scheme[#t]. In that
case, @scheme[qq-depth] specifies the starting @scheme[quasiquote]
depth for printing @scheme[datum].
The rationale for providing @scheme[print] is that @scheme[display]
and @scheme[write] both have relatively standard output conventions,
and this standardization restricts the ways that an environment can
change the behavior of these procedures. No output conventions should
be assumed for @scheme[print], so that environments are free to modify
the actual output generated by @scheme[print] in any way.}
and @scheme[write] both have specific output conventions, and those
conventions restrict the ways that an environment can change the
behavior of @scheme[display] and @scheme[write] procedures. No output
conventions should be assumed for @scheme[print], so that environments
are free to modify the actual output generated by @scheme[print] in
any way.}
@defproc[(fprintf [out output-port?][form string?][v any/c] ...) void?]{
@ -192,6 +199,20 @@ A parameter that controls printing vectors; defaults to
A parameter that controls printing hash tables; defaults to
@scheme[#f]. See @secref["print-hashtable"] for more information.}
@defboolparam[print-reader-abbreviations on?]{
A parameter that controls printing of two-element lists that start
with @scheme[quote], @scheme['quasiquote], @scheme['unquote],
@scheme['unquote-splicing], @scheme['syntax], @scheme['quasisyntax],
@scheme['unsyntax], or @scheme['unsyntax-splicing]; defaults to
@scheme[#f]. See @secref["print-pairs"] for more information.}
@defboolparam[print-as-quasiquote on?]{
A parameter that controls printing in @scheme[print] mode (as opposed
to @scheme[write] or @scheme[display]); defaults to @scheme[#f]. See
@secref["printing"] for more information.}
@defboolparam[print-honu on?]{
A parameter that controls printing values in an alternate syntax. See
@ -230,7 +251,7 @@ it is not @scheme[#f], otherwise the path is left relative).}
[proc (any/c output-port? . -> . any)])
void?])]{}
@defproc*[([(port-print-handler [out output-port?]) (any/c output-port? . -> . any)]
@defproc*[([(port-print-handler [out output-port?]) ((any/c output-port?) (exact-nonnegative-integer?) . ->* . any)]
[(port-print-handler [out output-port?]
[proc (any/c output-port? . -> . any)])
void?])]{
@ -239,20 +260,33 @@ Gets or sets the @deftech{port write handler}, @deftech{port display
handler}, or @deftech{port print handler} for @scheme[out]. This
handler is call to output to the port when @scheme[write],
@scheme[display], or @scheme[print] (respectively) is applied to the
port. Each handler takes a two arguments: the value to be printed and
port. Each handler must accept two arguments: the value to be printed and
the destination port. The handler's return value is ignored.
A @tech{port print handler} optionally accepts a third argument, which
corresponds to the optional third argument to @scheme[print]; if a
procedure given to @scheme[port-print-handler] does not accept a third
argument, it is wrapped with a procedure that discards the optional
third argument.
The default port display and write handlers print Scheme expressions
with Scheme's built-in printer (see @secref["printing"]). The
default print handler calls the global port print handler (the value
of the @scheme[global-port-print-handler] parameter); the default
global port print handler is the same as the default write handler.}
@defparam[global-port-print-handler proc (any/c output-port? . -> . any)]{
@defproc*[([(global-port-print-handler) ((any/c output-port?) (exact-nonnegative-integer?) . ->* . any)]
[(global-port-print-handler [proc (any/c output-port? . -> . any)]) void?])]{
A parameter that determines @deftech{global port print handler},
which is called by the default port print handler (see
@scheme[port-print-handler]) to @scheme[print] values into a port.
The default value uses the built-in printer (see
@secref["printing"]) in @scheme[write] mode.}
@secref["printing"]) in @scheme[print] mode.
A @tech{global port print handler} optionally accepts a third
argument, which corresponds to the optional third argument to
@scheme[print]. If a procedure given to
@scheme[global-port-print-handler] does not accept a third argument,
it is wrapped with a procedure that discards the optional third
argument.}

2
collects/tests/future/random-future.ss
View File

@ -182,7 +182,7 @@ Errors/exceptions and other kinds of control?
(gen-exp))]))
(define-namespace-anchor ns-here)
(let ([seed 595933061 #;(+ 1 (random (expt 2 30)))])
(let ([seed (+ 1 (random (expt 2 30)))])
(printf "DrDr Ignore! random-seed ~s\n" seed)
(random-seed seed))

2
collects/tests/mzscheme/file.ss
View File

@ -707,7 +707,7 @@
(test "hello\"hello\"" get-output-string sp)
(arity-test (port-display-handler sp) 2 2)
(arity-test (port-write-handler sp) 2 2)
(arity-test (port-print-handler sp) 2 2)
(arity-test (port-print-handler sp) 2 3)
(err/rt-test ((port-display-handler sp) 8 8))
(err/rt-test ((port-write-handler sp) 8 8))
(err/rt-test ((port-print-handler sp) 8 8))

2
collects/tests/mzscheme/struct.ss
View File

@ -16,7 +16,7 @@
(test #f struct-type-property? 5)
(let-values ([(type make pred sel set) (make-struct-type 'a #f 2 1 'un (list (cons prop:p 87)) (make-inspector insp1))]
[(typex makex predx selx setx) (make-struct-type 'ax #f 0 5 #f null (make-inspector insp2))])
(arity-test make-struct-type 4 10)
(arity-test make-struct-type 4 11)
(test 5 primitive-result-arity make-struct-type)
(test #t struct-type? type)
(test #t procedure? make)

55
src/mzscheme/cmdline.inc
View File

@ -166,16 +166,58 @@ typedef struct {
typedef void (*Repl_Proc)(Scheme_Env *);
static void configure_environment(Scheme_Object *mod)
{
Scheme_Object *mli, *dyreq, *a[3], *gi, *v;
mli = scheme_builtin_value("module->language-info");
a[0] = mod;
a[1] = scheme_make_true();
v = scheme_apply(mli, 2, a);
if (SCHEME_VECTORP(v)) {
dyreq = scheme_builtin_value("dynamic-require");
a[0] = SCHEME_VEC_ELS(v)[0];
a[1] = SCHEME_VEC_ELS(v)[1];
gi = scheme_apply(dyreq, 2, a);
a[0] = SCHEME_VEC_ELS(v)[2];
gi = scheme_apply(gi, 1, a);
a[0] = scheme_intern_symbol("configure-runtime");
a[1] = scheme_make_false();
v = scheme_apply(gi, 2, a);
if (!SAME_OBJ(v, scheme_make_false())) {
if (SCHEME_VECTORP(v) && SCHEME_VEC_SIZE(v) == 3) {
a[0] = SCHEME_VEC_ELS(v)[0];
a[1] = SCHEME_VEC_ELS(v)[1];
a[2] = SCHEME_VEC_ELS(v)[2];
v = scheme_apply(dyreq, 2, a);
a[0] = a[2];
scheme_apply_multi(v, 1, a);
} else {
a[0] = v;
scheme_wrong_type("current-print setup", "vector of three values",
-1, 0, a);
}
}
}
}
static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
{
volatile int exit_val = 0;
volatile int did_config = 0;
if (fa->a->init_ns) {
Scheme_Object *nsreq, *a[1];
Scheme_Object *a[1], *nsreq;
Scheme_Thread * volatile p;
mz_jmp_buf * volatile save, newbuf;
nsreq = scheme_builtin_value("namespace-require");
a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
scheme_make_pair(scheme_make_utf8_string(fa->init_lib),
scheme_make_null()));
@ -183,9 +225,13 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
if (!scheme_setjmp(newbuf)) {
if (!did_config) {
configure_environment(a[0]);
did_config = 1;
}
scheme_apply(nsreq, 1, a);
else {
} else {
exit_val = 1;
}
p->error_buf = save;
@ -238,6 +284,8 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
a[0] = scheme_make_pair(scheme_intern_symbol(name),
scheme_make_pair(scheme_make_utf8_string(fa->evals_and_loads[i]),
scheme_make_null()));
if (!did_config)
configure_environment(a[0]);
scheme_apply(nsreq, 1, a);
}
} else {
@ -307,6 +355,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
}
p->error_buf = save;
}
did_config = 1;
}
}
#endif /* DONT_PARSE_COMMAND_LINE */

3
src/mzscheme/include/mzscheme.exp
View File

@ -355,8 +355,8 @@ scheme_compile
scheme_read
scheme_read_syntax
scheme_write
scheme_display
scheme_print
scheme_display
scheme_write_w_max
scheme_display_w_max
scheme_print_w_max
@ -523,6 +523,7 @@ scheme_intern_exact_char_keyword
scheme_make_struct_values
scheme_make_struct_names
scheme_make_struct_type
scheme_make_struct_type2
scheme_make_struct_instance
scheme_is_struct_instance
scheme_struct_ref

3
src/mzscheme/include/mzscheme3m.exp
View File

@ -361,8 +361,8 @@ scheme_compile
scheme_read
scheme_read_syntax
scheme_write
scheme_display
scheme_print
scheme_display
scheme_write_w_max
scheme_display_w_max
scheme_print_w_max
@ -529,6 +529,7 @@ scheme_intern_exact_char_keyword
scheme_make_struct_values
scheme_make_struct_names
scheme_make_struct_type
scheme_make_struct_type2
scheme_make_struct_instance
scheme_is_struct_instance
scheme_struct_ref

3
src/mzscheme/include/mzwin.def
View File

@ -338,8 +338,8 @@ EXPORTS
scheme_read
scheme_read_syntax
scheme_write
scheme_display
scheme_print
scheme_display
scheme_write_w_max
scheme_display_w_max
scheme_print_w_max
@ -506,6 +506,7 @@ EXPORTS
scheme_make_struct_values
scheme_make_struct_names
scheme_make_struct_type
scheme_make_struct_type2
scheme_make_struct_instance
scheme_is_struct_instance
scheme_struct_ref

3
src/mzscheme/include/mzwin3m.def
View File

@ -353,8 +353,8 @@ EXPORTS
scheme_read
scheme_read_syntax
scheme_write
scheme_display
scheme_print
scheme_display
scheme_write_w_max
scheme_display_w_max
scheme_print_w_max
@ -521,6 +521,7 @@ EXPORTS
scheme_make_struct_values
scheme_make_struct_names
scheme_make_struct_type
scheme_make_struct_type2
scheme_make_struct_instance
scheme_is_struct_instance
scheme_struct_ref

3
src/mzscheme/include/scheme.h
View File

@ -1191,6 +1191,8 @@ enum {
MZCONFIG_PRINT_PAIR_CURLY,
MZCONFIG_PRINT_MPAIR_CURLY,
MZCONFIG_PRINT_SYNTAX_WIDTH,
MZCONFIG_PRINT_READER,
MZCONFIG_PRINT_AS_QQ,
MZCONFIG_CASE_SENS,
MZCONFIG_SQUARE_BRACKETS_ARE_PARENS,
@ -1894,6 +1896,7 @@ extern Scheme_Extension_Table *scheme_extension_table;
#define SCHEME_STRUCT_GEN_GET 0x20
#define SCHEME_STRUCT_GEN_SET 0x40
#define SCHEME_STRUCT_EXPTIME 0x80
#define SCHEME_STRUCT_NO_MAKE_PREFIX 0x100
/*========================================================================*/
/* file descriptors */

1123
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -3287,7 +3287,7 @@ do_raise(Scheme_Object *arg, int need_debug, int eb)
if (need_debug) {
msg = scheme_display_to_string(((Scheme_Structure *)arg)->slots[0], NULL);
} else
msg = scheme_write_to_string(arg, NULL);
msg = scheme_print_to_string(arg, NULL);
scheme_log(NULL,
SCHEME_LOG_WARNING,
0,

14
src/mzscheme/src/fun.c
View File

@ -3520,10 +3520,8 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
return scheme_make_integer(1);
}
static Scheme_Object *object_name(int argc, Scheme_Object **argv)
Scheme_Object *scheme_object_name(Scheme_Object *a)
{
Scheme_Object *a = argv[0];
if (SCHEME_CHAPERONEP(a))
a = SCHEME_CHAPERONE_VAL(a);
@ -3580,6 +3578,11 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv)
return scheme_false;
}
static Scheme_Object *object_name(int argc, Scheme_Object **argv)
{
return scheme_object_name(argv[0]);
}
Scheme_Object *scheme_arity(Scheme_Object *p)
{
return get_or_check_arity(p, -1, NULL);
@ -3676,13 +3679,14 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
while (insp->superior->superior) {
insp = insp->superior;
}
scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
NULL,
(Scheme_Object *)insp,
4, 0,
scheme_false,
scheme_null,
scheme_make_integer(0),
NULL);
NULL, NULL);
}
}

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

@ -398,7 +398,7 @@ void scheme_init_module(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("resolved-module-path-name", resolved_module_path_name, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module-provide-protected?", module_export_protected_p, 2, 2, env);
GLOBAL_PRIM_W_ARITY("module->namespace", module_to_namespace, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module->language-info", module_to_lang_info, 1, 1, env);
GLOBAL_PRIM_W_ARITY("module->language-info", module_to_lang_info, 1, 2, env);
GLOBAL_PRIM_W_ARITY("module->imports", module_to_imports, 1, 1, env);
GLOBAL_PRIM_W_ARITY2("module->exports", module_to_exports, 1, 1, 2, 2, env);
GLOBAL_PRIM_W_ARITY("module-path?", is_module_path, 1, 1, env);
@ -2601,7 +2601,8 @@ static Scheme_Module *module_to_(const char *who, int argc, Scheme_Object *argv[
if (SCHEME_MODNAMEP(argv[0]))
name = argv[0];
else
name = scheme_module_resolve(scheme_make_modidx(argv[0], scheme_false, scheme_false), 1);
name = scheme_module_resolve(scheme_make_modidx(argv[0], scheme_false, scheme_false),
(argc > 1) ? SCHEME_TRUEP(argv[1]) : 0);
if (SAME_OBJ(name, kernel_modname))
m = kernel;

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

@ -3829,6 +3829,7 @@ static int mark_print_params_MARK(void *p, struct NewGC *gc) {
gcMARK2(pp->inspector, gc);
gcMARK2(pp->print_port, gc);
gcMARK2(pp->print_buffer, gc);
gcMARK2(pp->depth_delta, gc);
return
gcBYTES_TO_WORDS(sizeof(PrintParams));
}
@ -3838,6 +3839,7 @@ static int mark_print_params_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(pp->inspector, gc);
gcFIXUP2(pp->print_port, gc);
gcFIXUP2(pp->print_buffer, gc);
gcFIXUP2(pp->depth_delta, gc);
return
gcBYTES_TO_WORDS(sizeof(PrintParams));
}

1
src/mzscheme/src/mzmarksrc.c
View File

@ -1560,6 +1560,7 @@ mark_print_params {
gcMARK2(pp->inspector, gc);
gcMARK2(pp->print_port, gc);
gcMARK2(pp->print_buffer, gc);
gcMARK2(pp->depth_delta, gc);
size:
gcBYTES_TO_WORDS(sizeof(PrintParams));
}

61
src/mzscheme/src/portfun.c
View File

@ -200,14 +200,14 @@ scheme_init_port_fun(Scheme_Env *env)
scheme_write_proc = scheme_make_noncm_prim(sch_write, "write", 1, 2);
scheme_display_proc = scheme_make_noncm_prim(display, "display", 1, 2);
scheme_print_proc = scheme_make_noncm_prim(sch_print, "print", 1, 2);
scheme_print_proc = scheme_make_noncm_prim(sch_print, "print", 1, 3);
/* Made as a closed prim so we can get the arity right: */
default_read_handler = scheme_make_closed_prim_w_arity(sch_default_read_handler, NULL, "default-port-read-handler", 1, 2);
default_display_handler = scheme_make_prim_w_arity(sch_default_display_handler, "default-port-display-handler", 2, 2);
default_write_handler = scheme_make_prim_w_arity(sch_default_write_handler, "default-port-write-handler", 2, 2);
default_print_handler = scheme_make_prim_w_arity(sch_default_print_handler, "default-port-print-handler", 2, 2);
default_print_handler = scheme_make_prim_w_arity(sch_default_print_handler, "default-port-print-handler", 2, 3);
scheme_add_global_constant("eof", scheme_eof, env);
@ -342,7 +342,7 @@ void scheme_init_port_fun_config(void)
REGISTER_SO(scheme_default_global_print_handler);
scheme_default_global_print_handler
= scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 2);
= scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 3);
scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler);
/* Use dummy port: */
@ -3684,6 +3684,9 @@ static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
{
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-port-print-handler", "output-port", 1, argc, argv);
if ((argc > 2) && !scheme_nonneg_exact_p(argv[2]))
scheme_wrong_type("default-port-print-handler", "non-negative exact integer",
2, argc, argv);
return _scheme_apply(scheme_get_param(scheme_current_config(),
MZCONFIG_PORT_PRINT_HANDLER),
@ -3694,8 +3697,11 @@ static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Obj
{
if (!SCHEME_OUTPUT_PORTP(argv[1]))
scheme_wrong_type("default-global-port-print-handler", "output-port", 1, argc, argv);
if ((argc > 2) && !scheme_nonneg_exact_p(argv[2]))
scheme_wrong_type("default-global-port-print-handler", "non-negative exact integer",
2, argc, argv);
scheme_internal_print(argv[0], argv[1]);
scheme_internal_print(argv[0], argv[1], argv[2]);
return scheme_void;
}
@ -3757,17 +3763,25 @@ display_write(char *name,
} else {
/* print */
Scheme_Object *h;
Scheme_Object *a[2];
Scheme_Object *a[3];
if (argc > 2) {
h = argv[2];
if (!scheme_nonneg_exact_p(h))
scheme_wrong_type(name, "non-negative exact integer", 2, argc, argv);
} else
h = scheme_make_integer(0);
a[0] = argv[0];
a[1] = (Scheme_Object *)port;
a[2] = h;
h = op->print_handler;
if (!h)
sch_default_print_handler(2, a);
sch_default_print_handler(3, a);
else
_scheme_apply_multi(h, 2, a);
_scheme_apply_multi(h, 3, a);
}
return scheme_void;
@ -3943,6 +3957,20 @@ static Scheme_Object *port_write_handler(int argc, Scheme_Object *argv[])
}
}
static Scheme_Object *call_print_handler(void *data, int argc, Scheme_Object *argv[])
{
/* If there's a 3rd argument, drop it. */
return _scheme_tail_apply((Scheme_Object *)data, 2, argv);
}
static Scheme_Object *wrap_print_handler(Scheme_Object *proc)
{
return scheme_make_closed_prim_w_arity(call_print_handler,
proc,
"wrapped-port-print-handler",
2, 3);
}
static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
{
Scheme_Output_Port *op;
@ -3960,19 +3988,34 @@ static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
scheme_check_proc_arity("port-print-handler", 2, 1, argc, argv);
if (argv[1] == default_print_handler)
op->print_handler = NULL;
else
else if (!scheme_check_proc_arity(NULL, 3, 1, argc, argv)) {
Scheme_Object *wrapped;
wrapped = wrap_print_handler(argv[1]);
op->print_handler = wrapped;
} else
op->print_handler = argv[1];
return scheme_void;
}
}
static Scheme_Object *filter_print_handler(int argc, Scheme_Object **argv)
{
if (scheme_check_proc_arity(NULL, 2, 0, argc, argv)) {
if (scheme_check_proc_arity(NULL, 3, 0, argc, argv))
return argv[0];
else
return wrap_print_handler(argv[0]);
} else
return NULL;
}
static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
{
return scheme_param_config("global-port-print-handler",
scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER),
argc, argv,
2, NULL, NULL, 0);
-1, filter_print_handler, "procedure (arity 2)", 1);
}
static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[])

292
src/mzscheme/src/print.c
View File

@ -49,11 +49,22 @@ SHARED_OK static char compacts[_CPT_COUNT_];
SHARED_OK static Scheme_Hash_Table *global_constants_ht;
SHARED_OK static Scheme_Object *quote_link_symbol = NULL;
ROSYM Scheme_Object *quote_symbol;
ROSYM Scheme_Object *quasiquote_symbol;
ROSYM Scheme_Object *unquote_symbol;
ROSYM Scheme_Object *unquote_splicing_symbol;
ROSYM Scheme_Object *syntax_symbol;
ROSYM Scheme_Object *quasisyntax_symbol;
ROSYM Scheme_Object *unsyntax_symbol;
ROSYM Scheme_Object *unsyntax_splicing_symbol;
/* Flag for debugging compiled code in printed form: */
#define NO_COMPACT 0
#define PRINT_MAXLEN_MIN 3
#define REASONABLE_QQ_DEPTH (1 << 29)
/* locals */
#define MAX_PRINT_BUFFER 500
@ -67,6 +78,7 @@ typedef struct Scheme_Print_Params {
char print_hash_table;
char print_unreadable;
char print_pair_curly, print_mpair_curly;
char print_reader;
char can_read_pipe_quote;
char case_sens;
char honu_mode;
@ -81,6 +93,7 @@ typedef struct Scheme_Print_Params {
long print_syntax;
Scheme_Object *print_port;
mz_jmp_buf *print_escape;
Scheme_Object *depth_delta; /* for large qq depth */
} PrintParams;
#ifdef MZ_PRECISE_GC
@ -88,7 +101,7 @@ static void register_traversers(void);
#endif
static void print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port,
int notdisplay, long maxl, int check_honu);
int notdisplay, long maxl, int check_honu, Scheme_Object *qq_depth);
static int print(Scheme_Object *obj, int notdisplay, int compact,
Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
@ -100,7 +113,7 @@ static void print_pair(Scheme_Object *pair, int notdisplay, int compact,
Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
PrintParams *pp,
Scheme_Type type, int round_parens);
Scheme_Type type, int round_parens, int first_unquoted);
static void print_vector(Scheme_Object *vec, int notdisplay, int compact,
Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
@ -108,7 +121,8 @@ static void print_vector(Scheme_Object *vec, int notdisplay, int compact,
int as_prefab);
static void print_char(Scheme_Object *chobj, int notdisplay, PrintParams *pp);
static char *print_to_string(Scheme_Object *obj, long * volatile len, int write,
Scheme_Object *port, long maxl, int check_honu);
Scheme_Object *port, long maxl, int check_honu,
Scheme_Object *qq_depth);
static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
@ -153,6 +167,23 @@ void scheme_init_print(Scheme_Env *env)
compacts[i] = i;
}
REGISTER_SO(quote_symbol);
REGISTER_SO(quasiquote_symbol);
REGISTER_SO(unquote_symbol);
REGISTER_SO(unquote_splicing_symbol);
REGISTER_SO(syntax_symbol);
REGISTER_SO(quasisyntax_symbol);
REGISTER_SO(unsyntax_symbol);
REGISTER_SO(unsyntax_splicing_symbol);
quote_symbol = scheme_intern_symbol("quote");
quasiquote_symbol = scheme_intern_symbol("quasiquote");
unquote_symbol = scheme_intern_symbol("unquote");
unquote_splicing_symbol = scheme_intern_symbol("unquote-splicing");
syntax_symbol = scheme_intern_symbol("syntax");
quasisyntax_symbol = scheme_intern_symbol("quasisyntax");
unsyntax_symbol = scheme_intern_symbol("unsyntax");
unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing");
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
@ -208,14 +239,24 @@ scheme_debug_print (Scheme_Object *obj)
static void *print_to_port_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *obj, *port;
Scheme_Object *obj, *port, *depth;
port = (Scheme_Object *)p->ku.k.p1;
obj = (Scheme_Object *)p->ku.k.p2;
depth = (Scheme_Object *)p->ku.k.p3;
print_to_port(p->ku.k.i2 ? "write" : "display",
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
print_to_port((p->ku.k.i2
? ((p->ku.k.i2 = 2)
? "print"
: "write")
: "display"),
obj, port,
p->ku.k.i2, p->ku.k.i1, p->ku.k.i3);
p->ku.k.i2, p->ku.k.i1, p->ku.k.i3,
depth);
return NULL;
}
@ -232,7 +273,7 @@ static void do_handled_print(Scheme_Object *obj, Scheme_Object *port,
} else
a[1] = port;
scheme_apply_multi(scheme_write_proc, 2, a);
scheme_apply_multi(proc, 2, a);
if (maxl > 0) {
char *s;
@ -258,6 +299,7 @@ void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
p->ku.k.i1 = maxl;
p->ku.k.i2 = 1;
p->ku.k.i3 = 0;
p->ku.k.p3 = NULL;
(void)scheme_top_level_do(print_to_port_k, 0);
}
@ -280,6 +322,7 @@ void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
p->ku.k.i1 = maxl;
p->ku.k.i2 = 0;
p->ku.k.i3 = 0;
p->ku.k.p3 = NULL;
(void)scheme_top_level_do(print_to_port_k, 0);
}
@ -300,8 +343,9 @@ void scheme_print_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
p->ku.k.p1 = port;
p->ku.k.p2 = obj;
p->ku.k.i1 = maxl;
p->ku.k.i2 = 1;
p->ku.k.i2 = 2;
p->ku.k.i3 = 1;
p->ku.k.p3 = NULL;
(void)scheme_top_level_do(print_to_port_k, 0);
}
@ -315,7 +359,7 @@ void scheme_print(Scheme_Object *obj, Scheme_Object *port)
static void *print_to_string_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *obj;
Scheme_Object *obj, *qq_depth;
long *len, maxl;
int iswrite, check_honu;
@ -324,11 +368,13 @@ static void *print_to_string_k(void)
maxl = p->ku.k.i1;
iswrite = p->ku.k.i2;
check_honu = p->ku.k.i3;
qq_depth = (Scheme_Object *)p->ku.k.p3;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
return (void *)print_to_string(obj, len, iswrite, NULL, maxl, check_honu);
return (void *)print_to_string(obj, len, iswrite, NULL, maxl, check_honu, qq_depth);
}
char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
@ -340,6 +386,7 @@ char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
p->ku.k.i1 = maxl;
p->ku.k.i2 = 1;
p->ku.k.i3 = 0;
p->ku.k.p3 = NULL;
return (char *)scheme_top_level_do(print_to_string_k, 0);
}
@ -358,6 +405,7 @@ char *scheme_display_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
p->ku.k.i1 = maxl;
p->ku.k.i2 = 0;
p->ku.k.i3 = 0;
p->ku.k.p3 = NULL;
return (char *)scheme_top_level_do(print_to_string_k, 0);
}
@ -374,8 +422,9 @@ char *scheme_print_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
p->ku.k.p1 = obj;
p->ku.k.p2 = len;
p->ku.k.i1 = maxl;
p->ku.k.i2 = 1;
p->ku.k.i2 = 2;
p->ku.k.i3 = 1;
p->ku.k.p3 = NULL;
return (char *)scheme_top_level_do(print_to_string_k, 0);
}
@ -388,19 +437,19 @@ char *scheme_print_to_string(Scheme_Object *obj, long *len)
void
scheme_internal_write(Scheme_Object *obj, Scheme_Object *port)
{
print_to_port("write", obj, port, 1, -1, 0);
print_to_port("write", obj, port, 1, -1, 0, NULL);
}
void
scheme_internal_display(Scheme_Object *obj, Scheme_Object *port)
{
print_to_port("display", obj, port, 0, -1, 0);
print_to_port("display", obj, port, 0, -1, 0, NULL);
}
void
scheme_internal_print(Scheme_Object *obj, Scheme_Object *port)
scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Object *depth)
{
print_to_port("print", obj, port, 1, -1, 1);
print_to_port("print", obj, port, 2, -1, 1, depth);
}
#ifdef DO_STACK_CHECK
@ -834,7 +883,8 @@ static char *
print_to_string(Scheme_Object *obj,
long * volatile len, int write,
Scheme_Object *port, long maxl,
int check_honu)
int check_honu,
Scheme_Object *qq_depth)
{
Scheme_Hash_Table * volatile ht;
Scheme_Object *v;
@ -852,6 +902,7 @@ print_to_string(Scheme_Object *obj,
params.print_maxlen = maxl;
params.print_port = port;
params.print_syntax = 0;
params.depth_delta = NULL;
/* Getting print params can take a while, and they're irrelevant
for simple things like displaying numbers. So try a shortcut: */
@ -866,6 +917,7 @@ print_to_string(Scheme_Object *obj,
params.print_vec_shorthand = 0;
params.print_hash_table = 0;
params.print_unreadable = 1;
params.print_reader = 1;
params.print_pair_curly = 0;
params.print_mpair_curly = 1;
params.can_read_pipe_quote = 1;
@ -904,6 +956,28 @@ print_to_string(Scheme_Object *obj,
params.print_pair_curly = SCHEME_TRUEP(v);
v = scheme_get_param(config, MZCONFIG_PRINT_MPAIR_CURLY);
params.print_mpair_curly = SCHEME_TRUEP(v);
if (write > 1) {
v = scheme_get_param(config, MZCONFIG_PRINT_AS_QQ);
if (SCHEME_TRUEP(v)) {
params.depth_delta = scheme_make_integer(0);
if (qq_depth) {
if (scheme_bin_gt(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH))) {
write = 3 + REASONABLE_QQ_DEPTH;
qq_depth = scheme_bin_minus(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH));
params.depth_delta = qq_depth;
} else
write = 3 + SCHEME_INT_VAL(qq_depth);
} else
write = 3;
}
}
/* at this point, write >= 3 => qq printing at depth write - 3 */
if (write > 2) {
params.print_reader = 1;
} else {
v = scheme_get_param(config, MZCONFIG_PRINT_READER);
params.print_reader = SCHEME_TRUEP(v);
}
v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE);
params.can_read_pipe_quote = SCHEME_TRUEP(v);
v = scheme_get_param(config, MZCONFIG_CASE_SENS);
@ -957,7 +1031,8 @@ print_to_string(Scheme_Object *obj,
}
static void
print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdisplay, long maxl, int check_honu)
print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdisplay,
long maxl, int check_honu, Scheme_Object *qq_depth)
{
Scheme_Output_Port *op;
char *str;
@ -967,7 +1042,7 @@ print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdispla
if (op->closed)
scheme_raise_exn(MZEXN_FAIL, "%s: output port is closed", name);
str = print_to_string(obj, &len, notdisplay, port, maxl, check_honu);
str = print_to_string(obj, &len, notdisplay, port, maxl, check_honu, qq_depth);
scheme_write_byte_string(str, len, port);
}
@ -1576,9 +1651,28 @@ static void always_scheme(PrintParams *pp, int reset)
}
}
static int to_quoted(PrintParams *pp, int notdisplay, const char *quote)
{
if (notdisplay == 3) {
print_utf8_string(pp, quote, 0, 1);
return notdisplay + 1;
} else
return notdisplay;
}
static int to_unquoted(PrintParams *pp, int notdisplay)
{
while (notdisplay > 3) {
print_utf8_string(pp, ",", 0, 1);
--notdisplay;
}
return notdisplay;
}
static int
print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt, PrintParams *pp)
/* notdisplay >= 3 => print at qq depth notdisplay - 3 */
{
int closed = 0;
int save_honu_mode;
@ -1741,6 +1835,17 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
} else {
const char *s;
if (notdisplay >= 3) {
if (notdisplay == 4) {
if (SAME_OBJ(obj, unquote_symbol)
|| SAME_OBJ(obj, unquote_splicing_symbol))
print_utf8_string(pp, ",'", 0, 2);
else
notdisplay = to_quoted(pp, notdisplay, "'");
} else
notdisplay = to_quoted(pp, notdisplay, "'");
}
if (is_kw)
print_utf8_string(pp, "#:", 0, 2);
s = scheme_symbol_name_and_size(obj, (unsigned int *)&l,
@ -1866,6 +1971,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (compact) {
print_compact(pp, CPT_NULL);
} else {
notdisplay = to_quoted(pp, notdisplay, "'");
if (pp->honu_mode)
print_utf8_string(pp, "null", 0, 4);
else
@ -1875,18 +1981,21 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
}
else if (SCHEME_PAIRP(obj))
{
print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly);
notdisplay = to_quoted(pp, notdisplay, "`");
print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly, 0);
closed = 1;
}
else if (SCHEME_MUTABLE_PAIRP(obj))
{
notdisplay = to_quoted(pp, notdisplay, "`");
if (compact || !pp->print_unreadable)
cannot_print(pp, notdisplay, obj, ht, compact);
print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly);
print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly, 0);
closed = 1;
}
else if (SCHEME_CHAPERONE_VECTORP(obj))
{
notdisplay = to_quoted(pp, notdisplay, "`");
print_vector(obj, notdisplay, compact, ht, mt, pp, 0);
closed = 1;
}
@ -1900,6 +2009,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_compact(pp, CPT_BOX);
else {
always_scheme(pp, 1);
notdisplay = to_quoted(pp, notdisplay, "`");
print_utf8_string(pp, "#&", 0, 2);
}
if (SCHEME_BOXP(obj))
@ -1933,6 +2043,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_compact_number(pp, 0);
} else {
always_scheme(pp, 1);
notdisplay = to_quoted(pp, notdisplay, "`");
print_utf8_string(pp, "#hash", 0, 5);
if (SCHEME_HASHTP(obj)) {
if (!scheme_is_hash_table_equal(obj)) {
@ -2061,10 +2172,18 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
Scheme_Object *vec, *prefab;
prefab = ((Scheme_Structure *)obj)->stype->prefab_key;
vec = scheme_struct_to_vector(obj, NULL, pp->inspector);
if ((notdisplay >= 3) && !prefab) {
notdisplay = to_unquoted(pp, notdisplay);
vec = scheme_vector_to_list(vec);
vec = scheme_make_pair(scheme_object_name(obj), SCHEME_CDR(vec));
print_pair(vec, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly, 1);
} else {
if (prefab) {
SCHEME_VEC_ELS(vec)[0] = SCHEME_CDR(prefab);
notdisplay = to_quoted(pp, notdisplay, "`");
}
print_vector(vec, notdisplay, compact, ht, mt, pp, !!prefab);
}
closed = 1;
} else {
Scheme_Object *src;
@ -2456,7 +2575,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
char *str;
print_utf8_string(pp, " ", 0, 1);
str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx, 0, NULL),
&slen, 1, NULL, pp->print_syntax, 0);
&slen, 1, NULL, pp->print_syntax, 0, NULL);
print_utf8_string(pp, str, 0, slen);
}
print_utf8_string(pp, ">", 0, 1);
@ -3065,13 +3184,80 @@ print_byte_string(const char *str, int delta, int len, int notdisplay, PrintPara
}
}
static int is_special_reader_form(PrintParams *pp, int notdisplay, Scheme_Object *p)
{
Scheme_Object *v;
if (notdisplay && pp->print_reader) {
v = SCHEME_CAR(p);
p = SCHEME_CDR(p);
if (!SCHEME_PAIRP(p)) return 0;
p = SCHEME_CDR(p);
if (!SCHEME_NULLP(p)) return 0;
if (SCHEME_SYMBOLP(v)) {
if (SAME_OBJ(v, quote_symbol)
|| SAME_OBJ(v, quasiquote_symbol)
|| (SAME_OBJ(v, unquote_symbol) && (notdisplay != 4))
|| (SAME_OBJ(v, unquote_splicing_symbol) && (notdisplay != 4))
|| SAME_OBJ(v, syntax_symbol)
|| SAME_OBJ(v, quasisyntax_symbol)
|| SAME_OBJ(v, unsyntax_symbol)
|| SAME_OBJ(v, unsyntax_splicing_symbol))
return 1;
}
}
return 0;
}
static int print_special_reader_form(Scheme_Object *v, PrintParams *pp, int notdisplay)
{
const char *str;
int len;
if (SAME_OBJ(v, quote_symbol)) {
str = "'";
len = 1;
} else if (SAME_OBJ(v, quasiquote_symbol)) {
str = "`";
len = 1;
notdisplay++;
} else if (SAME_OBJ(v, unquote_symbol)) {
str = ",";
len = 1;
--notdisplay;
} else if (SAME_OBJ(v, unquote_splicing_symbol)) {
str = ",@";
len = 2;
--notdisplay;
} else if (SAME_OBJ(v, syntax_symbol)) {
str = "#'";
len = 2;
} else if (SAME_OBJ(v, quasisyntax_symbol)) {
str = "#`";
len = 2;
} else if (SAME_OBJ(v, unsyntax_symbol)) {
str = "#,";
len = 2;
} else if (SAME_OBJ(v, unsyntax_splicing_symbol)) {
str = "#,@";
len = 3;
} else {
str = "???";
len = 3;
}
print_utf8_string(pp, str, 0, len);
return notdisplay;
}
static void
print_pair(Scheme_Object *pair, int notdisplay, int compact,
Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
PrintParams *pp,
Scheme_Type pair_type, int round_parens)
Scheme_Type pair_type, int round_parens, int first_unquoted)
{
Scheme_Object *cdr;
int super_compact = 0;
@ -3162,16 +3348,22 @@ print_pair(Scheme_Object *pair, int notdisplay, int compact,
if (!super_compact)
print_compact(pp, CPT_PAIR);
} else {
if (round_parens)
if (round_parens) {
if (!first_unquoted && is_special_reader_form(pp, notdisplay, pair)) {
notdisplay = print_special_reader_form(SCHEME_CAR(pair), pp, notdisplay);
(void)print(SCHEME_CADR(pair), notdisplay, compact, ht, mt, pp);
return;
} else
print_utf8_string(pp,"(", 0, 1);
else
} else
print_utf8_string(pp,"{", 0, 1);
}
print(SCHEME_CAR(pair), notdisplay, compact, ht, mt, pp);
print(SCHEME_CAR(pair), (first_unquoted ? 1 : notdisplay), compact, ht, mt, pp);
cdr = SCHEME_CDR (pair);
while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
cdr = SCHEME_CDR(pair);
while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)
&& !is_special_reader_form(pp, notdisplay, pair)) {
if (ht && !super_compact) {
if ((long)scheme_hash_get(ht, cdr) != 1) {
/* This needs a tag */
@ -3450,7 +3642,9 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
volatile long save_max;
if (!SCHEME_OUTPORTP(argv[1])) {
scheme_wrong_type(notdisplay ? "write/recusrive" : "display/recursive",
scheme_wrong_type((notdisplay > 1)
? "print/recursive"
: (notdisplay ? "write/recusrive" : "display/recursive"),
"output-port", 1, argc, argv);
return NULL;
}
@ -3491,6 +3685,29 @@ static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_
pp->print_port = argv[1];
if (notdisplay > 1) {
if (argc > 2) {
Scheme_Object *qq_depth = argv[2];
if (!scheme_nonneg_exact_p(qq_depth))
scheme_wrong_type("print/recursive", "nonnegative exact integer", 2, argc, argv);
pp = copy_print_params(pp);
if (scheme_bin_gt(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH))) {
notdisplay = 3 + REASONABLE_QQ_DEPTH;
qq_depth = scheme_bin_minus(qq_depth, scheme_make_integer(REASONABLE_QQ_DEPTH));
pp->depth_delta = qq_depth;
} else {
pp->depth_delta = scheme_make_integer(0);
notdisplay = 3 + SCHEME_INT_VAL(qq_depth);
}
} else if (pp->depth_delta) {
notdisplay = 3;
if (!SAME_OBJ(pp->depth_delta, scheme_make_integer(0))) {
pp = copy_print_params(pp);
pp->depth_delta = scheme_make_integer(0);
}
}
}
/* Recur */
print(argv[0], notdisplay, 0, ht, mt, pp);
@ -3518,13 +3735,18 @@ static Scheme_Object *custom_display_recur(void *_vec, int argc, Scheme_Object *
return custom_recur(0, _vec, argc, argv);
}
static Scheme_Object *custom_print_recur(void *_vec, int argc, Scheme_Object **argv)
{
return custom_recur(2, _vec, argc, argv);
}
static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
Scheme_Marshal_Tables *mt,
PrintParams *orig_pp, int notdisplay)
{
Scheme_Object *v, *a[3], *o, *vec, *orig_port;
Scheme_Output_Port *op;
Scheme_Object *recur_write, *recur_display;
Scheme_Object *recur_write, *recur_display, *recur_print;
PrintParams *pp;
v = scheme_is_writable_struct(s);
@ -3557,11 +3779,14 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
vec,
"custom-display-recur-handler",
2, 2);
recur_print = scheme_make_closed_prim_w_arity(custom_print_recur,
vec,
"custom-print-recur-handler",
2, 3);
op->write_handler = recur_write;
op->display_handler = recur_display;
op->print_handler = recur_write;
op->print_handler = recur_print;
/* First, flush print cache to actual port,
so further writes go after current writes: */
@ -3570,7 +3795,12 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
a[0] = s;
a[1] = o;
if (notdisplay >= 3) {
a[2] = scheme_bin_plus(pp->depth_delta, scheme_make_integer(notdisplay - 3));
pp->depth_delta = a[2];
} else
a[2] = (notdisplay ? scheme_true : scheme_false);
scheme_apply_multi(v, 3, a);
scheme_close_output_port(o);

16
src/mzscheme/src/read.c
View File

@ -118,6 +118,8 @@ static Scheme_Object *print_pair_curly(int, Scheme_Object *[]);
static Scheme_Object *print_mpair_curly(int, Scheme_Object *[]);
static Scheme_Object *print_honu(int, Scheme_Object *[]);
static Scheme_Object *print_syntax_width(int, Scheme_Object *[]);
static Scheme_Object *print_reader(int, Scheme_Object *[]);
static Scheme_Object *print_as_qq(int, Scheme_Object *[]);
static int scheme_ellipses(mzchar* buffer, int length);
@ -536,6 +538,8 @@ void scheme_init_read(Scheme_Env *env)
GLOBAL_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env);
GLOBAL_PARAMETER("print-honu", print_honu, MZCONFIG_HONU_MODE, env);
GLOBAL_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env);
GLOBAL_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env);
GLOBAL_PARAMETER("print-as-quasiquote", print_as_qq, MZCONFIG_PRINT_AS_QQ, env);
GLOBAL_PRIM_W_ARITY("make-readtable", make_readtable, 1, -1, env);
GLOBAL_FOLDING_PRIM("readtable?", readtable_p, 1, 1, 1, env);
@ -753,6 +757,18 @@ print_honu(int argc, Scheme_Object *argv[])
DO_CHAR_PARAM("print-honu", MZCONFIG_HONU_MODE);
}
static Scheme_Object *
print_reader(int argc, Scheme_Object *argv[])
{
DO_CHAR_PARAM("print-reader-abbreviations", MZCONFIG_PRINT_READER);
}
static Scheme_Object *
print_as_qq(int argc, Scheme_Object *argv[])
{
DO_CHAR_PARAM("print-as-quasiquote", MZCONFIG_PRINT_AS_QQ);
}
static Scheme_Object *good_syntax_width(int c, Scheme_Object **argv)
{
int ok;

11
src/mzscheme/src/schemef.h
View File

@ -699,8 +699,8 @@ MZ_EXTERN Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, in
MZ_EXTERN Scheme_Object *scheme_read(Scheme_Object *port);
MZ_EXTERN Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc);
MZ_EXTERN void scheme_write(Scheme_Object *obj, Scheme_Object *port);
MZ_EXTERN void scheme_display(Scheme_Object *obj, Scheme_Object *port);
MZ_EXTERN void scheme_print(Scheme_Object *obj, Scheme_Object *port);
MZ_EXTERN void scheme_display(Scheme_Object *obj, Scheme_Object *port);
MZ_EXTERN void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
MZ_EXTERN void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
MZ_EXTERN void scheme_print_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl);
@ -993,6 +993,15 @@ MZ_EXTERN Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
Scheme_Object *uninit_val,
Scheme_Object *properties,
Scheme_Object *guard);
MZ_EXTERN Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit_fields,
Scheme_Object *uninit_val,
Scheme_Object *proc_attr,
Scheme_Object *properties,
char *immutable_array,
Scheme_Object *guard);
MZ_EXTERN Scheme_Object *scheme_make_struct_instance(Scheme_Object *stype,
int argc,
Scheme_Object **argv);

11
src/mzscheme/src/schemex.h
View File

@ -577,8 +577,8 @@ Scheme_Object *(*scheme_compile)(Scheme_Object *form, Scheme_Env *env, int write
Scheme_Object *(*scheme_read)(Scheme_Object *port);
Scheme_Object *(*scheme_read_syntax)(Scheme_Object *port, Scheme_Object *stxsrc);
void (*scheme_write)(Scheme_Object *obj, Scheme_Object *port);
void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port);
void (*scheme_print)(Scheme_Object *obj, Scheme_Object *port);
void (*scheme_display)(Scheme_Object *obj, Scheme_Object *port);
void (*scheme_write_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
void (*scheme_display_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
void (*scheme_print_w_max)(Scheme_Object *obj, Scheme_Object *port, long maxl);
@ -825,6 +825,15 @@ Scheme_Object *(*scheme_make_struct_type)(Scheme_Object *base,
Scheme_Object *uninit_val,
Scheme_Object *properties,
Scheme_Object *guard);
Scheme_Object *(*scheme_make_struct_type2)(Scheme_Object *base,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit_fields,
Scheme_Object *uninit_val,
Scheme_Object *proc_attr,
Scheme_Object *properties,
char *immutable_array,
Scheme_Object *guard);
Scheme_Object *(*scheme_make_struct_instance)(Scheme_Object *stype,
int argc,
Scheme_Object **argv);

3
src/mzscheme/src/schemex.inc
View File

@ -403,8 +403,8 @@
scheme_extension_table->scheme_read = scheme_read;
scheme_extension_table->scheme_read_syntax = scheme_read_syntax;
scheme_extension_table->scheme_write = scheme_write;
scheme_extension_table->scheme_display = scheme_display;
scheme_extension_table->scheme_print = scheme_print;
scheme_extension_table->scheme_display = scheme_display;
scheme_extension_table->scheme_write_w_max = scheme_write_w_max;
scheme_extension_table->scheme_display_w_max = scheme_display_w_max;
scheme_extension_table->scheme_print_w_max = scheme_print_w_max;
@ -575,6 +575,7 @@
scheme_extension_table->scheme_make_struct_values = scheme_make_struct_values;
scheme_extension_table->scheme_make_struct_names = scheme_make_struct_names;
scheme_extension_table->scheme_make_struct_type = scheme_make_struct_type;
scheme_extension_table->scheme_make_struct_type2 = scheme_make_struct_type2;
scheme_extension_table->scheme_make_struct_instance = scheme_make_struct_instance;
scheme_extension_table->scheme_is_struct_instance = scheme_is_struct_instance;
scheme_extension_table->scheme_struct_ref = scheme_struct_ref;

3
src/mzscheme/src/schemexm.h
View File

@ -403,8 +403,8 @@
#define scheme_read (scheme_extension_table->scheme_read)
#define scheme_read_syntax (scheme_extension_table->scheme_read_syntax)
#define scheme_write (scheme_extension_table->scheme_write)
#define scheme_display (scheme_extension_table->scheme_display)
#define scheme_print (scheme_extension_table->scheme_print)
#define scheme_display (scheme_extension_table->scheme_display)
#define scheme_write_w_max (scheme_extension_table->scheme_write_w_max)
#define scheme_display_w_max (scheme_extension_table->scheme_display_w_max)
#define scheme_print_w_max (scheme_extension_table->scheme_print_w_max)
@ -575,6 +575,7 @@
#define scheme_make_struct_values (scheme_extension_table->scheme_make_struct_values)
#define scheme_make_struct_names (scheme_extension_table->scheme_make_struct_names)
#define scheme_make_struct_type (scheme_extension_table->scheme_make_struct_type)
#define scheme_make_struct_type2 (scheme_extension_table->scheme_make_struct_type2)
#define scheme_make_struct_instance (scheme_extension_table->scheme_make_struct_instance)
#define scheme_is_struct_instance (scheme_extension_table->scheme_is_struct_instance)
#define scheme_struct_ref (scheme_extension_table->scheme_struct_ref)

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 978
#define EXPECTED_PRIM_COUNT 980
#define EXPECTED_UNSAFE_COUNT 65
#define EXPECTED_FLFXNUM_COUNT 53

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

@ -708,19 +708,13 @@ Scheme_Object *scheme_make_struct_type_from_string(const char *base,
Scheme_Object *props,
Scheme_Object *guard,
int immutable);
Scheme_Object *scheme_make_proc_struct_type(Scheme_Object *base,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit,
Scheme_Object *uninit_val,
Scheme_Object *proc_attr,
Scheme_Object *guard);
Scheme_Object *scheme_struct_to_vector(Scheme_Object *_s, Scheme_Object *unknown_val, Scheme_Object *insp);
Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int *is_method);
Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a);
Scheme_Object *scheme_object_name(Scheme_Object *a);
Scheme_Object *scheme_is_writable_struct(Scheme_Object *s);
@ -1914,7 +1908,7 @@ Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Object *delay_load_info);
void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port, Scheme_Object *quote_depth);
Scheme_Object *scheme_read_language(Scheme_Object *port, int nonlang_ok);

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.5.4"
#define MZSCHEME_VERSION "4.2.5.5"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 5
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

74
src/mzscheme/src/struct.c
View File

@ -171,11 +171,11 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type);
#define icons scheme_make_pair
#define _intern scheme_intern_symbol
#define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET
#define LOC_STRUCT_FLAGS BUILTIN_STRUCT_FLAGS | SCHEME_STRUCT_NO_SET
#define BUILTIN_STRUCT_FLAGS SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME
#define TYPE_NAME(base, blen) make_name("struct:", base, blen, "", NULL, 0, "", 1)
#define CSTR_NAME(base, blen) make_name("make-", base, blen, "", NULL, 0, "", 1)
#define CSTR_NAME(base, blen) make_name("", base, blen, "", NULL, 0, "", 1)
#define CSTR_MAKE_NAME(base, blen) make_name("make-", base, blen, "", NULL, 0, "", 1)
#define PRED_NAME(base, blen) make_name("", base, blen, "?", NULL, 0, "", 1)
#define GET_NAME(base, blen, field, flen, sym) make_name("", base, blen, "-", field, flen, "", sym)
#define SET_NAME(base, blen, field, flen, sym) make_name("set-", base, blen, "-", field, flen, "!", sym)
@ -259,10 +259,10 @@ scheme_init_struct (Scheme_Env *env)
loc_names = scheme_make_struct_names_from_array("srcloc",
5, location_fields,
LOC_STRUCT_FLAGS, &loc_count);
BUILTIN_STRUCT_FLAGS, &loc_count);
loc_values = scheme_make_struct_values(location_struct, loc_names, loc_count,
LOC_STRUCT_FLAGS);
BUILTIN_STRUCT_FLAGS);
for (i = 0; i < loc_count - 1; i++) {
scheme_add_global_constant(scheme_symbol_val(loc_names[i]), loc_values[i],
env);
@ -405,7 +405,7 @@ scheme_init_struct (Scheme_Env *env)
REGISTER_SO(scheme_make_struct_type_proc);
scheme_make_struct_type_proc = scheme_make_prim_w_arity2(make_struct_type,
"make-struct-type",
4, 10,
4, 11,
5, 5);
scheme_add_global_constant("make-struct-type",
@ -504,7 +504,7 @@ scheme_init_struct (Scheme_Env *env)
scheme_add_global_constant("struct-type-make-constructor",
scheme_make_prim_w_arity(struct_type_constr,
"struct-type-make-constructor",
1, 1),
1, 2),
env);
scheme_add_global_constant("struct->vector",
scheme_make_prim_w_arity(struct_to_vector,
@ -1530,6 +1530,8 @@ int scheme_is_set_transformer(Scheme_Object *o)
}
static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); }
static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o)
|| scheme_check_proc_arity(NULL, 2, -1, 0, &o))); }
Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
{
@ -1537,6 +1539,14 @@ Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
return NULL;
}
static Scheme_Object *chain_transformer(void *data, int argc, Scheme_Object *argv[])
{
Scheme_Object *a[2], *v = (Scheme_Object *)data;
a[0] = SCHEME_CAR(v);
a[1] = argv[0];
return _scheme_tail_apply(SCHEME_CDR(v), 2, a);
}
Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
{
if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type))
@ -1551,6 +1561,11 @@ Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
"bad-syntax-set!-transformer",
1, 1);
}
} else if (!scheme_check_proc_arity(NULL, 1, -1, 0, &v)) {
/* Must be a procedure of 2 arguments. Reduce to a procedure of 1. */
o = scheme_make_pair(o, v);
v = scheme_make_closed_prim_w_arity(chain_transformer, (void *)o,
"set!-transformer", 1, 1);
}
return v;
}
@ -1560,8 +1575,8 @@ Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o)
static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[])
{
return check_indirect_property_value_ok("guard-for-prop:set!-transformer",
is_proc_1,
"property value is not an procedure (arity 1) or exact non-negative integer: ",
is_proc_1_or_2,
"property value is not an procedure (arity 1 or 2) or exact non-negative integer: ",
argc, argv);
}
@ -2485,9 +2500,17 @@ static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[])
else
stype = (Scheme_Struct_Type *)argv[0];
if ((argc < 2) || SCHEME_FALSEP(argv[1]))
v = CSTR_MAKE_NAME(scheme_symbol_val(stype->name), SCHEME_SYM_LEN(stype->name));
else if (SCHEME_SYMBOLP(argv[1]))
v = argv[1];
else {
scheme_wrong_type("struct-type-make-constructor", "symbol", 1, argc, argv);
return NULL;
}
v = make_struct_proc(stype,
scheme_symbol_val(CSTR_NAME(scheme_symbol_val(stype->name),
SCHEME_SYM_LEN(stype->name))),
scheme_symbol_val(v),
SCHEME_CONSTR,
stype->num_slots);
@ -3200,7 +3223,10 @@ static Scheme_Object **_make_struct_names(const char *base, int blen,
}
if (!(flags & SCHEME_STRUCT_NO_CONSTR)) {
Scheme_Object *nm;
if (flags & SCHEME_STRUCT_NO_MAKE_PREFIX)
nm = CSTR_NAME(base, blen);
else
nm = CSTR_MAKE_NAME(base, blen);
names[pos++] = nm;
}
if (!(flags & SCHEME_STRUCT_NO_PRED)) {
@ -3711,7 +3737,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
p = SCHEME_INT_VAL(proc_attr);
if (p < ni) {
if (!immutable_array) {
immutable_array= (char *)scheme_malloc_atomic(n);
immutable_array = (char *)scheme_malloc_atomic(n);
memset(immutable_array, 0, n);
}
immutable_array[p] = 1;
@ -3911,19 +3937,21 @@ Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
guard);
}
Scheme_Object *scheme_make_proc_struct_type(Scheme_Object *base,
Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit,
Scheme_Object *uninit_val,
Scheme_Object *properties,
Scheme_Object *proc_attr,
char *immutable_array,
Scheme_Object *guard)
{
return _make_struct_type(base,
parent, inspector,
num_fields, num_uninit,
uninit_val, scheme_null,
proc_attr, NULL,
uninit_val, properties,
proc_attr, immutable_array,
guard);
}
@ -4045,7 +4073,7 @@ static char* immutable_pos_list_to_immutable_array(Scheme_Object *immutable_pos_
static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
{
int initc, uninitc, num_props = 0, prefab = 0;
Scheme_Object *props = scheme_null, *l, *a, **r;
Scheme_Object *props = scheme_null, *l, *a, **r, *cstr_name = NULL;
Scheme_Object *inspector = NULL, *uninit_val;
Scheme_Struct_Type *type;
Scheme_Object *proc_attr = NULL, *immutable_pos_list = scheme_null, *guard = NULL;
@ -4133,6 +4161,14 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
if (!SCHEME_PROCP(guard))
scheme_wrong_type("make-struct-type", "procedure or #f", 9, argc, argv);
}
if (argc > 10) {
if (!SCHEME_FALSEP(argv[10])) {
if (!SCHEME_SYMBOLP(argv[10]))
scheme_wrong_type("make-struct-type", "symbol or #f", 10, argc, argv);
cstr_name = argv[10];
}
}
}
}
}
@ -4177,8 +4213,7 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
initc, uninitc,
uninit_val,
immutable_array);
}
else {
} else {
type = (Scheme_Struct_Type *)_make_struct_type(argv[0],
SCHEME_FALSEP(argv[1]) ? NULL : argv[1],
inspector,
@ -4188,6 +4223,7 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
immutable_array,
guard);
}
{
int i;
Scheme_Object **names;
@ -4196,6 +4232,8 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
NULL,
SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET,
&i);
if (cstr_name)
names[1] = cstr_name;
r = scheme_make_struct_values((Scheme_Object *)type, names, i,
SCHEME_STRUCT_GEN_GET | SCHEME_STRUCT_GEN_SET);

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

@ -6624,6 +6624,8 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_PRINT_UNREADABLE, scheme_true);
init_param(cells, paramz, MZCONFIG_PRINT_PAIR_CURLY, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_MPAIR_CURLY, scheme_true);
init_param(cells, paramz, MZCONFIG_PRINT_READER, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_AS_QQ, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_SYNTAX_WIDTH, scheme_make_integer(32));
init_param(cells, paramz, MZCONFIG_HONU_MODE, scheme_false);