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

* moved gensym->unique-string, gensym-prefix, gensym-count, and 

print-gensym to (ikarus symbols)
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 06:51:33 -04:00
parent 52b3c67c06
commit 4a0db4a117
3 changed files with 50 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

45
src/ikarus.core.ss
View File

@ -53,51 +53,6 @@
(primitive-set! 'gensym->unique-string
(lambda (x)
(unless (symbol? x)
(error 'gensym->unique-string "~s is not a gensym" x))
(let ([us ($symbol-unique-string x)])
(cond
[(string? us) us]
[(not us)
(error 'gensym->unique-string "~s is not a gensym" x)]
[else
(let f ([x x])
(let ([id (uuid)])
($set-symbol-unique-string! x id)
(cond
[(foreign-call "ikrt_intern_gensym" x) id]
[else (f x)])))]))))
(primitive-set! 'gensym-prefix
(make-parameter
"g"
(lambda (x)
(unless (string? x)
(error 'gensym-prefix "~s is not a string" x))
x)))
(primitive-set! 'gensym-count
(make-parameter
0
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'gensym-count "~s is not a valid count" x))
x)))
(primitive-set! 'print-gensym
(make-parameter
#t
(lambda (x)
(unless (or (boolean? x) (eq? x 'pretty))
(error 'print-gensym "~s is not in #t|#f|pretty" x))
x)))
(primitive-set! 'pointer-value
(lambda (x)

58
src/ikarus.symbols.ss
View File

@ -1,15 +1,16 @@
(library (ikarus symbols)
(export gensym gensym?
string->symbol
getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value!)
(export gensym gensym? gensym->unique-string gensym-prefix
gensym-count print-gensym string->symbol
getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value!)
(import
(only (scheme) $make-symbol $symbol-string $symbol-unique-string
$symbol-value $set-symbol-value! $set-symbol-plist!
$symbol-plist
$car $cdr $set-cdr! $unbound-object?)
(except (ikarus) gensym gensym?
$set-symbol-unique-string! $symbol-value $set-symbol-value!
$set-symbol-plist! $symbol-plist
$car $cdr $fx>= $set-cdr! $unbound-object?)
(except (ikarus) gensym gensym? gensym->unique-string
gensym-prefix gensym-count print-gensym
string->symbol
getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value!))
@ -110,5 +111,46 @@
(cons ($car a) (cons ($cdr a) ac))))]))])
(f ($symbol-plist x) '()))))
(define gensym->unique-string
(lambda (x)
(unless (symbol? x)
(error 'gensym->unique-string "~s is not a gensym" x))
(let ([us ($symbol-unique-string x)])
(cond
[(string? us) us]
[(not us)
(error 'gensym->unique-string "~s is not a gensym" x)]
[else
(let f ([x x])
(let ([id (uuid)])
($set-symbol-unique-string! x id)
(cond
[(foreign-call "ikrt_intern_gensym" x) id]
[else (f x)])))]))))
(define gensym-prefix
(make-parameter
"g"
(lambda (x)
(unless (string? x)
(error 'gensym-prefix "~s is not a string" x))
x)))
(define gensym-count
(make-parameter
0
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'gensym-count "~s is not a valid count" x))
x)))
(define print-gensym
(make-parameter
#t
(lambda (x)
(unless (or (boolean? x) (eq? x 'pretty))
(error 'print-gensym "~s is not in #t|#f|pretty" x))
x)))
)