Browse files

Add compile-time flag to make ___tPAIR and ___tSUBTYPED equal (in pre…

…paration for implementing contained objects)
  • Loading branch information...
1 parent abd790a commit 29103e6a29b8fbbf7d6fc772a344b814be3f1c1a @feeley feeley committed Oct 13, 2012
Showing with 70 additions and 29 deletions.
  1. +21 −8 include/gambit.h.in
  2. +2 −2 include/stamp.h
  3. +8 −2 lib/_gambit#.scm
  4. +10 −4 lib/_system.scm
  5. +22 −6 lib/mem.c
  6. +7 −7 lib/setup.c
View
29 include/gambit.h.in
@@ -1738,15 +1738,24 @@ ___CAST_U64((val)<<(((i)&7)<<3))
* ___TB = number of tag bits
* ___tFIXNUM = tag for fixnums (small integers), must be 0
* ___tSPECIAL = tag for other immediates (#f, #t, (), #!eof, chars, ...)
- * ___tPAIR = tag for pairs
- * ___tSUBTYPED = tag for other memory allocated objects
+ * ___tMEM1 = tag #1 for memory allocated objects (lower bit must be 1)
+ * ___tMEM2 = tag #2 for memory allocated objects (lower bit must be 1)
+ * ___tSUBTYPED = ___tMEM1
+ * ___tPAIR = ___tMEM1 or ___tMEM2
*/
#define ___TB 2
#define ___tFIXNUM 0
#define ___tSPECIAL 2
-#define ___tPAIR 3
-#define ___tSUBTYPED 1
+#define ___tMEM1 1
+#define ___tMEM2 3
+#define ___tSUBTYPED ___tMEM1
+
+#ifdef ___USE_SAME_TAG_FOR_PAIRS_AND_SUBTYPED
+#define ___tPAIR ___tMEM1
+#else
+#define ___tPAIR ___tMEM2
+#endif
#define ___MEM_ALLOCATED(obj)((obj)&1)
#define ___MEM_ALLOCATED_CLEAR(obj)((obj)&~___CAST(___WORD,1))
@@ -1921,10 +1930,10 @@ ___CAST_U64((val)<<(((i)&7)<<3))
#endif
#define ___REF_CHR(x)___CHR(x)
-#define ___REF_SYM(i,id)((___CAST(___WORD,-1-i)<<___TB)+___tPAIR)
-#define ___REF_KEY(i,id)((___CAST(___WORD,-1-i)<<___TB)+___tSUBTYPED)
-#define ___REF_CNS(i)((___CAST(___WORD,i)<<___TB)+___tPAIR)
-#define ___REF_SUB(i)((___CAST(___WORD,i)<<___TB)+___tSUBTYPED)
+#define ___REF_SYM(i,id)((___CAST(___WORD,-1-i)<<___TB)+___tMEM2)
+#define ___REF_KEY(i,id)((___CAST(___WORD,-1-i)<<___TB)+___tMEM1)
+#define ___REF_CNS(i)((___CAST(___WORD,i)<<___TB)+___tMEM2)
+#define ___REF_SUB(i)((___CAST(___WORD,i)<<___TB)+___tMEM1)
/*---------------------------------------------------------------------------*/
@@ -2550,7 +2559,11 @@ ___FIX((((___BIGMDOUBLEDIGIT)___BIGMFETCH(___BODY_AS(u,___tSUBTYPED),___INT(___B
#define ___FIXNUMP(x)___TESTTYPE(x,___tFIXNUM)
#define ___FLONUMP(x)___TESTSUBTYPE(x,___sFLONUM)
#define ___SPECIALP(x)___TESTTYPE(x,___tSPECIAL)
+#if ___tPAIR == ___tSUBTYPED
+#define ___PAIRP(x)___TESTSUBTYPE(x,___sPAIR)
+#else
#define ___PAIRP(x)___TESTTYPE(x,___tPAIR)
+#endif
#define ___PAIRMUTABLEP(obj)(___HD_TYP(*___UNTAG_AS(obj,___tPAIR))!=___PERM)
#define ___SUBTYPEDP(x)___TESTTYPE(x,___tSUBTYPED)
#define ___SUBTYPEDMUTABLEP(obj)(___HD_TYP(*___UNTAG_AS(obj,___tSUBTYPED))!=___PERM)
View
4 include/stamp.h
@@ -2,5 +2,5 @@
* Time stamp of last source code repository commit.
*/
-#define ___STAMP_YMD 20121011
-#define ___STAMP_HMS 160520
+#define ___STAMP_YMD 20121013
+#define ___STAMP_HMS 190232
View
10 lib/_gambit#.scm
@@ -15,9 +15,15 @@
;; Type tags.
(##define-macro (macro-type-fixnum) 0)
-(##define-macro (macro-type-subtyped) 1)
+(##define-macro (macro-type-mem1) 1)
(##define-macro (macro-type-special) 2)
-(##define-macro (macro-type-pair) 3)
+(##define-macro (macro-type-mem2) 3)
+
+(##define-macro (macro-type-subtyped) `(macro-type-mem1))
+
+;; The type for pair depends on compile-time flags
+;; (##define-macro (macro-type-pair) `(macro-type-mem1))
+;; (##define-macro (macro-type-pair) `(macro-type-mem2))
;; Subtype tags.
View
14 lib/_system.scm
@@ -704,8 +704,8 @@
(define-prim (##mem-allocated? obj)
(let ((type (##type obj)))
- (or (##fixnum.= type (macro-type-subtyped))
- (##fixnum.= type (macro-type-pair)))))
+ (or (##fixnum.= type (macro-type-mem1))
+ (##fixnum.= type (macro-type-mem2)))))
(implement-type-table)
@@ -1615,9 +1615,15 @@
;;; Type tags.
(##define-macro (macro-type-fixnum) 0)
-(##define-macro (macro-type-subtyped) 1)
+(##define-macro (macro-type-mem1) 1)
(##define-macro (macro-type-special) 2)
-(##define-macro (macro-type-pair) 3)
+(##define-macro (macro-type-mem2) 3)
+
+(##define-macro (macro-type-subtyped) `(macro-type-mem1))
+
+;; The type for pair depends on compile-time flags
+;; (##define-macro (macro-type-pair) `(macro-type-mem1))
+;; (##define-macro (macro-type-pair) `(macro-type-mem2))
;;; Subtype tags.
View
28 lib/mem.c
@@ -1,6 +1,6 @@
-/* File: "mem.c", Time-stamp: <2010-12-03 16:45:18 feeley> */
+/* File: "mem.c" */
-/* Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved. */
+/* Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved. */
#define ___INCLUDED_FROM_MEM
#define ___VERSION 406006
@@ -104,8 +104,12 @@
* ___tSPECIAL object is a boolean, character, or other immediate
*
* memory allocated:
- * ___tPAIR object is a pair
- * ___tSUBTYPED object is memory allocated but not a pair
+ * if ___USE_SAME_TAG_FOR_PAIRS_AND_SUBTYPED is defined
+ * ___tMEM1 = ___tSUBTYPED = ___tPAIR subtyped object, possibly a pair
+ * ___tMEM2 contained object, or a pair
+ * otherwise
+ * ___tMEM1 = ___tSUBTYPED subtyped object, but not a pair
+ * ___tMEM2 = ___tPAIR a pair
*
* A special type of object exists to support object finalization:
* 'will' objects. Wills contain a weak reference to an object, the
@@ -1233,7 +1237,12 @@ int kind;)
base[___PERM_BODY_OFS-1] = ___MAKE_HD(bytes, subtype, ___PERM);
return ___TAG((base + ___PERM_HAND_OFS - ___BODY_OFS),
- (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED));
+#if ___tPAIR == ___tSUBTYPED
+ ___tSUBTYPED
+#else
+ (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED)
+#endif
+ );
}
else
{
@@ -1249,7 +1258,12 @@ int kind;)
base[___STILL_BODY_OFS-1] = ___MAKE_HD(bytes, subtype, ___STILL);
return ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),
- (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED));
+#if ___tPAIR == ___tSUBTYPED
+ ___tSUBTYPED
+#else
+ (subtype == ___sPAIR ? ___tPAIR : ___tSUBTYPED)
+#endif
+ );
}
}
@@ -1833,9 +1847,11 @@ char *msg;)
int subtype = ___HD_SUBTYPE(head);
int i;
+#if ___tPAIR != ___tSUBTYPED
if (subtype == ___sPAIR)
container = ___TAG(container_body-___BODY_OFS,___tPAIR);
else
+#endif
container = ___TAG(container_body-___BODY_OFS,___tSUBTYPED);
___printf (">>> The reference was found in ");
View
14 lib/setup.c
@@ -663,19 +663,19 @@ ___SCMOBJ *sub_tbl;)
___SCMOBJ v = *p;
switch (___TYP(v))
{
- case ___tPAIR:
+ case ___tMEM1:
if (___INT(v)<0)
- *p = sym_tbl[-1-___INT(v)];
+ *p = key_tbl[-1-___INT(v)];
else
- *p = ___TAG(___ALIGNUP(&cns_tbl[(___PAIR_SIZE+1)*___INT(v)],___WS),
- ___tPAIR);
+ *p = sub_tbl[___INT(v)];
break;
- case ___tSUBTYPED:
+ case ___tMEM2:
if (___INT(v)<0)
- *p = key_tbl[-1-___INT(v)];
+ *p = sym_tbl[-1-___INT(v)];
else
- *p = sub_tbl[___INT(v)];
+ *p = ___TAG(___ALIGNUP(&cns_tbl[(___PAIR_SIZE+1)*___INT(v)],___WS),
+ ___tPAIR);
break;
}
}

0 comments on commit 29103e6

Please sign in to comment.