version 1.42, 2004/09/14 02:13:29 |
version 1.49, 2005/06/16 06:21:21 |
|
|
% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.41 2004/09/14 02:02:02 takayama Exp $ |
% $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.48 2005/02/27 05:28:06 takayama Exp $ |
%% dr.sm1 (Define Ring) 1994/9/25, 26 |
%% dr.sm1 (Define Ring) 1994/9/25, 26 |
%% This file is error clean. |
%% This file is error clean. |
|
|
|
|
(type?) data_conversion RingP eq |
(type?) data_conversion RingP eq |
} def |
} def |
|
|
|
[(isByteArray) |
|
[(obj isByteArray bool) ] |
|
] putUsages |
|
/isByteArray { |
|
(type?) data_conversion ByteArrayP eq |
|
} def |
|
|
/toString.tmp { |
/toString.tmp { |
/arg1 set |
/arg1 set |
[/obj /fname] pushVariables |
[/obj /fname] pushVariables |
|
|
{ obj (string) data_conversion } { } ifelse |
{ obj (string) data_conversion } { } ifelse |
obj isRational |
obj isRational |
{ obj (string) data_conversion } { } ifelse |
{ obj (string) data_conversion } { } ifelse |
|
obj isByteArray |
|
{ obj (array) data_conversion toString } { } ifelse |
obj tag 0 eq |
obj tag 0 eq |
{ (null) } { } ifelse |
{ (null) } { } ifelse |
|
|
|
|
/RationalFunctionP 16 def |
/RationalFunctionP 16 def |
/ClassP 17 def |
/ClassP 17 def |
/DoubleP 18 def |
/DoubleP 18 def |
|
/ByteArrayP 19 def |
/@.datatypeConstant.usage [ |
/@.datatypeConstant.usage [ |
(IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,) |
(IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,) |
(UniversalNumberP, RationalFunctionP, ClassP, DoubleP) |
(UniversalNumberP, RationalFunctionP, ClassP, DoubleP, ByteArrayP) |
( return data type identifiers.) |
( return data type identifiers.) |
(Example: 7 tag IntegerP eq ---> 1) |
(Example: 7 tag IntegerP eq ---> 1) |
] def |
] def |
|
|
[(RationalFunctionP) @.datatypeConstant.usage ] putUsages |
[(RationalFunctionP) @.datatypeConstant.usage ] putUsages |
[(ClassP) @.datatypeConstant.usage ] putUsages |
[(ClassP) @.datatypeConstant.usage ] putUsages |
[(DoubleP) @.datatypeConstant.usage ] putUsages |
[(DoubleP) @.datatypeConstant.usage ] putUsages |
|
[(ByteArrayP) @.datatypeConstant.usage ] putUsages |
|
|
[(__) |
[(__) |
[( string ring __ polynomial) |
[( string ring __ polynomial) |
|
|
[( string .. universalNumber) |
[( string .. universalNumber) |
(Parse the << string >> as a universalNumber.) |
(Parse the << string >> as a universalNumber.) |
(Example: (123431232123123).. /n set) |
(Example: (123431232123123).. /n set) |
|
({ commands }.. executes the commands. << .. >> is equivalent to exec.) |
]] putUsages |
]] putUsages |
/.. { (universalNumber) data_conversion } def |
/.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def |
|
|
[(dc) |
[(dc) |
[(Abbreviation of data_conversion.) |
[(Abbreviation of data_conversion.) |
Line 4153 $ [ff ff] fromVectors :: $ |
|
Line 4165 $ [ff ff] fromVectors :: $ |
|
/getNode { |
/getNode { |
/arg2 set |
/arg2 set |
/arg1 set |
/arg1 set |
[/in-getNode /ob /key /rr /rr /ii] pushVariables |
[/in-getNode /ob /key /rr /tt /ii] pushVariables |
[ |
[ |
/ob arg1 def |
/ob arg1 def |
/key arg2 def |
/key arg2 def |
/rr null def |
/rr null def |
{ |
{ |
|
ob isArray { |
|
ob length 1 gt { |
|
ob 0 get isString { |
|
ob 0 get , key eq { |
|
/rr ob 1 get def exit |
|
} { } ifelse |
|
} { } ifelse |
|
}{ } ifelse |
|
ob { key getNode , dup tag 0 eq {pop} { } ifelse } map /tt set |
|
tt length 0 gt { /rr tt 0 get def exit } |
|
{/rr null def exit } ifelse |
|
} { } ifelse |
|
|
ob isClass { |
ob isClass { |
ob (array) dc /ob set |
ob (array) dc /ob set |
} { exit } ifelse |
} { } ifelse |
|
ob isClass , ob isArray or { } { exit } ifelse |
ob 0 get key eq { |
ob 0 get key eq { |
/rr ob def |
/rr ob def |
exit |
exit |
Line 4180 $ [ff ff] fromVectors :: $ |
|
Line 4206 $ [ff ff] fromVectors :: $ |
|
arg1 |
arg1 |
} def |
} def |
[(getNode) |
[(getNode) |
[(ob key getNode) |
[(ob key getNode node-value) |
(ob is a class object.) |
(ob is a class object or an array.) |
(The operator getNode returns the node with the key in ob.) |
(The operator getNode returns the node with the key in ob.) |
(The node is an array of the format [key attr-list node-list]) |
(When ob is a class, the node is an array of the format [key attr-list node-list]) |
|
(When ob is an array, the node is a value of key-value pairs.) |
(Example:) |
(Example:) |
( /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def) |
( /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def) |
( /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def) |
( /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def) |
( /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def) |
( /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def) |
( ma (dog) getNode ) |
( ma (dog) getNode ) |
|
(Example 2:) |
|
( [ [1 ] [2 3] [[(dog) 2]]] (dog) getNode ::) |
]] putUsages |
]] putUsages |
|
|
/cons { |
/cons { |
Line 4254 $ [ff ff] fromVectors :: $ |
|
Line 4283 $ [ff ff] fromVectors :: $ |
|
[(list listToArray a) |
[(list listToArray a) |
]] putUsages |
]] putUsages |
|
|
/makeInfix { |
% Body is moved to smacro.sm1 |
[(or_attr) 4 4 -1 roll ] extension |
|
} def |
|
[(makeInfix) |
[(makeInfix) |
[(literal makeInfix) |
[(literal makeInfix) |
(Change literal to an infix operator.) |
(Change literal to an infix operator.) |
Line 4345 $ [ff ff] fromVectors :: $ |
|
Line 4372 $ [ff ff] fromVectors :: $ |
|
[(a b setMinus c) |
[(a b setMinus c) |
]] putUsages |
]] putUsages |
|
|
|
% Define some infix operators |
|
/~add~ { add } def /~add~ makeInfix |
|
/~sub~ { sub } def /~sub~ makeInfix |
|
/~mul~ { mul } def /~mul~ makeInfix |
|
/~div~ { div } def /~div~ makeInfix |
|
/~power~ { power } def /~power~ makeInfix |
|
/~put~ { |
|
dup tag 3 eq { exec } { } ifelse put |
|
} def |
|
/~put~ makeInfix |
|
|
|
/toTokensBySpace { |
|
/arg1 set |
|
[(cgiToTokens) arg1 [ ]] extension |
|
} def |
|
[(toTokensBySpace) |
|
[ |
|
( string toTokensBySpace token_array ) |
|
]] putUsages |
|
|
|
/setAttributeList { |
|
/arg2 set |
|
/arg1 set |
|
[ |
|
[(setAttributeList) arg1 arg2] extension /arg1 set |
|
] pop |
|
arg1 |
|
} def |
|
/getAttributeList { |
|
/arg1 set |
|
[(getAttributeList) arg1] extension |
|
} def |
|
/setAttribute { |
|
/arg3 set |
|
/arg2 set |
|
/arg1 set |
|
[ |
|
[(setAttribute) arg1 arg2 arg3] extension /arg1 set |
|
] pop |
|
arg1 |
|
} def |
|
/getAttribute { |
|
/arg2 set |
|
/arg1 set |
|
[(getAttribute) arg1 arg2] extension |
|
} def |
|
[(setAttributeList) |
|
[ |
|
(ob attr setAttributeList new-obj ) |
|
(Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set ) |
|
]] putUsages |
|
[(setAttribute) |
|
[ |
|
(ob key value setAttribute new-obj ) |
|
(Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set ) |
|
]] putUsages |
|
[(getAttributeList) |
|
[ |
|
(ob getAttributeList attr-obj ) |
|
(Example: [(x-1) (y-1)] [(gb) 1] setAttributeList /ff set ) |
|
( ff getAttributeList :: ) |
|
]] putUsages |
|
[(getAttribute) |
|
[ |
|
(ob key getAttribute value ) |
|
(Example: [(x-1) (y-1)] (gb) 1 setAttribute /ff set ) |
|
( ff (gb) getAttribute :: ) |
|
]] putUsages |
; |
; |
|
|
|
|