fogus (owner)

Revisions

gist: 162704 Download_button fork
public
Public Clone URL: git://gist.github.com/162704.git
Embed All Files: show embed
labels.qi #
raw 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

\Main macro\
(qi::defmacro labels
     [Defs Code] -> (LET ((qi::*tc* 'false)) 
			 (let F/Fs/Vis  (map label-declares Defs)
			      F/Fs  (map (/. X [(CAR X) (CADR X)]) F/FS/Vis)
			      Vis   (map (/. X (CADDR X))          F/FS/Vis)
			      Defs2 (substitute F/Fs Defs)
			      Code2 (substitute F/Fs Code)
			      Defs3 (map lab-fixup Defs2)
			      Code3 [do [do|Visi] Code2]
			    [label* Defs3 Code3])))
\sub 1\
(define label-declare
  [define F -visible     | Code] -> (get-sign-args F -visible     Code)
  [define F (-visible G) | Code] -> (get-sign-args F (-visible G) Code)
  [define F              | Code] -> (get-sign-args F  no          Code))
 
(define get-sign-args
  F Vis Code -> (let Err        (FORMAT NIL "Error in label definition for local dun ~a" F)
		     Sign/Rules (compile <define*> Err)
		     Sign       (CAR  Sign/Rules)
		     TrueSign   (if (= Sign no) [] [(head Code)])
		     GlF        (if (= Vis  -visible) F (CADR Vis))
		     Rules      (CADR Sign/Rules)
		     Arity      (aritycheck labels Rules)   
		     Vars       (va-gensyms Arity)
		     Fn         (gensym "f")
 
	        (do (eval (! define Fn ,Vars -> 1))
		    (if (not (= Sign no))
			(declare Fn Sign)
			ok)		    
		    [F Fn (if (= Visi no) 
			      [] 
			      (! eval (! define GlF 
					TrueSign 
					,Vars -> (FUNCALL (FUNCTION Fn) ,Vars))))])))
 
(defcc <define*>
  <signature> <rules>  := [<signature> <rules>];
  <rules>              := [no          <rules>);)
 
  
(define substitute
  []        Code -> Code
  [[N M]|L] Code -> (substitute L (SUBST M N Code)))
 
 
(define lab-fixup
  [define F -visible     | Code] -> [define* F | Code]
  [define F (-visible G) | Code] -> [define* F | Code]
  [define F              | Code] -> [define* F | Code])
 
 
\
Type code
\
(specialice label*)
(datatype labeltype
  V    : labeldef;
  Code : A
  ====================
 
  (labels V Code) : A;
  
  _____________
  [] : labeldef
 
  F  : A;
  Fs : labeldef;
  _________________
  [F|Fs] : labeldef;)
 
 
\
Dave and mark inspired code to make compile a function def to actual code
\
 
(define compile_fun*
  Vars Rules ->
  (let ErrString (FORMAT NIL "fun* syntax error in ~{~S ~}" Rules)
    (compile <match> [Vars | Rules] ErrString)))
 
(defcc <fun*>  
  <local-vars> <rules> 
  := 
   (compile-fun*-to-machine-code <local-vars> <rules>);)
 
(defcc <local-vars>
  -*- := -*-;) 
 
(define compile-fun*-to-machine-code
  LclVars Rules -> (let Lambda+ (compile-fun*-to-lambda Rules)
		     (compile-fun-to-lisp LclVars Lambda+))
 
(define compile-fun*-to-lambda
  Rules -> (let   Arity        (aritycheck fun* Rules)
	          Variables    (parameters Arity)
		  Linear       (map linearise Rules)
		  Abstractions (map abstract-rule Linear)
		  Applications (map (/. X (application_build Variables X))
				    Abstractions)
	      [Variables Applications]))
 
(define fun*-failure
  -> (error "Fun* failure"))
 
(define compile-fun*-to-lisp
  LclVars Args [Variables Applications] 
  ->
  (let   Reduce         (map reduce Applications)
         CondExpression (cond-expression fun*-failure (append LclVars
							     Variables) Reduce)
         Lisp           (optimise-lisp (value *speed*) [DEFUN dummy-name Variables CondExpression])
      (CDR (CDR Lisp))))
 
 
\
in t* we add
_______________________
t*((mode [[define* F | Def] : A] -), Hyps)
               :- !,
                  fwhen((symbol? (lazyderef F))),
                  bind(S+Def, (sigdef (lazyderef F) (lazyderef Def))),
                  bind(S, 
                       (normalise-type (curry-type (head (tail (lazyderef S+Def)))))),
                  bind(SS, (specialise-type (lazyderef S))),
                  =(A,S),
                  bind(Rules, 
                       (rule+rules F (elim-backtrack (head (lazyderef S+Def))))),
                  tfun(Rules, SS, [[F : SS]|Hyps], 1, F),
                  fundeclare(F, S).
 
 
and in lisp-code add
_________________________
 Vs [define* F   | Rules] -> (compile_fun* Vs Rules) 
 
\