From 2273e5313b11211fc0f8914131e6738b43fbc1a1 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Mon, 6 May 2019 21:57:03 +0200
Subject: [PATCH] Make keywords distinct from symbols at the Scheme level
Having keywords as a subtype of symbols is problematic. This is most
obvious with identifiers, which may be any symbol, but cannot be
keywords. Keywords also no longer have plists, so it makes less and
less sense to treat these two object types as almost the same.
There are several Schemes which treat them as distinct types. Having
keywords be a subtype of symbols is more of a old school Lisp thing,
like treating () and 'nil as the same, falsy values. It's cleaner to
separate them, this also allows the scrutinizer to treat them more
cleanly as different things.
---
NEWS | 6 ++++++
c-backend.scm | 5 +++--
chicken.h | 22 ++++++++++++++--------
core.scm | 6 +-----
expand.scm | 2 +-
extras.scm | 6 +++---
lfa2.scm | 7 ++++++-
library.scm | 39 +++++++++++++++++++++------------------
runtime.c | 22 +++++++++++++---------
scrutinizer.scm | 10 +++++++---
synrules.scm | 15 ++++++---------
tests/library-tests.scm | 14 ++++++++++----
tests/version-tests.scm | 6 +++---
types.db | 16 ++++++++--------
14 files changed, 102 insertions(+), 74 deletions(-)
diff --git a/NEWS b/NEWS
index c37366f2..54c87cf6 100644
a
|
b
|
|
| 1 | 5.0.3 |
| 2 | |
| 3 | - Runtime system |
| 4 | - Keywords are now distinct types; they are not a subtype of symbols. |
| 5 | |
| 6 | |
1 | 7 | 5.0.2 |
2 | 8 | |
3 | 9 | - Core libraries |
diff --git a/c-backend.scm b/c-backend.scm
index 037eab3e..a6942c47 100644
a
|
b
|
|
705 | 705 | ((bignum? lit) 2) ; internal vector statically allocated |
706 | 706 | ((flonum? lit) words-per-flonum) |
707 | 707 | ((symbol? lit) 7) ; size of symbol, and possibly a bucket |
| 708 | ((keyword? lit) 7) ; size of keyword (symbol), and possibly a bucket |
708 | 709 | ((pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))) |
709 | 710 | ((vector? lit) |
710 | 711 | (+ 1 (vector-length lit) |
… |
… |
|
739 | 740 | (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) ) |
740 | 741 | ((char? lit) |
741 | 742 | (gen #t to "=C_make_character(" (char->integer lit) ");") ) |
742 | | ((symbol? lit) ; handled slightly specially (see C_h_intern_in) |
| 743 | ((or (keyword? lit) (symbol? lit)) ; handled slightly specially (see C_h_intern_in) |
743 | 744 | (let* ((str (##sys#slot lit 1)) |
744 | 745 | (cstr (c-ify-string str)) |
745 | 746 | (len (##sys#size str)) |
… |
… |
return((C_header_bits(lit) >> 24) & 0xff); |
1484 | 1485 | (string-append "\xc2" (encode-size (string-length str)) str))) |
1485 | 1486 | ((flonum? lit) |
1486 | 1487 | (string-append "\x55" (number->string lit) "\x00") ) |
1487 | | ((symbol? lit) |
| 1488 | ((or (keyword? lit) (symbol? lit)) |
1488 | 1489 | (let ((str (##sys#slot lit 1))) |
1489 | 1490 | (string-append |
1490 | 1491 | "\x01" |
diff --git a/chicken.h b/chicken.h
index 20dab23e..c73bb03c 100644
a
|
b
|
void *alloca (); |
583 | 583 | #define C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR 2 |
584 | 584 | #define C_BAD_ARGUMENT_TYPE_ERROR 3 |
585 | 585 | #define C_UNBOUND_VARIABLE_ERROR 4 |
586 | | #define C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR 5 |
| 586 | #define C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR 5 |
587 | 587 | #define C_OUT_OF_MEMORY_ERROR 6 |
588 | 588 | #define C_DIVISION_BY_ZERO_ERROR 7 |
589 | 589 | #define C_OUT_OF_RANGE_ERROR 8 |
… |
… |
typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret; |
1388 | 1388 | #define C_i_check_number(x) C_i_check_number_2(x, C_SCHEME_FALSE) |
1389 | 1389 | #define C_i_check_string(x) C_i_check_string_2(x, C_SCHEME_FALSE) |
1390 | 1390 | #define C_i_check_bytevector(x) C_i_check_bytevector_2(x, C_SCHEME_FALSE) |
| 1391 | #define C_i_check_keyword(x) C_i_check_keyword_2(x, C_SCHEME_FALSE) |
1391 | 1392 | #define C_i_check_symbol(x) C_i_check_symbol_2(x, C_SCHEME_FALSE) |
1392 | 1393 | #define C_i_check_list(x) C_i_check_list_2(x, C_SCHEME_FALSE) |
1393 | 1394 | #define C_i_check_pair(x) C_i_check_pair_2(x, C_SCHEME_FALSE) |
… |
… |
C_fctexport C_word C_fcall C_i_check_number_2(C_word x, C_word loc) C_regparm; |
2008 | 2009 | C_fctexport C_word C_fcall C_i_check_string_2(C_word x, C_word loc) C_regparm; |
2009 | 2010 | C_fctexport C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc) C_regparm; |
2010 | 2011 | C_fctexport C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) C_regparm; |
| 2012 | C_fctexport C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc) C_regparm; |
2011 | 2013 | C_fctexport C_word C_fcall C_i_check_list_2(C_word x, C_word loc) C_regparm; |
2012 | 2014 | C_fctexport C_word C_fcall C_i_check_pair_2(C_word x, C_word loc) C_regparm; |
2013 | 2015 | C_fctexport C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc) C_regparm; |
… |
… |
inline static C_word C_u_i_namespaced_symbolp(C_word x) |
2194 | 2196 | return C_mk_bool(C_memchr(C_data_pointer(s), '#', C_header_size(s))); |
2195 | 2197 | } |
2196 | 2198 | |
2197 | | inline static C_word C_u_i_keywordp(C_word x) |
2198 | | { |
2199 | | return C_mk_bool(C_symbol_plist(x) == C_SCHEME_FALSE); |
2200 | | } |
2201 | | |
2202 | 2199 | inline static C_word C_flonum(C_word **ptr, double n) |
2203 | 2200 | { |
2204 | 2201 | C_word |
… |
… |
inline static C_word C_i_eqvp(C_word x, C_word y) |
2653 | 2650 | |
2654 | 2651 | inline static C_word C_i_symbolp(C_word x) |
2655 | 2652 | { |
2656 | | return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG); |
| 2653 | return C_mk_bool(!C_immediatep(x) && |
| 2654 | C_block_header(x) == C_SYMBOL_TAG && |
| 2655 | C_symbol_plist(x) != C_SCHEME_FALSE); |
| 2656 | } |
| 2657 | |
| 2658 | inline static C_word C_i_keywordp(C_word x) |
| 2659 | { |
| 2660 | return C_mk_bool(!C_immediatep(x) && |
| 2661 | C_block_header(x) == C_SYMBOL_TAG && |
| 2662 | C_symbol_plist(x) == C_SCHEME_FALSE); |
2657 | 2663 | } |
2658 | 2664 | |
2659 | 2665 | inline static int C_persistable_symbol(C_word x) |
… |
… |
inline static int C_persistable_symbol(C_word x) |
2661 | 2667 | /* Symbol is bound, or has a non-empty plist (but is not a keyword) */ |
2662 | 2668 | return ((C_truep(C_boundp(x)) || |
2663 | 2669 | C_symbol_plist(x) != C_SCHEME_END_OF_LIST) && |
2664 | | !C_truep(C_u_i_keywordp(x))); |
| 2670 | C_symbol_plist(x) != C_SCHEME_FALSE); |
2665 | 2671 | } |
2666 | 2672 | |
2667 | 2673 | inline static C_word C_i_pairp(C_word x) |
diff --git a/core.scm b/core.scm
index c4aa81bc..d9aa8a4c 100644
a
|
b
|
|
524 | 524 | (else (find-id id (cdr se))))) |
525 | 525 | |
526 | 526 | (define (lookup id) |
527 | | (cond ((keyword? id) id) |
| 527 | (cond ((keyword? id) id) ; DEPRECATED |
528 | 528 | ((find-id id (##sys#current-environment))) |
529 | 529 | ((##sys#get id '##core#macro-alias) symbol? => values) |
530 | 530 | (else id))) |
… |
… |
|
1145 | 1145 | ((assq var0 (##sys#current-environment)) |
1146 | 1146 | (warning |
1147 | 1147 | (sprintf "~aassignment to imported value binding `~S'" |
1148 | | (if ln (sprintf "(~a) - " ln) "") var0))) |
1149 | | ((keyword? var0) |
1150 | | (warning |
1151 | | (sprintf "~aassignment to keyword `~S'" |
1152 | 1148 | (if ln (sprintf "(~a) - " ln) "") var0))))) |
1153 | 1149 | `(set! ,var ,(walk val e var0 (memq var e) h ln #f)))))) |
1154 | 1150 | |
diff --git a/expand.scm b/expand.scm
index baaa133c..0ce8b505 100644
a
|
b
|
|
771 | 771 | (else #f) ) ) ) ) |
772 | 772 | |
773 | 773 | (define (variable? v) |
774 | | (and (symbol? v) (not (##core#inline "C_u_i_keywordp" v)))) |
| 774 | (symbol? v)) |
775 | 775 | |
776 | 776 | (define (proper-list? x) |
777 | 777 | (let loop ((x x)) |
diff --git a/extras.scm b/extras.scm
index 3449294e..535e499f 100644
a
|
b
|
|
248 | 248 | (module chicken.pretty-print |
249 | 249 | (pp pretty-print pretty-print-width) |
250 | 250 | |
251 | | (import scheme chicken.base chicken.fixnum chicken.string) |
| 251 | (import scheme chicken.base chicken.fixnum chicken.keyword chicken.string) |
252 | 252 | |
253 | 253 | (define generic-write |
254 | 254 | (lambda (obj display? width output) |
… |
… |
|
298 | 298 | ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) |
299 | 299 | ((boolean? obj) (out (if obj "#t" "#f") col)) |
300 | 300 | ((##sys#number? obj) (out (##sys#number->string obj) col)) |
301 | | ((symbol? obj) |
302 | | (let ([s (open-output-string)]) |
| 301 | ((or (keyword? obj) (symbol? obj)) |
| 302 | (let ((s (open-output-string))) |
303 | 303 | (##sys#print obj #t s) |
304 | 304 | (out (get-output-string s) col) ) ) |
305 | 305 | ((procedure? obj) (out (##sys#procedure->string obj) col)) |
diff --git a/lfa2.scm b/lfa2.scm
index 1fba207c..b1147a4a 100644
a
|
b
|
|
45 | 45 | chicken.base |
46 | 46 | chicken.compiler.support |
47 | 47 | chicken.fixnum |
48 | | chicken.format) |
| 48 | chicken.format |
| 49 | chicken.keyword) |
49 | 50 | |
50 | 51 | (include "tweaks") |
51 | 52 | (include "mini-srfi-1.scm") |
… |
… |
|
61 | 62 | ("C_i_check_string" string) |
62 | 63 | ("C_i_check_bytevector" blob) |
63 | 64 | ("C_i_check_symbol" symbol) |
| 65 | ("C_i_check_keyword" keyword) |
64 | 66 | ("C_i_check_list" null pair list) |
65 | 67 | ("C_i_check_pair" pair) |
66 | 68 | ("C_i_check_locative" locative) |
… |
… |
|
75 | 77 | ("C_i_check_string_2" string) |
76 | 78 | ("C_i_check_bytevector_2" blob) |
77 | 79 | ("C_i_check_symbol_2" symbol) |
| 80 | ("C_i_check_keyword_2" keyword) |
78 | 81 | ("C_i_check_list_2" null pair list) |
79 | 82 | ("C_i_check_pair_2" pair) |
80 | 83 | ("C_i_check_locative_2" locative) |
… |
… |
|
97 | 100 | ("C_i_cplxnump" cplxnum) |
98 | 101 | ("C_stringp" string) |
99 | 102 | ("C_bytevectorp" blob) |
| 103 | ("C_i_keywordp" keyword) |
100 | 104 | ("C_i_symbolp" symbol) |
101 | 105 | ("C_i_listp" list) |
102 | 106 | ("C_i_pairp" pair) |
… |
… |
|
235 | 239 | (define (constant-result lit) |
236 | 240 | ;; a simplified variant of the one in scrutinizer.scm |
237 | 241 | (cond ((string? lit) 'string) |
| 242 | ((keyword? lit) 'keyword) |
238 | 243 | ((symbol? lit) 'symbol) |
239 | 244 | ;; Do not assume fixnum width matches target platforms! |
240 | 245 | ((or (big-fixnum? lit) (small-bignum? lit)) 'integer) |
diff --git a/library.scm b/library.scm
index c7ce2b5a..0f329199 100644
a
|
b
|
EOF |
1156 | 1156 | (##core#inline "C_i_check_symbol_2" x (car loc)) |
1157 | 1157 | (##core#inline "C_i_check_symbol" x) ) ) |
1158 | 1158 | |
| 1159 | (define (##sys#check-keyword x . loc) |
| 1160 | (if (pair? loc) |
| 1161 | (##core#inline "C_i_check_keyword_2" x (car loc)) |
| 1162 | (##core#inline "C_i_check_keyword" x) ) ) |
| 1163 | |
1159 | 1164 | (define (##sys#check-vector x . loc) |
1160 | 1165 | (if (pair? loc) |
1161 | 1166 | (##core#inline "C_i_check_vector_2" x (car loc)) |
… |
… |
EOF |
2729 | 2734 | (import scheme) |
2730 | 2735 | (import chicken.fixnum) |
2731 | 2736 | |
2732 | | (define (keyword? x) |
2733 | | (and (symbol? x) (##core#inline "C_u_i_keywordp" x)) ) |
| 2737 | (define (keyword? x) (##core#inline "C_i_keywordp" x) ) |
2734 | 2738 | |
2735 | 2739 | (define string->keyword |
2736 | 2740 | (let ([string string] ) |
… |
… |
EOF |
2748 | 2752 | (define get-keyword |
2749 | 2753 | (let ((tag (list 'tag))) |
2750 | 2754 | (lambda (key args #!optional thunk) |
| 2755 | (##sys#check-keyword key 'get-keyword) |
2751 | 2756 | (##sys#check-list args 'get-keyword) |
2752 | 2757 | (let ((r (##core#inline "C_i_get_keyword" key args tag))) |
2753 | 2758 | (if (eq? r tag) ; not found |
… |
… |
EOF |
4539 | 4544 | ((##core#inline "C_unboundvaluep" x) (outstr port "#<unbound value>")) |
4540 | 4545 | ((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>")) |
4541 | 4546 | ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>")) |
4542 | | ((##core#inline "C_symbolp" x) |
4543 | | (cond ((##core#inline "C_u_i_keywordp" x) |
4544 | | ;; Force portable #: style for readable output |
4545 | | (case (and (not readable) ksp) |
4546 | | ((#:prefix) |
4547 | | (outchr port #\:) |
4548 | | (outsym port x)) |
4549 | | ((#:suffix) |
4550 | | (outsym port x) |
4551 | | (outchr port #\:)) |
4552 | | (else |
4553 | | (outstr port "#:") |
4554 | | (outsym port x)))) |
4555 | | (else |
4556 | | (outsym port x)))) |
| 4547 | ((##core#inline "C_i_keywordp" x) |
| 4548 | ;; Force portable #: style for readable output |
| 4549 | (case (and (not readable) ksp) |
| 4550 | ((#:prefix) |
| 4551 | (outchr port #\:) |
| 4552 | (outsym port x)) |
| 4553 | ((#:suffix) |
| 4554 | (outsym port x) |
| 4555 | (outchr port #\:)) |
| 4556 | (else |
| 4557 | (outstr port "#:") |
| 4558 | (outsym port x)))) |
| 4559 | ((##core#inline "C_i_symbolp" x) (outsym port x)) |
4557 | 4560 | ((##sys#number? x) (outstr port (##sys#number->string x))) |
4558 | 4561 | ((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x))) |
4559 | 4562 | ((##core#inline "C_stringp" x) |
… |
… |
EOF |
5377 | 5380 | (if fn (list fn) '())))) |
5378 | 5381 | ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args)) |
5379 | 5382 | ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args)) |
5380 | | ((5) (apply ##sys#signal-hook #:type-error loc "symbol is a keyword, which has no plist" args)) |
| 5383 | ((5) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a keyword" args)) |
5381 | 5384 | ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args)) |
5382 | 5385 | ((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args)) |
5383 | 5386 | ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args)) |
diff --git a/runtime.c b/runtime.c
index 5638df55..05ab5f7b 100644
a
|
b
|
void barf(int code, char *loc, ...) |
1693 | 1693 | c = 1; |
1694 | 1694 | break; |
1695 | 1695 | |
1696 | | case C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR: |
1697 | | msg = C_text("symbol is a keyword, which has no plist"); |
| 1696 | case C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR: |
| 1697 | msg = C_text("bad argument type - not a keyword"); |
1698 | 1698 | c = 1; |
1699 | 1699 | break; |
1700 | 1700 | |
… |
… |
C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc) |
7408 | 7408 | |
7409 | 7409 | C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) |
7410 | 7410 | { |
7411 | | if(C_immediatep(x) || C_block_header(x) != C_SYMBOL_TAG) { |
| 7411 | if(!C_truep(C_i_symbolp(x))) { |
7412 | 7412 | error_location = loc; |
7413 | 7413 | barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x); |
7414 | 7414 | } |
… |
… |
C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) |
7417 | 7417 | } |
7418 | 7418 | |
7419 | 7419 | |
| 7420 | C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc) |
| 7421 | { |
| 7422 | if(!C_truep(C_i_keywordp(x))) { |
| 7423 | error_location = loc; |
| 7424 | barf(C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR, NULL, x); |
| 7425 | } |
| 7426 | |
| 7427 | return C_SCHEME_UNDEFINED; |
| 7428 | } |
| 7429 | |
7420 | 7430 | C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc) |
7421 | 7431 | { |
7422 | 7432 | if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) { |
… |
… |
C_i_getprop(C_word sym, C_word prop, C_word def) |
12837 | 12847 | { |
12838 | 12848 | C_word pl = C_symbol_plist(sym); |
12839 | 12849 | |
12840 | | if (pl == C_SCHEME_FALSE) |
12841 | | barf(C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR, "get", sym); |
12842 | | |
12843 | 12850 | while(pl != C_SCHEME_END_OF_LIST) { |
12844 | 12851 | if(C_block_item(pl, 0) == prop) |
12845 | 12852 | return C_u_i_car(C_u_i_cdr(pl)); |
… |
… |
C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val) |
12855 | 12862 | { |
12856 | 12863 | C_word pl = C_symbol_plist(sym); |
12857 | 12864 | |
12858 | | if (pl == C_SCHEME_FALSE) |
12859 | | barf(C_BAD_ARGUMENT_TYPE_SYMBOL_IS_KEYWORD_ERROR, "put", sym); |
12860 | | |
12861 | 12865 | /* Newly added plist? Ensure the symbol stays! */ |
12862 | 12866 | if (pl == C_SCHEME_END_OF_LIST) C_i_persist_symbol(sym); |
12863 | 12867 | |
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 7ceb8302..309960c1 100644
a
|
b
|
|
41 | 41 | chicken.format |
42 | 42 | chicken.internal |
43 | 43 | chicken.io |
| 44 | chicken.keyword |
44 | 45 | chicken.pathname |
45 | 46 | chicken.platform |
46 | 47 | chicken.plist |
… |
… |
|
84 | 85 | ; | (refine (SYMBOL ...) VALUE) |
85 | 86 | ; | deprecated |
86 | 87 | ; | (deprecated NAME) |
87 | | ; VALUE = string | symbol | char | number | boolean | true | false | |
| 88 | ; VALUE = string | symbol | keyword | char | number | |
| 89 | ; boolean | true | false | |
88 | 90 | ; null | eof | blob | pointer | port | locative | fixnum | |
89 | 91 | ; float | bignum | ratnum | cplxnum | integer | pointer-vector |
90 | 92 | ; BASIC = * | list | pair | procedure | vector | undefined | noreturn | values |
… |
… |
|
130 | 132 | (define-constant +maximal-complex-object-constructor-result-type-length+ 256) |
131 | 133 | |
132 | 134 | (define-constant value-types |
133 | | '(string symbol char null boolean true false blob eof fixnum float number |
134 | | integer bignum ratnum cplxnum pointer-vector port pointer locative)) |
| 135 | '(string symbol keyword char null boolean true false blob eof |
| 136 | fixnum float number integer bignum ratnum cplxnum |
| 137 | pointer-vector port pointer locative)) |
135 | 138 | |
136 | 139 | (define-constant basic-types |
137 | 140 | '(* list pair procedure vector undefined deprecated noreturn values)) |
… |
… |
|
190 | 193 | |
191 | 194 | (define (constant-result lit) |
192 | 195 | (cond ((string? lit) 'string) |
| 196 | ((keyword? lit) 'keyword) |
193 | 197 | ((symbol? lit) 'symbol) |
194 | 198 | ;; Do not assume fixnum width matches target platforms! |
195 | 199 | ((or (big-fixnum? lit) (small-bignum? lit)) 'integer) |
diff --git a/synrules.scm b/synrules.scm
index d3453fe7..d0919862 100644
a
|
b
|
|
64 | 64 | |
65 | 65 | (import scheme) |
66 | 66 | |
67 | | (define (plain-symbol? x) |
68 | | (and (symbol? x) (not (##core#inline "C_u_i_keywordp" x))) ) |
69 | | |
70 | 67 | (define (syntax-rules-mismatch input) |
71 | 68 | (##sys#syntax-error-hook "no rule matches form" input)) |
72 | 69 | |
… |
… |
|
163 | 160 | ;; Generate code to test whether input expression matches pattern |
164 | 161 | |
165 | 162 | (define (process-match input pattern seen-segment?) |
166 | | (cond ((plain-symbol? pattern) |
| 163 | (cond ((symbol? pattern) |
167 | 164 | (if (memq pattern subkeywords) |
168 | 165 | `((,%compare ,input (,%rename (##core#syntax ,pattern)))) |
169 | 166 | `())) |
… |
… |
|
202 | 199 | ;; This is pretty bad, but it seems to work (can't say why). |
203 | 200 | |
204 | 201 | (define (process-pattern pattern path mapit seen-segment?) |
205 | | (cond ((plain-symbol? pattern) |
| 202 | (cond ((symbol? pattern) |
206 | 203 | (if (memq pattern subkeywords) |
207 | 204 | '() |
208 | 205 | (list (list pattern (mapit path))))) |
… |
… |
|
233 | 230 | ;; Generate code to compose the output expression according to template |
234 | 231 | |
235 | 232 | (define (process-template template dim env) |
236 | | (cond ((plain-symbol? template) |
| 233 | (cond ((symbol? template) |
237 | 234 | (let ((probe (assq template env))) |
238 | 235 | (if probe |
239 | 236 | (if (<= (cdr probe) dim) |
… |
… |
|
253 | 250 | env)) |
254 | 251 | (gen (if (and (pair? vars) |
255 | 252 | (null? (cdr vars)) |
256 | | (plain-symbol? x) |
| 253 | (symbol? x) |
257 | 254 | (eq? x (car vars))) |
258 | 255 | x ;+++ |
259 | 256 | `(,%map (,%lambda ,vars ,x) |
… |
… |
|
278 | 275 | ;; Return an association list of (var . dim) |
279 | 276 | |
280 | 277 | (define (meta-variables pattern dim vars seen-segment?) |
281 | | (cond ((plain-symbol? pattern) |
| 278 | (cond ((symbol? pattern) |
282 | 279 | (if (memq pattern subkeywords) |
283 | 280 | vars |
284 | 281 | (cons (cons pattern dim) vars))) |
… |
… |
|
295 | 292 | ;; Return a list of meta-variables of given higher dim |
296 | 293 | |
297 | 294 | (define (free-meta-variables template dim env free) |
298 | | (cond ((plain-symbol? template) |
| 295 | (cond ((symbol? template) |
299 | 296 | (if (and (not (memq template free)) |
300 | 297 | (let ((probe (assq template env))) |
301 | 298 | (and probe (>= (cdr probe) dim)))) |
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 1e19a632..fa56e820 100644
a
|
b
|
|
348 | 348 | |
349 | 349 | (parameterize ((keyword-style #:suffix)) |
350 | 350 | (assert (string=? "abc:" (symbol->string (with-input-from-string "|abc:|" read)))) |
351 | | (assert (string=? "abc" (symbol->string (with-input-from-string "|abc|:" read)))) ; keyword |
| 351 | (assert (string=? "abc" (keyword->string (with-input-from-string "|abc|:" read)))) ; keyword |
352 | 352 | (let ((kw (with-input-from-string "|foo bar|:" read))) |
353 | 353 | (assert (eq? kw (with-input-from-string "#:|foo bar|" read))) |
354 | | (assert (string=? "foo bar" (symbol->string kw))) |
| 354 | (assert (string=? "foo bar" (keyword->string kw))) |
355 | 355 | (assert (string=? "foo bar:" |
356 | 356 | (with-output-to-string (lambda () (display kw))))) |
357 | 357 | (assert (string=? "#:|foo bar|" |
358 | 358 | (with-output-to-string (lambda () (write kw))))))) |
359 | 359 | |
360 | 360 | (parameterize ((keyword-style #:prefix)) |
361 | | (assert (string=? "abc" (symbol->string (with-input-from-string ":|abc|" read)))) |
| 361 | (assert (string=? "abc" (keyword->string (with-input-from-string ":|abc|" read)))) |
362 | 362 | (assert (string=? ":abc" (symbol->string (with-input-from-string "|:abc|" read)))) |
363 | 363 | (let ((kw (with-input-from-string ":|foo bar|" read))) |
364 | 364 | (assert (eq? kw (with-input-from-string "#:|foo bar|" read))) |
365 | | (assert (string=? "foo bar" (symbol->string kw))) |
| 365 | (assert (string=? "foo bar" (keyword->string kw))) |
366 | 366 | (assert (string=? ":foo bar" |
367 | 367 | (with-output-to-string (lambda () (display kw))))) |
368 | 368 | (assert (string=? "#:|foo bar|" |
… |
… |
|
413 | 413 | (assert-fail (with-input-from-string "#:" read)) |
414 | 414 | |
415 | 415 | (let ((empty-kw (with-input-from-string "#:||" read))) |
| 416 | (assert (not (symbol? empty-kw))) |
416 | 417 | (assert (keyword? empty-kw)) |
417 | 418 | (assert (string=? "" (keyword->string empty-kw)))) |
418 | 419 | |
… |
… |
|
427 | 428 | (assert (equal? (cons 1 2) (with-input-from-string "(1 . 2)" read))) |
428 | 429 | (assert (every keyword? (with-input-from-string "(42: abc: .: #:: ::)" read))) |
429 | 430 | |
| 431 | ;; symbols and keywords are now distinct |
| 432 | (assert (not (symbol? #:foo))) |
| 433 | (assert (not (symbol? (string->keyword "foo")))) |
| 434 | (assert (not (keyword? 'foo))) |
| 435 | (assert (not (keyword? (string->symbol "foo")))) |
430 | 436 | |
431 | 437 | ;;; reading unterminated objects |
432 | 438 | |
diff --git a/tests/version-tests.scm b/tests/version-tests.scm
index c6c3ce7d..2a786dc8 100644
a
|
b
|
|
1 | | (import chicken.irregex chicken.platform chicken.string) |
| 1 | (import chicken.irregex chicken.platform chicken.keyword chicken.string) |
2 | 2 | |
3 | 3 | (let* ((version-tokens (string-split (chicken-version) ".")) |
4 | 4 | (major (string->number (car version-tokens))) |
… |
… |
|
13 | 13 | (let loop ((features (features))) |
14 | 14 | (if (null? features) |
15 | 15 | (error "Could not find feature chicken-<major>.<minor>") |
16 | | (let ((feature (symbol->string (car features)))) |
| 16 | (let ((feature (keyword->string (car features)))) |
17 | 17 | (cond ((irregex-match "chicken-(\\d+)\\.(\\d+)" feature) |
18 | 18 | => (lambda (match) |
19 | 19 | (assert (= (string->number |
… |
… |
|
28 | 28 | (let loop ((features (features))) |
29 | 29 | (if (null? features) |
30 | 30 | (error "Could not find feature chicken-<major>") |
31 | | (let ((feature (symbol->string (car features)))) |
| 31 | (let ((feature (keyword->string (car features)))) |
32 | 32 | (cond ((irregex-match "chicken-(\\d+)" feature) |
33 | 33 | => (lambda (match) |
34 | 34 | (assert (= (string->number |
diff --git a/types.db b/types.db
index 9131145d..0b1b1ec7 100644
a
|
b
|
|
1322 | 1322 | |
1323 | 1323 | ;; keyword |
1324 | 1324 | |
1325 | | (chicken.keyword#get-keyword (#(procedure #:clean #:enforce) chicken.keyword#get-keyword (symbol list #!optional *) *)) |
1326 | | (chicken.keyword#keyword->string (#(procedure #:clean #:enforce) chicken.keyword#keyword->string (symbol) string)) |
1327 | | (chicken.keyword#keyword? (#(procedure #:pure) chicken.keyword#keyword? (*) boolean)) |
1328 | | (chicken.keyword#string->keyword (#(procedure #:clean #:enforce) chicken.keyword#string->keyword (string) symbol)) |
| 1325 | (chicken.keyword#get-keyword (#(procedure #:clean #:enforce) chicken.keyword#get-keyword (keyword list #!optional *) *)) |
| 1326 | (chicken.keyword#keyword->string (#(procedure #:clean #:enforce) chicken.keyword#keyword->string (keyword) string)) |
| 1327 | (chicken.keyword#keyword? (#(procedure #:pure #:predicate keyword) chicken.keyword#keyword? (*) boolean)) |
| 1328 | (chicken.keyword#string->keyword (#(procedure #:clean #:enforce) chicken.keyword#string->keyword (string) keyword)) |
1329 | 1329 | |
1330 | 1330 | ;; load |
1331 | 1331 | |
… |
… |
|
1346 | 1346 | (chicken.platform#build-platform (#(procedure #:pure) chicken.platform#build-platform () symbol)) |
1347 | 1347 | (chicken.platform#chicken-version (#(procedure #:pure) chicken.platform#chicken-version (#!optional *) string)) |
1348 | 1348 | (chicken.platform#chicken-home (#(procedure #:clean) chicken.platform#chicken-home () string)) |
1349 | | (chicken.platform#feature? (#(procedure #:clean) chicken.platform#feature? (#!rest symbol) boolean)) |
1350 | | (chicken.platform#features (#(procedure #:clean) chicken.platform#features () (list-of symbol))) |
| 1349 | (chicken.platform#feature? (#(procedure #:clean) chicken.platform#feature? (#!rest (or keyword symbol string)) boolean)) |
| 1350 | (chicken.platform#features (#(procedure #:clean) chicken.platform#features () (list-of keyword))) |
1351 | 1351 | (chicken.platform#software-type (#(procedure #:pure) chicken.platform#software-type () symbol)) |
1352 | 1352 | (chicken.platform#software-version (#(procedure #:pure) chicken.platform#software-version () symbol)) |
1353 | | (chicken.platform#register-feature! (#(procedure #:clean #:enforce) chicken.platform#register-feature! (#!rest symbol) undefined)) |
1354 | | (chicken.platform#unregister-feature! (#(procedure #:clean #:enforce) chicken.platform#unregister-feature! (#!rest symbol) undefined)) |
| 1353 | (chicken.platform#register-feature! (#(procedure #:clean #:enforce) chicken.platform#register-feature! (#!rest (or keyword symbol string)) undefined)) |
| 1354 | (chicken.platform#unregister-feature! (#(procedure #:clean #:enforce) chicken.platform#unregister-feature! (#!rest (or keyword symbol string)) undefined)) |
1355 | 1355 | (chicken.platform#machine-byte-order (#(procedure #:pure) chicken.platform#machine-byte-order () symbol)) |
1356 | 1356 | (chicken.platform#machine-type (#(procedure #:pure) chicken.platform#machine-type () symbol)) |
1357 | 1357 | (chicken.platform#repository-path (#(procedure #:clean) chicken.platform#repository-path (#!optional *) *)) |