aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog15
-rw-r--r--src/interp/buildom.boot14
-rw-r--r--src/interp/compiler.boot1
-rw-r--r--src/interp/g-cndata.boot9
-rw-r--r--src/interp/g-error.boot8
-rw-r--r--src/interp/nrunfast.boot20
-rw-r--r--src/interp/sys-constants.boot3
7 files changed, 56 insertions, 14 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index f506aadf..e3908535 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,18 @@
+2011-02-09 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ Add MappingCategory as a (builtin) category.
+ * interp/sys-constants.boot ($CategoryNames): Include MappingCategory.
+ * interp/g-cndata.boot (unabbrevSpecialForms): Handle
+ MappingCategory, RecordCategory, and UnionCategory.
+ * interp/buildom.boot (MappingCategory): New.
+ * interp/compiler.boot: Elaboration MappingCategory forms.
+ * interp/g-error.boot (needsToSplitMessage): Fix thinko from
+ type-based dispatch done by the Boot translator.
+ * interp/nrunfast.boot (builtinConstructor?): New.
+ (generalizedBuiltinConstructor?): Likewise.
+ (lazyMatch): Use them.
+ (newHasTest): Properly recognize all flavours of category forms.
+
2011-02-08 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/sys-constants.boot ($PrimitiveDomainNames): Remove.
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index 81ad8d1e..ce70aa08 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -203,6 +203,20 @@ coerceUn2E(x,source) ==
--% Mapping
-- Want to eventually have elt: ($, args) -> target
+++ Implementation of the `MappinCategory' as builtin.
+++ A domain that satisfy this predicate provides implementation
+++ to abstraction that map values from some type to values
+++ of another type.
+MappingCategory(:"sig") ==
+ sig = nil =>
+ error '"MappingCategory requires at least one argument"
+ cat := eval ['Join,$Type,
+ ['mkCategory,quoteForm 'domain,
+ quoteForm [[['elt,[first sig,'$,:rest sig]],true]],
+ [], [], nil]]
+ vectorRef(cat,0) := ['MappingCategory,:sig]
+ cat
+
Mapping(:args) ==
srcArgs := [devaluate a for a in args]
nargs := #args
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index b231b3db..3c928a81 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -2683,6 +2683,7 @@ for x in [["|", :"compSuchthat"],_
["SubsetCategory", :"compSubsetCategory"],_
["Union", :"compCat"],_
["Mapping", :"compCat"],_
+ ["MappingCategory", :"compConstructorCategory"],_
["UnionCategory", :"compConstructorCategory"],_
["where", :"compWhere"],_
["per",:"compPer"],_
diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot
index 819fb583..5f90bc61 100644
--- a/src/interp/g-cndata.boot
+++ b/src/interp/g-cndata.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2010, Gabriel Dos Reis.
+-- Copyright (C) 2007-2011, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -200,10 +200,11 @@ unabbrev1(u,modeIfTrue) ==
u
unabbrevSpecialForms(op,arglist,modeIfTrue) ==
- op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]]
- op = 'Union =>
+ op in '(Mapping MappingCategory) =>
+ [op,:[unabbrev1(a,modeIfTrue) for a in arglist]]
+ op in '(Union UnionCategory) =>
[op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]]
- op = 'Record =>
+ op in '(Record RecordCategory) =>
[op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]]
nil
diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot
index e0c0c905..aafefd93 100644
--- a/src/interp/g-error.boot
+++ b/src/interp/g-error.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2010, Gabriel Dos Reis.
+-- Copyright (C) 2007-2011, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -79,9 +79,9 @@ errorSupervisor(errorType,errorMsg) ==
errorSupervisor1(errorType,errorMsg,$BreakMode)
needsToSplitMessage msg ==
- "%b" in msg or '"%b" in msg => false
- "%d" in msg or '"%d" in msg => false
- "%l" in msg or '"%l" in msg => false
+ member("%b",msg) or member('"%b",msg) => false
+ member("%d",msg) or member('"%d",msg) => false
+ member("%l",msg) or member('"%l",msg) => false
true
errorSupervisor1(errorType,errorMsg,$BreakMode) ==
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 57afc9a7..2a524414 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -463,14 +463,24 @@ lazyMatchArg2(s,a,dollar,domain,typeFlag) ==
lazyMatch(s,a,dollar,domain)
--above line is temporarily necessary until system is compiled 8/15/90
--s = a
-
+
+++ Return true if the symbol `s' designates a builtin constructor.
+builtinConstructor? s ==
+ s in $BuiltinConstructorNames
+
+++ Return true if the symbol `s' designates a generalized builtin
+++ constructor, that is a builtin constructor or any operator we
+++ deem as a constructor from the domain slot-filling machinery perspective.
+generalizedBuiltinConstructor? s ==
+ builtinConstructor? s or s is "QUOTE" or s is "[||]"
+
lazyMatch(source,lazyt,dollar,domain) ==
lazyt is [op,:argl] and cons? source and op=first source
and #(sargl := rest source) = #argl =>
- op in '(Record Union) and first argl is [":",:.] =>
+ builtinConstructor? op and first argl is [":",:.] =>
and/[stag = atag and lazyMatchArg(s,a,dollar,domain)
for [.,stag,s] in sargl for [.,atag,a] in argl]
- op in '(Union Mapping _[_|_|_] QUOTE Enumeration) =>
+ generalizedBuiltinConstructor? op =>
and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl]
coSig := getDualSignatureFromDB op
null coSig => error ["bad Constructor op", op]
@@ -644,7 +654,7 @@ newHasTest(domform,catOrAtt) ==
-- we will refuse to say yes for 'Cat has Cat'
--getConstructorKindFromDB opOf domform = "category" => throwKeyedMsg("S2IS0025",NIL)
-- on second thoughts we won't!
- getConstructorKindFromDB opOf domform = "category" =>
+ categoryForm? domform =>
domform = catOrAtt => 'T
for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,getConstructorAttributesFromDB(opOf domform))] | aCat = catOrAtt repeat
return evalCond cond where
@@ -658,7 +668,7 @@ newHasTest(domform,catOrAtt) ==
pred in '(OR or %or) => or/[evalCond i for i in l]
pred in '(AND and %and) => and/[evalCond i for i in l]
x
- not isAtom and constructor? op =>
+ not isAtom and categoryForm? catOrAtt =>
domain := eval mkEvalable domform
newHasCategory(domain,catOrAtt)
catOrAtt is [":",op,type] =>
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index 45f747d5..9a1fbcff 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -533,7 +533,8 @@ $CategoryNames ==
Join _
EnumerationCategory _
SubsetCategory _
- UnionCategory)
+ UnionCategory _
+ MappingCategory)
++ List of domain constructors that do not have entries in the constructor
++ database. So, they are mostly recognized by their names.