conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

removed all unsafe-record code

This commit is contained in:
Abdulaziz Ghuloum 2006-12-05 14:00:31 -05:00
parent bbf0936963
commit 1c35c6939d
4 changed files with 0 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

1
lib/libchezio.ss
View File

@ -1,7 +1,6 @@
(let ()
(include "unsafe-record.ss")
;;;
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;

52
lib/psyntax-7.1.ss
View File

@ -4638,58 +4638,6 @@
"~s is not a record of type ~s" x 'rtd)))) ...
)))])))
(define-syntax $define-record-syntax
(lambda (x)
(syntax-case x ()
[(_ name (field* ...))
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
[fields (syntax-object->datum #'(field* ...))]
[fieldstr* (map symbol->string fields)]
[rtd (make-record-type namestr fields)])
(with-syntax ([constr
(datum->syntax-object #'name
(string->symbol
(string-append "make-" namestr)))]
[pred
(datum->syntax-object #'name
(string->symbol
(string-append namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append namestr "-" x)))
fieldstr*))]
[(setters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append "set-" namestr "-" x "!")))
fieldstr*))]
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define-syntax constr
(syntax-rules ()
[(_ field* ...) ($record 'rtd field* ...)]))
(define-syntax pred
(syntax-rules ()
[(_ x) ($record/rtd? x 'rtd)]))
(define-syntax getters
(syntax-rules ()
[(_ x) ($record-ref x i)])) ...
(define-syntax setters
(syntax-rules ()
[(_ x v) ($record-set! x i v)])) ...
)))])))
(define-syntax trace
(lambda (x)
(syntax-case x ()

51
lib/unsafe-record.ss
View File

@ -1,51 +0,0 @@
(define-syntax $define-record-syntax
(lambda (x)
(syntax-case x ()
[(_ name (field* ...))
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
[fields (syntax-object->datum #'(field* ...))]
[fieldstr* (map symbol->string fields)]
[rtd (make-record-type namestr fields)])
(with-syntax ([constr
(datum->syntax-object #'name
(string->symbol
(string-append "$make-" namestr)))]
[pred
(datum->syntax-object #'name
(string->symbol
(string-append "$" namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append "$" namestr "-" x)))
fieldstr*))]
[(setters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append "$set-" namestr "-" x "!")))
fieldstr*))]
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define-syntax constr
(syntax-rules ()
[(_ field* ...) ($record 'rtd field* ...)]))
(define-syntax pred
(syntax-rules ()
[(_ x) ($record/rtd? x 'rtd)]))
(define-syntax getters
(syntax-rules ()
[(_ x) ($record-ref x i)])) ...
(define-syntax setters
(syntax-rules ()
[(_ x v) ($record-set! x i v)])) ...
)))])))