suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

checkpoint GUI reference work

Browse Source 
svn: r7086

original commit: 0b29e215cb50c90986d999e14ba200b89d1234d1
This commit is contained in:
Matthew Flatt 2007-08-13 15:56:03 +00:00
parent fe85409392
commit 362c312033
1 changed files with 70 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
collects/scribble/manual.ss
View File

@ -181,7 +181,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(provide method xmethod) (provide method xmethod (rename method ::))
(define-syntax method (define-syntax method
(syntax-rules () (syntax-rules ()
@ -269,7 +269,7 @@
(make-element "schememeta" (list "...+"))) (make-element "schememeta" (list "...+")))
(define-syntax (arg-contract stx) (define-syntax (arg-contract stx)
(syntax-case stx (... ...+) (syntax-case stx (... ...+ _...superclass-args...)
[(_ [id contract]) [(_ [id contract])
(identifier? #'id) (identifier? #'id)
#'(schemeblock0 contract)] #'(schemeblock0 contract)]
@ -288,6 +288,8 @@
#'#f] #'#f]
[(_ (... ...+)) [(_ (... ...+))
#'#f] #'#f]
[(_ _...superclass-args...)
#'#f]
[(_ arg) [(_ arg)
(raise-syntax-error (raise-syntax-error
'defproc 'defproc
@ -549,6 +551,11 @@
(list (scheme new) (list (scheme new)
(hspace 1) (hspace 1)
(to-element within-id)))] (to-element within-id)))]
[(eq? mode 'make)
(make-element #f
(list (scheme make-object)
(hspace 1)
(to-element within-id)))]
[(eq? mode 'send) [(eq? mode 'send)
(make-element #f (make-element #f
(list (scheme send) (list (scheme send)
@ -556,22 +563,30 @@
(to-element (string->symbol (to-element (string->symbol
(regexp-replace (regexp-replace
#rx"(%|<%>|-mixin)$" #rx"(%|<%>|-mixin)$"
(format "a-~s" (syntax-e within-id)) (format "a~a-~s"
(if (member
(string-ref (symbol->string (syntax-e within-id)) 0)
'(#\a #\e #\i #\o #\u))
"n"
"")
(syntax-e within-id))
""))) "")))
(hspace 1) (hspace 1)
(let* ([mname (car prototype)] (if first?
[tag (format "~a::~a" (let* ([mname (car prototype)]
(register-scheme-definition within-id) [tag (format "~a::~a"
mname)] (register-scheme-definition within-id)
[content (list (*method mname within-id))]) mname)]
(make-toc-target-element [content (list (*method mname within-id))])
#f (make-toc-target-element
(list (make-index-element #f #f
content (list (make-index-element #f
tag content
(list (symbol->string mname)) tag
content)) (list (symbol->string mname))
tag))))] content))
tag))
(*method (car prototype) within-id))))]
[else [else
(if first? (if first?
(let ([tag (register-scheme-definition stx-id)] (let ([tag (register-scheme-definition stx-id)]
@ -594,7 +609,8 @@
[(res) (result-contract)] [(res) (result-contract)]
[(result-next-line?) ((+ (if short? [(result-next-line?) ((+ (if short?
flat-size flat-size
(prototype-size prototype + max)) (+ (prototype-size (cdr prototype) max max)
(element-width tagged)))
(flow-element-width res)) (flow-element-width res))
. >= . (- max-proto-width 7))] . >= . (- max-proto-width 7))]
[(end) (list (to-flow spacer) [(end) (list (to-flow spacer)
@ -1198,6 +1214,9 @@
(provide defclass (provide defclass
definterface definterface
defconstructor defconstructor
defconstructor/make
defconstructor*/make
defconstructor/auto-super
defmethod defmethod
defmethod* defmethod*
methspec methspec
@ -1312,12 +1331,12 @@
(list (quote-syntax intf) ...))) (list (quote-syntax intf) ...)))
(list body ...))))])) (list body ...))))]))
(define-syntax (defconstructor stx) (define-syntax (defconstructor*/* stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([id . arg-rest] ...) desc ...) [(_ mode ((arg ...) ...) desc ...)
(let ([n (syntax-parameter-value #'current-class)]) (let ([n (syntax-parameter-value #'current-class)])
(with-syntax ([name n] (with-syntax ([name n]
[result (let ([s (quote-syntax (is-a/c n))]) [result (let ([s (quote-syntax (is-a/c nm))])
(datum->syntax-object s (datum->syntax-object s
(let ([l (syntax->list s)]) (let ([l (syntax->list s)])
(cons (car l) (cons (car l)
@ -1325,13 +1344,40 @@
(syntax-e n) (syntax-e n)
(cadr l))))) (cadr l)))))
s))] s))]
[(kw ...) (map (lambda (id) [(((kw ...) ...) ...) (map (lambda (ids)
(string->keyword (symbol->string (syntax-e id)))) (map (lambda (arg)
(syntax->list #'(id ...)))]) (if (and (pair? (syntax-e arg))
(eq? (syntax-e #'mode) 'new))
(list (string->keyword (symbol->string
(syntax-e
(car (syntax-e arg))))))
null))
(syntax->list ids)))
(syntax->list #'((arg ...) ...)))])
#'(make-constructor (lambda () #'(make-constructor (lambda ()
(defproc* #:mode new #:within name [[(make [kw id . arg-rest] ...) result]] (defproc* #:mode mode #:within name [[(make [kw ... . arg] ...) result] ...]
desc ...)))))])) desc ...)))))]))
(define-syntax (defconstructor stx)
(syntax-case stx ()
[(_ ([id . arg-rest] ...) desc ...)
#'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)]))
(define-syntax (defconstructor/make stx)
(syntax-case stx ()
[(_ ([id . arg-rest] ...) desc ...)
#'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)]))
(define-syntax (defconstructor*/make stx)
(syntax-case stx ()
[(_ (([id . arg-rest] ...) ...) desc ...)
#'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)]))
(define-syntax (defconstructor/auto-super stx)
(syntax-case stx ()
[(_ ([id . arg-rest] ...) desc ...)
#'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) desc ...)]))
(define-syntax (defmethod* stx) (define-syntax (defmethod* stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:mode mode ([(name arg ...) result-type] ...) desc ...) [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...)