.
original commit: e9b58213637cefa6278641a1c7299fd738e0c5d6
This commit is contained in:
parent
62593d59ea
commit
8b5f4ecde1
|
@ -7,6 +7,7 @@
|
||||||
(provide class
|
(provide class
|
||||||
class*
|
class*
|
||||||
class?
|
class?
|
||||||
|
mixin
|
||||||
interface interface?
|
interface interface?
|
||||||
object% object?
|
object% object?
|
||||||
object=?
|
object=?
|
||||||
|
|
|
@ -678,7 +678,8 @@ add struct contracts for immutable structs?
|
||||||
(string-append one-line " ")
|
(string-append one-line " ")
|
||||||
(let ([sp (open-output-string)])
|
(let ([sp (open-output-string)])
|
||||||
(newline sp)
|
(newline sp)
|
||||||
(parameterize ([pretty-print-print-line print-contract-liner])
|
(parameterize ([pretty-print-print-line print-contract-liner]
|
||||||
|
[pretty-print-columns 50])
|
||||||
(pretty-print contract-sexp sp))
|
(pretty-print contract-sexp sp))
|
||||||
(get-output-string sp))))]
|
(get-output-string sp))))]
|
||||||
[specific-blame
|
[specific-blame
|
||||||
|
|
|
@ -1,14 +1,18 @@
|
||||||
|
|
||||||
(module etc mzscheme
|
(module etc mzscheme
|
||||||
|
|
||||||
(require "spidey.ss"
|
(require "spidey.ss"
|
||||||
(lib "plthome.ss" "setup"))
|
(lib "plthome.ss" "setup"))
|
||||||
|
|
||||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||||
(lib "stx.ss" "syntax")
|
(lib "stx.ss" "syntax")
|
||||||
(lib "name.ss" "syntax")
|
(lib "name.ss" "syntax")
|
||||||
(lib "context.ss" "syntax")
|
(lib "context.ss" "syntax")
|
||||||
(lib "plthome.ss" "setup")
|
(lib "plthome.ss" "setup")
|
||||||
|
"list.ss"
|
||||||
"private/stxset.ss")
|
"private/stxset.ss")
|
||||||
|
|
||||||
|
|
||||||
(provide true false
|
(provide true false
|
||||||
boolean=? symbol=?
|
boolean=? symbol=?
|
||||||
identity
|
identity
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
|
|
||||||
;; by Jacob Matthews
|
;; by Jacob Matthews (and others)
|
||||||
|
|
||||||
(module struct mzscheme
|
(module struct mzscheme
|
||||||
(provide copy-struct)
|
(provide copy-struct make-->vector)
|
||||||
|
|
||||||
(require-for-syntax (lib "struct.ss" "syntax")
|
(require-for-syntax (lib "struct.ss" "syntax")
|
||||||
|
"list.ss"
|
||||||
(lib "stx.ss" "syntax"))
|
(lib "stx.ss" "syntax"))
|
||||||
|
|
||||||
;; copy-struct expands to `do-copy-struct' to delay the expansion
|
;; copy-struct expands to `do-copy-struct' to delay the expansion
|
||||||
|
@ -70,6 +70,23 @@
|
||||||
#,@(map
|
#,@(map
|
||||||
(lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
|
(lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
|
||||||
(reverse accessors)))
|
(reverse accessors)))
|
||||||
(raise-type-error '_ #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))])))
|
(raise-type-error '_ #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))]))
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax (make-->vector stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ name) ; a struct type name
|
||||||
|
(identifier? (syntax name))
|
||||||
|
(let ([info (syntax-local-value (syntax name))])
|
||||||
|
(if (struct-declaration-info? info)
|
||||||
|
(with-syntax ([(accessor ...)
|
||||||
|
(reverse
|
||||||
|
(filter identifier? (list-ref info 3)))])
|
||||||
|
(syntax
|
||||||
|
(λ (s)
|
||||||
|
(vector (accessor s) ...))))
|
||||||
|
(raise-syntax-error
|
||||||
|
#f
|
||||||
|
"not a declared structure type name"
|
||||||
|
stx
|
||||||
|
(syntax name))))])))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user