Lambda syntax (closures)

This code has been declared by its author to be Public Domain code.

Lambda syntax (closures) by Yasha

2012

MAYBE IF I JUST PUSH A LITTTTLE HARDER THIS SQUARE PEG WILL FIT IN THAT ROUND HOLE

...ahem.

This library (which is not short, simple, or clean, but anyway) adds support to Blitz3D/+ for lambda forms: anonymous functions, closures, and nested or "inner" function blocks.

No, no magic involved. The system is inspired by Boost::Lambda, although lacking templates or overloading, it's nowhere near as seamless. The method is really very simple: actions are packaged up using "thunk constructors" that have a name that visually indicates what you want to do, but actually return a delayed evaluation that can be invoked later on. The challenge is mainly in making it look tidy enough to use. Thus, we can write code like this:

Local L = Func("x", Add("x", 5))

...to put a "function" in L which adds 5 to its argument (when it is called later, using CallFunc). Well ain't that handy! You can then use this to pass custom functions inline to list sorts, store event handlers directly in GUI component objects, and so on! Basically this is a very marginal improvement on simply using inlined scripting language code.

Local variables to a closure are named using string literals (case-sensitive, can't begin with "@"); the last argument to Func is the closure's body expression (all closures must take at least one argument, and may take up to eight; you can combine two statements into one body expression with a "Do" block). You can pass values directly into expressions to bind them into the function objects - as we did with the number 5 above, and can therefore use "external" variables as well:

Function MakeAdder(n)
    Return Func("x", Add(n, "x"))
End Function

Every time you call MakeAdder, it'll return a shiny new function that will increment its argument by whatever it closed over. How handy. Note that since there's a distinction between code that runs immediately (normal Blitz functions) and code that secretly packages delayed actions (lambda code/thunks), if you want to do something similar to the above using only lambdas (create a "curried function"), you need to do it like this:

Local MakeAdder = Func("n", Lambda("x", Add("n", "x")))
Local adder = CallFunc(MakeAdder, 5)

"Lambda" is to "Func" as "Add" is to "+": it's the thunking-form for use within closures, as opposed to Func which returns a value immediately to Blitz code. There's also "Apply" to use instead of "CallFunc" within lambdas (Apply is thunking, CallFunc is value-returning).

If you want to close over strings or floats, you should package them with LString and LFloat (unpack results with GetLString and GetLFloat respectively). This is because the lambda constructors make minor use of strings for representing internal values, and also (as you can see) variable names; and CallFunc only deals in integers (the bundled math functions are int-only anyway for the moment).

There's also an "inner function" form:

Function GetPrinter(count)
    Local p = InnerFunc("x", "y")
        tWrite LString("Hello ")
        tPrint "x"
        Loop("n", 1, count, tPrint(IntToString("n")))
        tWrite LString("Goodbye ")
        tPrint "y"
    EndFunc
    
    Return p
End Function

CallFunc(GetPrinter(3), LString("Alice"), LString("Bob"))

; Prints:
; Hello Alice
; 1
; 2
; 3
; Goodbye Bob

This function returns its two-parameter inner function after closing-over the "count" environment. (If using IDEal or something else that "corrects" indentation, you might want to wrap the nested instructions in a Repeat/Until True block so they indent.) You'll also notice that those member statements that would have the same name as their normal Blitz code counterparts ("Print") are prefixed with a small t ("tPrint"), to avoid name clashes. There are a few others like this in the library. Even though nested functions are multi-line, they're still limited to using one-liner control blocks (unless of course you nest further inner functions within them...). Replicating the syntax of control structures too would be going a bit far.

Built-in control structures in the Basis library include tIf (which functions as a ternary operator), tWhile, Loop (a bit like For), tDelay and Force (implementing futures and promises), Let (names a local variable for use in the body expression), Do (multiple statements), and Fixpoint (allows recursion). Control structures are properly lazy (i.e. tIf will only evaluate the correct arm, and ignore the other), and all of them return a value, usually the last value evaluated (this is the Functional Programming Way). It is possible to change the value of variables, with SetVar, but do try to avoid it if at all possible (it is never necessary to set a variable, but sometimes the obvious option... and tWhile won't work if you never mutate anything). Among other things this will kinda highlight the fact that closures don't actually share environment objects.

Contrary to what you might expect, there are no Lisp-style list or cons manipulation functions. I figure it makes more sense to write them to suit an existing List library (such as my own... this will happen shortly), and also because without a garbage collector it becomes very hard indeed to keep track of "ownership" of such resources, and would probably just get confusing really quickly.

On the subject of memory management, using lambdas without a garbage collector is usually a real pain: to alleviate this slightly, by default this library is set up to allocate objects using my AutoReleasing semiautomatic-garbage-collector. This will take some of the pain out of tracking the lifetimes of lambda objects (all of it, in fact, if you never return them past the border of an AutoRelease block). If you really want to manually manage memory, you can comment out the AutoRelease code without breaking the library, as the library's inner workings don't use it, with one exception: LString. You'll have a very hard time keeping track of new Lambda objects though.

The Basis library also includes a WithAutoReleasePool function, which creates and clears an AutoRelease pool around the body expression, to isolate its allocations and tighten up memory use (obviously, comment this if you are working without AutoRelease).

(Using AutoRelease conversely introduces a bug which I can't be bothered to address: LStrings are AutoReleased separately from the functions, so closed-over LStrings may be freed before their supposed owners are, which will crash. Design around this.)

Basis Library, "Lambda-Basis.bb":

; Lambda Basis library
;======================

; Predefined math and HO constructors to make it easy to get started using lambdas


;Memory management (required only for LString/input-output):
Include "AutoRelease.bb"	;Get this file at <a href="http://www.blitzbasic.com/codearcs/codearcs.php?code=2978" target="_blank">http://www.blitzbasic.com/codearcs/codearcs.php?code=2978</a>


; Constructors (use these to build functions):
;=============================================

; Constructors all have the same form: call MakeThunk with the implementation function
; pointer, and the arguments. A function with variable arguments must give the number
; in the final parameter; a lazy function must give the number as a negative


; Math (integer only)

Function Add$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Add_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Sub$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Sub_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Mul$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Mul_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Div$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Div_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function tMod$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : tMod_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Pow$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Pow_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function ShiftL$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : ShiftL_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function ShiftR$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : ShiftR_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function ShiftAR$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : ShiftAR_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Less$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Less_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Greater$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Greater_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function LessEq$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : LessEq_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function GreaterEq$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : GreaterEq_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function Equal$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : Equal_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function NEqual$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : NEqual_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function tAnd$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : tAnd_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function tOr$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : tOr_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function tXor$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : tXor_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function

Function tNot$(l$, r$)
	Local fptr = FunctionPointer() : Goto skip : tNot_Impl 0
	.skip
	Return MakeThunk(fptr, l, r)
End Function


; Control flow

Function tIf$(cond$, ThenT$, ElseT$)
	Local fptr = FunctionPointer() : Goto skip : tIf_Impl 0
	.skip
	Return MakeThunk(fptr, cond, ThenT, ElseT, "", "", "", "", "", "", -3)	;Lazy function must give all args
End Function

Function tWhile$(cond$, body$)
	Local fptr = FunctionPointer() : Goto skip : tWhile_Impl 0
	.skip
	Return MakeThunk(fptr, cond, body, "", "", "", "", "", "", "", -2)
End Function

Function Loop$(v$, f$, t$, body$)
	Local fptr = FunctionPointer() : Goto skip : Loop_Impl 0
	.skip
	Return MakeThunk(fptr, f, t, Lambda(v, body), "", "", "", "", "", "", -3)
End Function

Function tDelay$(t$)
	Return Lambda("*delay*", t)		;Do not treat this as a lambda! Implementation detail!
End Function

Function Force$(p$)
	Local fptr = FunctionPointer() : Goto skip : Force_Impl 0
	.skip
	Return MakeThunk(fptr, p)
End Function

Function Let$(var$, val$, body$)
	Return Apply(Lambda(var, body), val)
End Function

Function Do$(a0$, a1$ = "", a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "")
	Local c = 1 + (a1 <> "") + (a2 <> "") + (a3 <> "") + (a4 <> "") + (a5 <> "") + (a6 <> "") + (a7 <> "")
	Local fptr = FunctionPointer() : Goto skip : Do_Impl 0
	.skip
	Return MakeThunk(fptr, c, a0, a1, a2, a3, a4, a5, a6, a7, -9)
End Function

Function SetVar$(var$, val$)
	Local fptr = FunctionPointer() : Goto skip : SetVar_Impl 0
	.skip
	Return MakeThunk(fptr, var, val, "", "", "", "", "", "", "", -2)
End Function


; Functional primitives

Function Compose$(f$, g$)
	Return Lambda("x", Apply(f, Apply(g, "x")))		;Another macro
End Function

Function bFixpoint(F)	;Immediate version
	Return Func("x", Apply(tFixpoint(F), "x"))
End Function

Function tFixpoint$(f$)		;Thunking version
	Local fptr = FunctionPointer() : Goto skip : tFixpoint_Impl 0
	.skip
	Return MakeThunk(fptr, f)
End Function

Function Identity$(id$)
	Local fptr = FunctionPointer() : Goto skip : Identity_Impl 0
	.skip
	Return MakeThunk(fptr, id)
End Function

Function bGenerator(start, var$, thisVal$, nextVal$)
	Local fptr = FunctionPointer() : Goto skip : bGenerator_Impl 0
	.skip
	Local cV$ = Lambda(var, thisVal), nV$ = Lambda(var, nextVal)	;Using Lambda assigns ownership to the generator, not Auto
	Return Func("*GENERATOR*", MakeThunk(fptr, start, cV, nV, "", "", "", "", "", "", -3))
End Function

Function tGenerator$(start$, var$, thisVal$, nextVal$)
	Local fptr = FunctionPointer() : Goto skip : tGenerator_Impl 0
	.skip
	Return MakeThunk(fptr, start, var, thisVal, nextVal, "", "", "", "", "", -4)
End Function


; Input and output

Function tPrint$(s$)
	Local fptr = FunctionPointer() : Goto skip : tPrint_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function tWrite$(s$)
	Local fptr = FunctionPointer() : Goto skip : tWrite_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function tDebugLog$(s$)
	Local fptr = FunctionPointer() : Goto skip : tDebugLog_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function tInput$(s$)
	Local fptr = FunctionPointer() : Goto skip : tInput_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function


; Data types (pack floats and strings into ints - not thunks!)
; These are for use in "main" Blitz code, not in lambdas

Function LFloat(f#)
	If Not LAMBDA_private_FB_ Then LAMBDA_private_FB_ = CreateBank(4)
	PokeFloat LAMBDA_private_FB_, 0, f : Return PeekInt(LAMBDA_private_FB_, 0)
End Function

Function GetLFloat#(f)
	PokeInt LAMBDA_private_FB_, 0, f : Return PeekFloat(LAMBDA_private_FB_, 0)
End Function

Function LString(s$)
	Local ls.tLString = New tLString
	ls\val = s
	Local freePtr = FunctionPointer() : Goto skip : FreeTLString ls	;Comment these lines if not using AutoRelease
	.skip
	ls\rc = NewRefCounted(freePtr, TypePointer(ls))
	AutoRelease ls\rc	;Strongly advised not to use LString without AutoRelease
	Return Handle ls
End Function

Function GetLString$(s)
	Local ls.tLString = Object.tLString s
	Return ls\val
End Function


; Data type thunk constructors (type conversion *actions*: for use in lambdas)

Function IntToFloat$(s$)
	Local fptr = FunctionPointer() : Goto skip : IntToFloat_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function IntToString$(s$)
	Local fptr = FunctionPointer() : Goto skip : IntToString_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function FloatToInt$(s$)
	Local fptr = FunctionPointer() : Goto skip : FloatToInt_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function FloatToString$(s$)
	Local fptr = FunctionPointer() : Goto skip : FloatToString_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function StringToInt$(s$)
	Local fptr = FunctionPointer() : Goto skip : StringToInt_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function

Function StringToFloat$(s$)
	Local fptr = FunctionPointer() : Goto skip : StringToFloat_Impl 0
	.skip
	Return MakeThunk(fptr, s)
End Function


; Memory management (fairly obviously relies on AutoRelease)

Function WithAutoReleasePool(body$)
	Local fptr = FunctionPointer() : Goto skip : WithAutoReleasePool_Impl 0
	.skip
	Return MakeThunk(fptr, body, "", "", "", "", "", "", "", "", -1)
End Function


; Implementations (don't call these directly):
;==============================================

; Implementations provide the function pointers stored by constructors. These all
; have the same signature: they must accept a single argument/return bank, and may
; only return a value by poking it to the bank. The bank contains a four-byte slot
; for each argument (inc. optionals), plus four bytes at the end for the return
; value. Implementations MUST NOT modify the argument slots, or risk corrupting
; shared data.
; Lazy functions receive their environment thunk in the arg slot.


; Math (integer only)

Function Add_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) + PeekInt(argv, 4)
End Function

Function Sub_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) - PeekInt(argv, 4)
End Function

Function Mul_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) * PeekInt(argv, 4)
End Function

Function Div_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) / PeekInt(argv, 4)
End Function

Function tMod_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Mod PeekInt(argv, 4)
End Function

Function Pow_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) ^ PeekInt(argv, 4)
End Function

Function ShiftL_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Shl PeekInt(argv, 4)
End Function

Function ShiftR_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Shr PeekInt(argv, 4)
End Function

Function ShiftAR_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Sar PeekInt(argv, 4)
End Function

Function Less_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) < PeekInt(argv, 4)
End Function

Function Greater_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) > PeekInt(argv, 4)
End Function

Function LessEq_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) <= PeekInt(argv, 4)
End Function

Function GreaterEq_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) >= PeekInt(argv, 4)
End Function

Function Equal_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) = PeekInt(argv, 4)
End Function

Function NEqual_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) <> PeekInt(argv, 4)
End Function

Function tAnd_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) And PeekInt(argv, 4)
End Function

Function tOr_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Or PeekInt(argv, 4)
End Function

Function tXor_Impl(argv)
	PokeInt argv, 8, PeekInt(argv, 0) Xor PeekInt(argv, 4)
End Function

Function tNot_Impl(argv)
	PokeInt argv, 4, Not PeekInt(argv, 0)
End Function


; Control flow

Function tIf_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 12)
	Local cond = GetLazyThunkArgValue(ith, 0)
	If cond Then PokeInt argv, 12, GetLazyThunkArgValue(ith, 1) : Else PokeInt argv, 12, GetLazyThunkArgValue(ith, 2)
End Function

Function tWhile_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 8), val
	While GetLazyThunkArgValue(ith, 0)
		val = GetLazyThunkArgValue(ith, 1)
	Wend
	PokeInt argv, 8, val
End Function

Function Loop_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 12)
	Local i, L, val, fromVal = GetLazyThunkArgValue(ith, 0), toVal = GetLazyThunkArgValue(ith, 1)
	If fromVal < toVal
		For i = fromVal To toVal
			L = GetLazyThunkArgValue(ith, 2) : val = CallFunc(L, i)
		Next
	Else
		For i = fromVal To toVal Step -1
			L = GetLazyThunkArgValue(ith, 2) : val = CallFunc(L, i)
		Next
	EndIf
	PokeInt argv, 12, val
End Function

Function Force_Impl(argv)
	Local L.Closure = Object.Closure PeekInt(argv, 0)
	If L\expr <> Null
		PokeInt L\argv, 0, CallFunc(Handle L, 0)
		FreeThunk L\expr
		ResizeBank L\argv, 4
	EndIf
	PokeInt argv, 4, PeekInt(L\argv, 0)
End Function

Function Do_Impl(argv)
	Local c = PeekInt(argv, 0), val, i, ith.Thunk = Object.Thunk PeekInt(argv, 36)
	For i = 1 To c
		val = GetLazyThunkArgValue(ith, i)
	Next
	PokeInt argv, 36, val
End Function

Function SetVar_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 8), val = GetLazyThunkArgValue(ith, 1)
	PokeInt ith\env\argv, ith\val[0], val
	PokeInt argv, 8, val
End Function


; Functional primitives

Function tFixpoint_Impl(argv)
	Local F = PeekInt(argv, 0)
	PokeInt argv, 4, CallFunc(F, bFixpoint(F))
End Function

Function Identity_Impl(argv)
	PokeInt argv, 4, PeekInt(argv, 0)
End Function

Function bGenerator_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 12), start = PeekInt(argv, 0)	;Start value is strict for this one
	Local cV.Thunk = Object.Thunk ith\val[1], nV.Thunk = Object.Thunk ith\val[2]	;Cannot directly evaluate these
	PokeInt argv, 0, CallFunc(nV\val[0], start) : PokeInt argv, 12, CallFunc(cV\val[0], start)
End Function

Function tGenerator_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 16), start = GetLazyThunkArgValue(ith, 0)
	Local cV$ = Lambda(ith\argn[1], "@" + Handle CopyThunkInner(Object.Thunk ith\val[2]))
	Local nV$ = Lambda(ith\argn[1], "@" + Handle CopyThunkInner(Object.Thunk ith\val[3]))
	BindFuncEnvironment GetLambdaFunc(cV), ith\env : BindFuncEnvironment GetLambdaFunc(nV), ith\env
	
	Local fptr = FunctionPointer() : Goto skip : bGenerator_Impl 0	;Sneakily now thunk over bGenerator
	.skip
	PokeInt argv, 16, Func("*GENERATOR*", MakeThunk(fptr, start, cV, nV, "", "", "", "", "", "", -3))
End Function


; Input and output

Function tPrint_Impl(argv)
	Print GetLString(PeekInt(argv, 0))
	PokeInt argv, 4, PeekInt(argv, 0)
End Function

Function tWrite_Impl(argv)
	Write GetLString(PeekInt(argv, 0))
	PokeInt argv, 4, PeekInt(argv, 0)
End Function

Function tDebugLog_Impl(argv)
	DebugLog GetLString(PeekInt(argv, 0))
	PokeInt argv, 4, PeekInt(argv, 0)
End Function

Function tInput_Impl(argv)
	Local s$ = Input(GetLString(PeekInt(argv, 0)))
	PokeInt argv, 4, LString(s)
End Function


; Data types (value)

Global LAMBDA_private_FB_	;Private typecasting bank

Type tLString
	Field rc.RefCounted, val$
End Type

Function FreeTLString(s.tLString)
	Delete s
End Function


; Data types (thunk)

Function IntToFloat_Impl(argv)
	PokeInt argv, 4, LFloat(Float PeekInt(argv, 0))
End Function

Function IntToString_Impl(argv)
	PokeInt argv, 4, LString(Str PeekInt(argv, 0))
End Function

Function FloatToInt_Impl(argv)
	PokeInt argv, 4, Int GetLFloat(PeekInt(argv, 0))
End Function

Function FloatToString_Impl(argv)
	PokeInt argv, 4, LString(Str GetLFloat(PeekInt(argv, 0)))
End Function

Function StringToInt_Impl(argv)
	PokeInt argv, 4, Int GetLString(PeekInt(argv, 0))
End Function

Function StringToFloat_Impl(argv)
	PokeInt argv, 4, LFloat(Float GetLString(PeekInt(argv, 0)))
End Function


; Memory management

Function WithAutoReleasePool_Impl(argv)
	Local ith.Thunk = Object.Thunk PeekInt(argv, 8), val, p.AutoReleasePool
	p = NewAutoReleasePool()
	val = GetLazyThunkArgValue(ith, 1)
	ClearAutoReleasePool p
	Return val
End Function


;~IDEal Editor Parameters:
;~F#15#1B#21#27#2D#33#39#3F#45#4B#51#57#5D#63#69#6F#75#7B#81#8A
;~F#90#96#9C#A0#A6#AA#B1#BA#BE#C2#C8#CE#D5#DE#E4#EA#F0#FA#FF#103
;~F#10D#115#11B#121#127#12D#133#13C#151#155#159#15D#161#165#169#16D#171#175#179#17D
;~F#181#185#189#18D#191#195#199#1A0#1A6#1AE#1BA#1C4#1CC#1D5#1DA#1DE#1E4#1F2#1F7#1FC
;~F#201#20B#20F#216#21A#21E#222#226#22A#231
;~C#Blitz3D

The evaluation system is not tail-call optimised. This means unlimited recursion is not safe, and absolutely will result in a stack overflow crash (in fact, since one function call actually requires four or five function calls, it will do it even sooner than regular Blitz code). Use the looping primitives, or call out to a normal Blitz function, to take care of such things: this is just a bit of FP-icing for Blitz, not a full programming style replacement! The same goes for other functionality: don't be afraid to call out to normal B3D code (you'll have to, to do anything interesting). The Basis library should make it fairly clear how to add more thunking functions for the lambda engine to use, both eager (normal) and lazy (control).

The actual lambda library is very small and only really consists of lambda constructors and the evaluation functions. Most of the useful stuff (some integer math, input and output, control structures) is in the Basis library, "Lambda-Basis.bb". ~~I have not tested the performance of this engine. I assume it's comparable to interpreted bytecode~~ (there's a lot of boilerplate, but conversely there are also a lot of "real" function calls doing all the hard work). This engine is significantly slower than native code, or even a decent interpreter; if you need to care about performance, you're probably thinking of a task that shouldn't be handled by lambda code: if necessary, create a new thunk around a native Blitz function (I will create a faster JITting version some other time). There's also very little error-checking: no type-checks, and no checks to see whether variable references are actually valid. Many errors will result in crashes; try not to make them (luckily functional-style code is easier to write without errors anyway).

Here are some more crappy examples:

; Lambda library example

Include "Lambda.bb"
Include "AutoRelease.bb"	;Memory management uses AutoRelease by default (doesn't have to)


Graphics 800, 600

Local p.AutoReleasePool = NewAutoReleasePool()


Local f = Func("x", Add("x", 5))
;Local t.Thunk = Object.Thunk Int Mid(Add(3, 5), 2)

;Print EvalThunk(t, Null)	;You'd normally never do this - don't use Thunks on their own
Print CallFunc(f, 9)

Local f2 = Func("x", Lambda("y", Add("x", "y")))	;"Curried" function allows partial application
Local f3 = CallFunc(f2, 42)

Print CallFunc(f3, 47)

Local i : For i = 1 To 3
	Print CallFunc(CallFunc(f2, i), 5)
Next

Local f4 = Func("x", Apply(f3, "x"))
Print CallFunc(f4, 29)

Local f5 = Func("x", Apply(Lambda("y", Add("x", "y")), 24))
Print CallFunc(f5, 29)

Local f6 = Func("x", tIf("x", Add(5, 3), Add(9, 12)))
Write "true: "
Print CallFunc(f6, 1)
Write "false: "
Print CallFunc(f6, 0)

;(Using [Repeat..Until True] provides auto-indentation that IDEal won't remove)
Local f7 = InnerFunc("x", "y") : Repeat
	Add("x", "y")
	Add(1, "y")
	Apply(Lambda("x", "y", Add("x", Add("x", "y"))), 5, 6)
	Add("x", 1)
	tPrint LString("Hello world!")
	Add(1, Add(2, 3))
Until True : EndFunc

Print CallFunc(f7, 12, 23)

Local f8 = Func("x", Let("y", Add("x", 1), Add("y", "y")))
Print CallFunc(f8, 5)

Print "" : Print "Adder factory: 5 + [1..10]"
For i = 1 To 10
	Print CallFunc(AdderFactory(i), 5)	;Call newly-created adder functions
Next


;Nested function factory
Function GetPrinter(count)
    Local p = InnerFunc("x", "y") : Repeat
		tWrite LString("Hello ")
		tPrint "x"
		Loop("n", 1, count, tPrint(IntToString("n")))
		tWrite LString("Goodbye ")
		tPrint "y"
	Until True : EndFunc
	
	Return p
End Function

Print ""
CallFunc(GetPrinter(3), LString("Alice"), LString("Bob"))

Print ""	;Multi-statement inline function
CallFunc Func("x", Do(tPrint(LString("one")), tPrint(LString("two")), tPrint(LString("three")))), 0


; Fixpoint combinator. Oh yes, I went there. THIS **** JUST GOT REAL
Local Y = Func("F", Let("R", Lambda("G", Apply("F", Lambda("A", Apply(Apply("G", "G"), "A")))), Apply("R", "R")))
Print ""

Local facY = Func("F", Lambda("x", tIf(LessEq("x", 0), 1, Mul("x", Apply("F", Sub("x", 1))))))
Local fac = CallFunc(Y, facY)
Print "Fac 10 using manual Y: " + CallFunc(fac, 10)

Local fibY = Func("F", Lambda("x", tIf(Less("x", 2), "x", Add(Apply("F", Sub("x", 1)), Apply("F", Sub("x", 2))))))
Local fib = CallFunc(Y, fibY)
Print "Fib 10 using manual Y: " + CallFunc(fib, 10)

Local fac2 = bFixpoint(facY)	;"bFixpoint" is the evaluating version, "tFixpoint" is thunking
Print "Fac 10 using Fixpoint: " + CallFunc(fac2, 10)
Local fib2 = bFixpoint(fibY)
Print "Fib 10 using Fixpoint: " + CallFunc(fib2, 10)


;Futures and promises
Local delayed = Func("x", tDelay(Do(tWrite(LString("[First evaluation...] ")), Add("x", 13))))
Print ""
Local promise = CallFunc(delayed, 12)
Print CallFunc(Func("prom", Force("prom")), promise)
Print CallFunc(Func("prom", Force("prom")), promise)	;Observe that it is only "run" once, then memoised

;Generators
Print ""
Local G1 = bGenerator(1, "n", Mul(2, "n"), Add("n", 1))	;Direct generator expression (returns to Blitz code)
Write "Even numbers generator: "
For i = 1 To 10
	Write CallFunc(G1) + " "
Next
Print ""

Local G2 = CallFunc(Func("x", tGenerator("x", "n", Mul(2, "n"), Add("n", "x"))), 3)	;Thunking generator expression
Write "Multiples of six generator: "
For i = 1 To 10
	Write CallFunc(G2) + " "
Next
Print ""


ClearAutoReleasePool p

WaitKey
End


Function AdderFactory(inc)
	Return Func("x", Add("x", inc))		;Close over a Blitz environment!
End Function


;~IDEal Editor Parameters:
;~C#Blitz3D

Yeah, that's right, that's a fixed-point combinator in classic Blitz Basic code.

As it stands, this library depends on AutoRelease for "garbage collection", available from the code archives (although this can be removed at your peril). It also requires the free FastPointer DLL by Mikhail Vostrikov, for working with real function pointers in Blitz Classic (it is possible to engineer a similar library to work without this, but it would be painful. Don't ask me to show you how).

Enjoy!

; Lambda library for Blitz3D/+
;==============================

; Requires FastPointer DLL (free): http://www.fastlibs.com/index.php


;Memory management (optional, but extremely useful)
Include "AutoRelease.bb"	;Get this file at http://www.blitzbasic.com/codearcs/codearcs.php?code=2978

;Basis library (useful predefined constructor functions)
Include "Lambda-Basis.bb"	;Get this file at http://www.blitzbasic.com/codearcs/codearcs.php?code=2992


Type Closure
	Field rc.RefCounted		;Remove this if not using AutoRelease
	Field argn$[9], env.Closure
	Field expr.Thunk, argv
End Type

Type Thunk
	Field argn$[9], isVarName	;isVarName = bit array; upper bits are "isThunk", bit 30 is "isBound"
	Field val[9], argv			;val = args passed in (inc. thunks, vars), argv = evaluated args passed to fptr
	Field fptr, argc, env.Closure	;Function pointer, arg count (neg for isLazy), calling lambda
End Type


Const LAMBDA_APPLY_CONSTPTR = 1
Global LAMBDA_private_CIF_.Closure


;Create an inline anonymous function and return it to external Blitz code
Function Func(a0$, a1$, a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "", a8$ = "", doAR = True)
	Local argc = 2 + (a2 <> "") + (a3 <> "") + (a4 <> "") + (a5 <> "") + (a6 <> "") + (a7 <> "") + (a8 <> "")
	Local f.Closure = MakeClosureInner(doAR)
	f\argn[0] = a0 : f\argn[1] = a1 : f\argn[2] = a2 : f\argn[3] = a3 : f\argn[4] = a4
	f\argn[5] = a5 : f\argn[6] = a6 : f\argn[7] = a7 : f\argn[8] = a8
	
	If Asc(f\argn[argc - 1]) <> 64 Then RuntimeError "Expecting thunk as body expression of lambda function"
	f\expr = Object.Thunk Int Mid(f\argn[argc - 1], 2)
	If LAMBDA_private_CIF_ <> Null Then PurgeThunkTreeFromCIF f\expr, LAMBDA_private_CIF_\expr
	
	Return Handle f
End Function

;Create an inline anonymous function and return it to closure code
Function Lambda$(a0$, a1$, a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "", a8$ = "")
	Return MakeThunk(0, Func(a0, a1, a2, a3, a4, a5, a6, a7, a8, False))
End Function

;Invoke a closure with arguments
Function CallFunc(L, a0 = 0, a1 = 0, a2 = 0, a3 = 0, a4 = 0, a5 = 0, a6 = 0, a7 = 0, a8 = 0)
	Local F.Closure = Object.Closure L 
	If Not F\argv Then F\argv = CreateBank(9 * 4)
	Local tmp[8], i, val : For i = 0 To 8
		tmp[i] = PeekInt(F\argv, i * 4)
	Next
	PokeInt F\argv,  0, a0 : PokeInt F\argv,  4, a1 : PokeInt F\argv,  8, a2
	PokeInt F\argv, 12, a3 : PokeInt F\argv, 16, a4 : PokeInt F\argv, 20, a5
	PokeInt F\argv, 24, a6 : PokeInt F\argv, 28, a7 : PokeInt F\argv, 32, a8
	val = EvalThunk(F\expr, F)
	For i = 0 To 8
		PokeInt F\argv, i * 4, tmp[i]
	Next
	Return val
End Function

;Invoke a closure with arguments and return it to closure code
Function Apply$(L$, a0$ = "", a1$ = "", a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "")
	Return MakeThunk(1, L, a0, a1, a2, a3, a4, a5, a6, a7, 9)
End Function

;Define a new nested inner function
Function InnerFunc(a0$, a1$ = "", a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "", a8$ = "")
	Local argc = 2 + (a2 <> "") + (a3 <> "") + (a4 <> "") + (a5 <> "") + (a6 <> "") + (a7 <> "") + (a8 <> "")
	Local f.Closure = MakeClosureInner(True)
	f\argn[0] = a0 : f\argn[1] = a1 : f\argn[2] = a2 : f\argn[3] = a3 : f\argn[4] = a4
	f\argn[5] = a5 : f\argn[6] = a6 : f\argn[7] = a7 : f\argn[8] = a8
	
	f\expr = Object.Thunk Int Mid(MakeThunk(0, ""), 2)	;Call before setting CIF!
	f\expr\argv = CreateBank(0) : f\expr\argc = 0
	f\env = LAMBDA_private_CIF_ : LAMBDA_private_CIF_ = f
	
	Return Handle f
End Function

;End a nested inner function definition
Function EndFunc()
	LAMBDA_private_CIF_ = LAMBDA_private_CIF_\env
End Function

;Manually free closure objects
Function FreeFunc(L.Closure)
	If L\expr <> Null Then FreeThunk L\expr
	If L\argv Then FreeBank L\argv
	Delete L
End Function

;(Internal) Internal constructor for closure objects: uses AutoRelease by default
Function MakeClosureInner.Closure(doAR)
	Local L.Closure = New Closure
	If doAR
		Local freePtr = FunctionPointer() : Goto skip : FreeFunc L	;Comment these lines if not using AutoRelease
		.skip
		L\rc = NewRefCounted(freePtr, TypePointer(L))
		AutoRelease L\rc
	EndIf
	Return L
End Function

;(Internal) Copy closure objects (for use with Lambda)
Function CopyFuncInner.Closure(L.Closure, doAR)
	Local C.Closure = MakeClosureInner(doAR), i
	For i = 0 To 8
		C\argn[i] = L\argn[i]
	Next
	If L\expr <> Null Then C\expr = CopyThunkInner(L\expr)
	If L\argv Then C\argv = CreateBank(BankSize(L\argv)) : CopyBank L\argv, 0, C\argv, 0, BankSize(L\argv)
	C\env = L\env
	Return C
End Function

;(Internal) Attach an environment to a function to form a complete closure
Function BindFuncEnvironment(L.Closure, env.Closure)
	If env <> Null
		L\argv = CreateBank(BankSize(env\argv) + 9 * 4)
		CopyBank env\argv, 0, L\argv, 9 * 4, BankSize(env\argv)
	Else
		L\argv = CreateBank(9 * 4)
	EndIf
	L\env = env
End Function

;(Internal) Get the Func out of a lambda-thunk for manual processing
Function GetLambdaFunc.Closure(lam$)
	Local L.Thunk = Object.Thunk Int Mid(lam, 2)
	Return Object.Closure L\val[0]
End Function

;(Internal) Package a delayed action
Function MakeThunk$(fptr, a0$, a1$ = "", a2$ = "", a3$ = "", a4$ = "", a5$ = "", a6$ = "", a7$ = "", a8$ = "", maxArgC = 0)
	Local t.Thunk = New Thunk, i
	If maxArgC
		t\argc = maxArgC
	Else	;Count them
		t\argc = 1 + (a1 <> "") + (a2 <> "") + (a3 <> "") + (a4 <> "") + (a5 <> "") + (a6 <> "") + (a7 <> "") + (a8 <> "")
	EndIf
	t\fptr = fptr
	t\argn[0] = a0
	If fptr
		t\argn[1] = a1 : t\argn[2] = a2 : t\argn[3] = a3 : t\argn[4] = a4
		t\argn[5] = a5 : t\argn[6] = a6 : t\argn[7] = a7 : t\argn[8] = a8
		t\argv = CreateBank((Abs t\argc) * 4 + 4)
	EndIf
	For i = 0 To (Abs t\argc) - 1
		If Asc(t\argn[i]) = 64 Then t\val[i] = Int Mid(t\argn[i], 2) : Else t\val[i] = Int t\argn[i]
	Next
	If LAMBDA_private_CIF_ <> Null	;Add statement to InnerFunc, but remove child expressions from it
		For i = 0 To (Abs t\argc) - 1
			If Asc(t\argn[i]) = 64 Then RemoveThunkFromCIF Object.Thunk t\val[i], LAMBDA_private_CIF_\expr
		Next
		LAMBDA_private_CIF_\expr\argc = LAMBDA_private_CIF_\expr\argc + 1
		ResizeBank LAMBDA_private_CIF_\expr\argv, LAMBDA_private_CIF_\expr\argc * 4
		PokeInt LAMBDA_private_CIF_\expr\argv, (LAMBDA_private_CIF_\expr\argc - 1) * 4, Handle t
	EndIf
	Return "@" + Handle t
End Function

;(Internal) Copy a Thunk (for use with Lambda)
Function CopyThunkInner.Thunk(t.Thunk)
	Local i, C.Thunk = New Thunk
	C\fptr = t\fptr : C\argc = t\argc : C\isVarName = t\isVarName
	If t\argv Then C\argv = CreateBank(BankSize(t\argv)) : CopyBank t\argv, 0, C\argv, 0, BankSize(t\argv)
	If t\fptr
		For i = 0 To (Abs t\argc - 1)
			If Asc(t\argn[i]) = 64
				C\val[i] = Handle CopyThunkInner(Object.Thunk t\val[i]) : C\argn[i] = "@" + C\val[i]
			Else
				C\val[i] = t\val[i] : C\argn[i] = t\argn[i]
			EndIf
		Next
	Else
		If t\argv	;An InnerFunc
			For i = 0 To t\argc - 1
				PokeInt C\argv, i * 4, Handle CopyThunkInner(Object.Thunk PeekInt(t\argv, i * 4))
			Next
		Else		;A lambda thunk
			C\val[0] = Handle CopyFuncInner(Object.Closure t\val[0], False)
		EndIf
	EndIf
	Return C
End Function

;(Internal) Free a delayed action
Function FreeThunk(t.Thunk)
	Local i
	If t\fptr
		For i = 0 To (Abs t\argc) - 1
			If Asc(t\argn[i]) = 64 Then FreeThunk Object.Thunk t\val[i]
		Next
		FreeBank t\argv
	Else
		If t\argv	;An InnerFunc
			For i = 0 To t\argc - 1
				FreeThunk Object.Thunk PeekInt(t\argv, i * 4)
			Next
			FreeBank t\argv
		Else		;A lambda thunk
			FreeFunc Object.Closure t\val[0]
		EndIf
	EndIf
	Delete t
End Function

;(Internal) Evaluate a delayed action
Function EvalThunk(t.Thunk, env.Closure)
	Local i, val
	
	If t\fptr	;It's an action thunk
		If Not t\isVarName
			For i = 0 To (Abs t\argc) - 1
				If Asc(t\argn[i]) = 64
					t\isVarName = t\isVarName Or (1 Shl (i + 9))
				Else
					Local idx = GetThunkArgBinding(t\argn[i], env)
					If idx
						t\val[i] = idx - 1 : t\isVarName = t\isVarName Or (1 Shl i)
					Else
						PokeInt t\argv, i * 4, t\val[i]		;Simple value, poke it here (so we only do it once)
					EndIf
				EndIf
			Next
			t\isVarName = t\isVarName Or (1 Shl 30)	;Set a very high bit to nonzero
		EndIf
		
		If t\argc < 0
			t\env = env : PokeInt t\argv, (Abs t\argc) * 4, Handle t	;Lazy thunks need an eval environment
		Else
			Local tmp[9]
			For i = 0 To t\argc - 1
				If t\isVarName And (1 Shl (i + 9))
					tmp[i] = EvalThunk(Object.Thunk t\val[i], env)
				EndIf
			Next
			For i = 0 To t\argc - 1
				If t\isVarName And (1 Shl i)
					PokeInt t\argv, i * 4, PeekInt(env\argv, t\val[i])
				ElseIf t\isVarName And (1 Shl (i + 9))
					PokeInt t\argv, i * 4, tmp[i]
				EndIf
			Next
		EndIf
		
		If t\fptr = LAMBDA_APPLY_CONSTPTR	;Apply (change this to check against Apply's actual fptr sometime)
			Local F = PeekInt(t\argv, 0), a0 = PeekInt(t\argv, 4), a1 = PeekInt(t\argv, 8), a2 = PeekInt(t\argv, 12), a3 = PeekInt(t\argv, 16)
			Return CallFunc(F, a0, a1, a2, a3, PeekInt(t\argv, 20), PeekInt(t\argv, 24), PeekInt(t\argv, 28), PeekInt(t\argv, 32))
		Else
			CallFunctionVarInt t\fptr, t\argv
			Return PeekInt(t\argv, (Abs t\argc) * 4)
		EndIf
		
	Else
		If t\argv	;It's an InnerFunc
			For i = 0 To t\argc - 1		;If we're here, t\argc should never be negative
				val = EvalThunk(Object.Thunk PeekInt(t\argv, i * 4), env)
			Next
			Return val
			
		Else		;It's a thunk of lambda: return copy of value to CallFunc
			Local L.Closure = CopyFuncInner(Object.Closure t\val[0], True)
			If Not L\argv Then BindFuncEnvironment L, env
			Return Handle L
		EndIf
	EndIf
End Function

;(Internal) Find the offset of a name in the var table of the environment
Function GetThunkArgBinding(arg$, env.Closure)
	If arg = "" Then Return 0
	Local i, count : While env <> Null
		For i = 0 To 8
			If env\argn[i] = arg Then Return count + 1
			count = count + 4
		Next
		env = env\env
	Wend
	Return 0
End Function

;(Internal) Evaluate a packaged action lazily
Function GetLazyThunkArgValue(t.Thunk, a)
	If t\isVarName And (1 Shl a)
		Return PeekInt(t\env\argv, t\val[a])
	ElseIf t\isVarName And (1 Shl (a + 9))
		Return EvalThunk(Object.Thunk t\val[a], t\env)
	Else
		Return PeekInt(t\argv, a * 4)
	EndIf
End Function

;(Internal) Remove thunks from the current inner function if they shouldn't be there
Function PurgeThunkTreeFromCIF(t.Thunk, cif.Thunk)
	Local i
	RemoveThunkFromCIF t, cif
	If t\fptr
		For i = 0 To (Abs t\argc) - 1
			If Asc(t\argn[i]) = 64 Then PurgeThunkTreeFromCIF Object.Thunk t\val[i], cif
		Next
	Else
		Local f.Closure = Object.Closure t\val[0]
		PurgeThunkTreeFromCIF f\expr, cif
	EndIf
End Function

;(Internal) Remove one thunk (see above)
Function RemoveThunkFromCIF(t.Thunk, cif.Thunk)
	Local ht = Handle t, i
	For i = 0 To BankSize(cif\argv) - 4 Step 4
		If PeekInt(cif\argv, i) = ht
			CopyBank cif\argv, i + 4, cif\argv, i, BankSize(cif\argv) - (i + 4)
			ResizeBank cif\argv, BankSize(cif\argv) - 4
			cif\argc = cif\argc - 1
			Return
		EndIf
	Next
End Function


;~IDEal Editor Parameters:
;~F#E#14#20#2E#33#44#49#57#5C#63#6F#7B#86#8C#A9#C2#D7#115#122#12D
;~F#13B
;~C#Blitz3D

Comments

None.

Code Archives Forum