|
/pliant/language/basic/shunt.pli |
|
1 |
# Copyright Hubert Tonneau hubert.tonneau@pliant.cx | |
2 |
# | |
3 |
# This program is free software; you can redistribute it and/or | |
4 |
# modify it under the terms of the GNU General Public License version 2 | |
5 |
# as published by the Free Software Foundation. | |
6 |
# | |
7 |
# This program is distributed in the hope that it will be useful, | |
8 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of | |
9 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
10 |
# GNU General Public License for more details. | |
11 |
# | |
12 |
# You should have received a copy of the GNU General Public License | |
13 |
# version 2 along with this program; if not, write to the Free Software | |
14 |
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
15 |
| |
16 |
scope "/pliant/language/" "/pliant/install/" | |
17 |
module "/pliant/install/ring2.pli" | |
18 |
| |
19 |
| |
20 |
abstract | |
21 |
['shunt' Pliant language control] | |
22 |
doc | |
23 |
['shunt' is a rather complicated control.] ; eol | |
24 |
[Let's assume that we are tying to compile:] | |
25 |
listing | |
26 |
shunt c1 v1 c2 v2 c3 v3 v4 | |
27 |
para | |
28 |
[The hard part of it is to decide the type of the end result will be. ] | |
29 |
[This is done through first testing if all v3 v3 v4 can be casted to the type of v1, ] | |
30 |
[and if not, testing if all v1 v3 v4 can be casted to the type of v2, and so on. ] | |
31 |
[The code for this part is the long 'while' loop.] | |
32 |
para | |
33 |
[The second part, that build the set of instructions is very classical.] | |
34 |
[The end result program will be (this is not a valid Pliant listing, but rather a symbolic program):] | |
35 |
listing | |
36 |
if not c1 jump part2 | |
37 |
r := v1 | |
38 |
jump end | |
39 |
part2: | |
40 |
if not c2 jump part3 | |
41 |
r := v2 | |
42 |
jump end | |
43 |
part3: | |
44 |
if not c3 jump part4 | |
45 |
r := v3 | |
46 |
jump end | |
47 |
part4: | |
48 |
r := v4 | |
49 |
end: | |
50 |
[Keep in mind that in the low level Pliant compiling engine, there are no more high level controls such as 'if' and 'while', only jump and conditional jump instructions.] ; eol | |
51 |
[The instructions are not build sequencialy: this is very common since if an instruction needs to jump or conditional jump to another one, then it's easyer to first build the target instructions rather than setting the jump parameter in the source instruction at a later point. ] | |
52 |
[On the other hand, the built instructions are added sequencialy to the expression instructions list.] ; eol | |
53 |
[Lastly, each argument must be suckuped before it's result be used. 'suckup' means insert the set of instructions that compute the argument in the expression instructions list.] | |
54 |
| |
55 |
| |
56 |
meta shunt e | |
57 |
# we must have at least three arguments and an odd number | |
58 |
if e:size<3 or e:size%2<>1 | |
59 |
return | |
60 |
# the first, third, fiveth, ... must be booleans | |
61 |
for (var Int i) 0 e:size-3 step 2 | |
62 |
if not (e:i cast CBool) | |
63 |
return | |
64 |
var Int base := -1 # indice of the argument we are going to test of the final type | |
65 |
var Pointer:Type type # the type of the result of the 'shunt' | |
66 |
var CBool ok := false # does the type fit ? | |
67 |
while not ok | |
68 |
# 'base' is 1, then 3, then 5, ... , and finaly then the last argument | |
69 |
# so is the indice of v1 v2 v3 v4 arguments in our example | |
70 |
base := base+2 | |
71 |
if base>e:size | |
72 |
return # the type of none of the arguments can be the result | |
73 |
eif base=e:size | |
74 |
base := base-1 | |
75 |
# test if the argument can be compile | |
76 |
e:base:compile | |
77 |
if error_notified | |
78 |
return | |
79 |
e:base:uncast # uncast it since previous loops may have cast it | |
80 |
type :> e:base:result:type # and extract the type of the argument result | |
81 |
# test if v1 v2 v3 v4 can all be casted to 'type' | |
82 |
ok := true | |
83 |
i := 1 | |
84 |
while ok and i<=e:size | |
85 |
if not (e:(min i e:size-1) cast type) | |
86 |
ok := false # one of the arguments cannot be casted to 'type' | |
87 |
i := i+2 | |
88 |
# so 'type' is now a type that all values can be casted to | |
89 |
var Link:Instruction end :> instruction the_function:'do nothing' | |
90 |
var Link:Instruction next :> instruction the_function:'do nothing' | |
91 |
var Link:Argument adr :> argument local Address | |
92 |
var Link:Argument result :> argument indirect type adr 0 | |
93 |
for (var Int i) 0 e:size-3 step 2 | |
94 |
e suckup e:i | |
95 |
e add (instruction (the_function 'jump if not' CBool) e:i:result jump next) | |
96 |
e suckup (e i+1) | |
97 |
e add (instruction (the_function 'address Universal' Universal -> Address) (e i+1):result adr) | |
98 |
e add (instruction the_function:'jump anyway' jump end) | |
99 |
e add next | |
100 |
next :> instruction the_function:'do nothing' | |
101 |
e add next | |
102 |
e suckup (e e:size-1) | |
103 |
e add (instruction (the_function 'address Universal' Universal -> Address) (e e:size-1):result adr) | |
104 |
e add end | |
105 |
e set_result result access_read | |
106 |
| |
107 |
export shunt | |
|