-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
+ case scm_tc7_keyword:
case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
return class_dynamic_state;
case scm_tc7_frame:
return class_frame;
+ case scm_tc7_keyword:
+ return scm_class_keyword;
case scm_tc7_vm_cont:
return class_vm_cont;
case scm_tc7_bytevector:
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
scm_smob_class[i] = SCM_BOOL_F;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
-
for (i = 0; i < scm_numsmob; ++i)
if (scm_is_false (scm_smob_class[i]))
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
+ * 2006, 2008, 2009, 2011, 2013, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static SCM keyword_obarray;
-scm_t_bits scm_tc16_keyword;
-
-#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
-#define KEYWORDSYM(X) (SCM_SMOB_OBJECT (X))
-
-static int
-keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts_unlocked ("#:", port);
- scm_display (KEYWORDSYM (exp), port);
- return 1;
-}
+#define SCM_KEYWORDP(x) (SCM_HAS_TYP7 (x, scm_tc7_keyword))
+#define SCM_KEYWORD_SYMBOL(x) (SCM_CELL_OBJECT_1 (x))
SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
(SCM obj),
"@code{#f}.")
#define FUNC_NAME s_scm_keyword_p
{
- return scm_from_bool (KEYWORDP (obj));
+ return scm_from_bool (SCM_KEYWORDP (obj));
}
#undef FUNC_NAME
SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");
SCM_CRITICAL_SECTION_START;
- /* njrev: NEWSMOB and hashq_set_x can raise errors */
+ /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory
+ error. */
keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
- SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
+ keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol));
scm_hashq_set_x (keyword_obarray, symbol, keyword);
}
SCM_CRITICAL_SECTION_END;
"Return the symbol with the same name as @var{keyword}.")
#define FUNC_NAME s_scm_keyword_to_symbol
{
- scm_assert_smob_type (scm_tc16_keyword, keyword);
- return KEYWORDSYM (keyword);
+ SCM_VALIDATE_KEYWORD (1, keyword);
+ return SCM_KEYWORD_SYMBOL (keyword);
}
#undef FUNC_NAME
int
scm_is_keyword (SCM val)
{
- return KEYWORDP (val);
+ return SCM_KEYWORDP (val);
}
SCM
}
}
-/* njrev: critical sections reviewed so far up to here */
void
scm_init_keywords ()
{
- scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
- scm_set_smob_print (scm_tc16_keyword, keyword_print);
-
keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}
#ifndef SCM_KEYWORDS_H
#define SCM_KEYWORDS_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
-SCM_API scm_t_bits scm_tc16_keyword;
-
-\f
-
SCM_API SCM scm_keyword_p (SCM obj);
SCM_API SCM scm_symbol_to_keyword (SCM symbol);
SCM_API SCM scm_keyword_to_symbol (SCM keyword);
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- * 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
case scm_tc7_frame:
scm_i_frame_print (exp, port, pstate);
break;
+ case scm_tc7_keyword:
+ scm_puts_unlocked ("#:", port);
+ scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate);
+ break;
case scm_tc7_vm_cont:
scm_i_vm_cont_print (exp, port, pstate);
break;
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#define scm_tc7_dynamic_state 45
#define scm_tc7_frame 47
-#define scm_tc7_unused_53 53
+#define scm_tc7_keyword 53
#define scm_tc7_unused_55 55
#define scm_tc7_vm_cont 71
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a))
(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
+ (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
+ (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
;;; Effects analysis on CPS
-;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
((string? arg))
((number? arg))
((char? arg))
+ ((bytevector? arg))
+ ((keyword? arg))
+ ((bitvector? arg))
((procedure? arg))
((thunk? arg)))
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(string? . (1 . 1))
(vector? . (1 . 1))
(symbol? . (1 . 1))
+ (keyword? . (1 . 1))
(variable? . (1 . 1))
(bitvector? . (1 . 1))
(bytevector? . (1 . 1))
(('struct-ref s (? immediate-u8? n))
(adapt-val ($primcall 'struct-ref/immediate (s n))))
(('struct-set! s (? immediate-u8? n) x)
- ;; Unhappily, and undocumentedly, struct-set! returns the value
- ;; that was set. There is code that relies on this. Hackety
- ;; hack...
- (let-fresh (k*) ()
- (build-cps-term
- ($letk ((k* ($kargs () ()
- ($continue k src ($primcall 'values (x))))))
- ($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
+ (build-cps-term
+ ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
(_
(build-cps-term ($continue k src ($primcall name args))))))
;;; Type analysis on CPS
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
(define-simple-predicate-inferrer vector? &vector)
(define-simple-predicate-inferrer struct? &struct)
(define-simple-predicate-inferrer string? &string)
+(define-simple-predicate-inferrer bytevector? &bytevector)
+(define-simple-predicate-inferrer bitvector? &bitvector)
+(define-simple-predicate-inferrer keyword? &keyword)
(define-simple-predicate-inferrer number? &number)
(define-simple-predicate-inferrer char? &char)
(define-simple-predicate-inferrer procedure? &procedure)
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(make-lexical-ref src 'v v)
(reverse args) (reverse (iota len))))))
+ (($ <primcall> src 'struct-set! (struct index value))
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let ((v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list value)
+ (make-seq src
+ (make-primcall src 'struct-set!
+ (list struct
+ index
+ (make-lexical-ref src 'v v)))
+ (make-lexical-ref src 'v v)))))
+
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
sqrt abs
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
+ bytevector? keyword? bitvector?
procedure? thunk?
not
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
+ bytevector? keyword? bitvector?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
not
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
+ bytevector? keyword? bitvector?
procedure? thunk?
acons cons cons* list vector))
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
<boolean> <char> <list> <pair> <null> <string> <symbol>
<vector> <bytevector> <uvec> <foreign> <hashtable>
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
+ <keyword>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
;; smob-type-name->class procedure.
<arbiter> <promise> <thread> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state> <async>
- <directory> <keyword> <array> <character-set>
+ <directory> <array> <character-set>
<dynamic-object> <guardian> <macro>
;; Modules.
(define <random-state> (find-subclass <top> '<random-state>))
(define <async> (find-subclass <top> '<async>))
(define <directory> (find-subclass <top> '<directory>))
-(define <keyword> (find-subclass <top> '<keyword>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))
(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
(define %tc7-stringbuf 39)
(define %tc7-dynamic-state 45)
(define %tc7-frame 47)
+(define %tc7-keyword 53)
(define %tc7-program 69)
(define %tc7-vm-continuation 71)
(define %tc7-bytevector 77)
(inferior-object 'hash-table address))
(((_ & #x7f = %tc7-pointer) address)
(make-pointer address))
+ (((_ & #x7f = %tc7-keyword) symbol)
+ (symbol->keyword (cell->object symbol backend)))
(((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address))
(((_ & #x7f = %tc7-weak-set))
;(define-tc7-macro-assembler br-if-fluid 37)
;(define-tc7-macro-assembler br-if-dynamic-state 45)
;(define-tc7-macro-assembler br-if-frame 47)
+(define-tc7-macro-assembler br-if-keyword 53)
;(define-tc7-macro-assembler br-if-vm 55)
;(define-tc7-macro-assembler br-if-vm-cont 71)
;(define-tc7-macro-assembler br-if-rtl-program 69)
;;; Guile bytecode disassembler
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
((7) "variable?")
((13) "vector?")
((15) "string?")
+ ((53) "keyword?")
((77) "bytevector?")
((95) "bitvector?")
(else (number->string tc7)))))
;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
42 (expt 2 28) 3.14
"narrow string" "wide στρινγ"
'symbol 'λ
- ;; NB: keywords are SMOBs.
+ #:keyword #:λ
'(2 . 3) (iota 123) '(1 (two ("three")))
#(1 2 3) #(foo bar baz)
#vu8(255 254 253)
(with-test-prefix "opaque objects"
(test-inferior-objects
((make-guardian) smob (? integer?))
- (#:keyword smob (? integer?))
((%make-void-port "w") port (? integer?))
((open-input-string "hello") port (? integer?))
((lambda () #t) program _)