labels.qi

\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) 

\