.
original commit: e9b58213637cefa6278641a1c7299fd738e0c5d6
This commit is contained in:
parent
62593d59ea
commit
8b5f4ecde1
|
@ -7,6 +7,7 @@
|
|||
(provide class
|
||||
class*
|
||||
class?
|
||||
mixin
|
||||
interface interface?
|
||||
object% object?
|
||||
object=?
|
||||
|
|
|
@ -678,7 +678,8 @@ add struct contracts for immutable structs?
|
|||
(string-append one-line " ")
|
||||
(let ([sp (open-output-string)])
|
||||
(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))
|
||||
(get-output-string sp))))]
|
||||
[specific-blame
|
||||
|
|
|
@ -1,14 +1,18 @@
|
|||
|
||||
(module etc mzscheme
|
||||
|
||||
(require "spidey.ss"
|
||||
(lib "plthome.ss" "setup"))
|
||||
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
(lib "context.ss" "syntax")
|
||||
(lib "plthome.ss" "setup")
|
||||
"list.ss"
|
||||
"private/stxset.ss")
|
||||
|
||||
|
||||
(provide true false
|
||||
boolean=? symbol=?
|
||||
identity
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
|
||||
;; by Jacob Matthews
|
||||
;; by Jacob Matthews (and others)
|
||||
|
||||
(module struct mzscheme
|
||||
(provide copy-struct)
|
||||
|
||||
(provide copy-struct make-->vector)
|
||||
(require-for-syntax (lib "struct.ss" "syntax")
|
||||
"list.ss"
|
||||
(lib "stx.ss" "syntax"))
|
||||
|
||||
;; copy-struct expands to `do-copy-struct' to delay the expansion
|
||||
|
@ -70,6 +70,23 @@
|
|||
#,@(map
|
||||
(lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
|
||||
(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