Code archives/Miscellaneous/PsychoScript v0.5
This code has been declared by its author to be Public Domain code.
Download source code
| |||||
So this is the first simple stages of my scripting language. I'm releasing this to GPU cause it's a bit sloppy. But yeah, you can add to it. Just make sure I get a bit of credit please! :) It has the feature of creating classes with functions and variables. Variables can hold integers floats and characters. You can also conform it to your app by creating custom functions, call-backs, and classes/objects. So that means it can be highly modifiable. I will release some classes and function modules later if this gets popular. !!!!!!!!!!!!!!!TEST SCRIPT! SAVE THIS AS "SIMPLEAPP.PS"!!!!! //THIS SIMPLE SCRIPT ASKS FOR THE USERS NAME AND GREETS THEM //========================================================== //Create new object from the stdio class. obj std = new stdio //Calls the custom module STD for an input function. //std.input saves data to std.buffer std.input("Whats your name? ") print("Hello there "+std.buffer+"! Welcome to the party!") std.input("Whats your age? ") var age%=std.buffer if age>=18 print("Wow! Your an adult!") else print("Cool! Still young!") endif !!!!!!!!!!!!!!!!!!!!!!TEST APPLICATION!!!!!!!!!!!!!!!!!!!!! Graphics 640,480,16,2 AppTitle "Simple Scripting Application" Include "ScriptEngine2.bb" Initialize(True) If Not LoadScript("SimpleApp") Then PromptError() ExecuteScript("SimpleApp") If CheckErrors() Then PromptError() Destroy() Print "<END OF SCRIPT>" WaitKey() End Function CallFunction(name$,param$) Select name$ Case "stdio::input" param$ = TrimEnds(param$) SetClassVariable(obj\name$,"buffer",dqt$+Input(param$)+dqt$) Default AddError("The requested function does not exist!","CallFunction") End Select End Function Function ClassConstructor.class(className$,objectName$) Select className$ Case "stdio" temp.class = New class temp\className$="stdio" temp\name$=objectName$ SetClassVariable(objectName$,"buffer","","$") Return temp Default AddError("The requested class does not exist!","ClassConstructor") End Select End Function | |||||
;Globals and other variables. ;============================ Global debug_mode=True,debug_file Global last_error$,isError=False Global last_tokcnt% Global el$ = Chr$(10) + Chr$(13) Global tb$ = Chr$(9) Global dqt$ = Chr$(34) Global inIf,isTrue=False,wasFalse=False Global inFunction,runStart%,runFinish%,runTime% Global temp1$,temp2$,temp3$,temp4$ Type error Field msg$,caller$ End Type Global er.error Type token Field value$,id% End Type Global tk.token,tk2.token ;===VARIABLE TYPE=== Type variable Field name$,kind%,parent$ Field vStr$,vFlt#,vInt%,vFnc$ ;STRING$, FLOAT#, INTEGER%, FUNCTION-POINTER& End Type Global var.variable ;===COMPLEX CLASSES=== Type class Field name$,className$ End Type Global obj.class Type scrLine Field value$,parent$ End Type Type fncLine Field value$,parent$ End Type Type script Field name$,ln.scrLine End Type Global scr2.script Type func Field name$,params$,fln.fncLine End Type Global fnc.func,fncE.func ;Initializing and routine functions ;================================== Function AddError(msg$,caller$) er.error=New error er\msg$=msg$ er\caller$=caller$ last_error$ = "["+caller$+"]: "+msg$ DebugOut("! ERROR: "+last_error$) End Function Function PrintErrors() For er.error = Each error Print "["+er\caller$+"]: "+er\msg$ Next End Function Function ClearErrors() For er.error = Each error Delete er Next last_error$="" isError=False End Function Function CheckErrors(caller$="") For er.error = Each error If caller$="" If er\msg$<>"" Then Return True Else If caller$=er\caller$ And er\msg$<>"" Then Return True EndIf Next End Function Function PromptError() ;Formats a runtimerror message for you! No using variables now! msg$ = "AN ERROR HAS ACCURED:"+el$ msg$ = msg$ + tb$ +last_error$+el$ msg$ = msg$ + tb$ +"You can review the debug.log file for more information,"+el$ msg$ = msg$ + tb$ +"there could also be more errors found there."+el$ RuntimeError(msg$) End Function Function Initialize%(dbg%=False) debug_mode = dbg% If dbg% debug_file=WriteFile("Debug.log") ;Just clear and write If Not debug_file AddError("Could not write debug log file!","Initialize") Return False EndIf DebugOut("DEBUG LOG STARTED!") DebugOut("DATE: "+CurrentDate$()) DebugOut("TIME: "+CurrentTime$()) DebugOut("==================") EndIf End Function Function Destroy() If debug_mode CloseFile(debug_file) EndIf End Function Function DebugOut(msg$) If debug_mode=True If debug_file<>0 WriteLine(debug_file,msg$) Else AddError("Debug file could not be writen to!","DebugOut") EndIf EndIf End Function Function PrintDebug%() Local dfile = ReadFile("debug.log") If Not dfile AddError("Could not load debug log file!","PrintDebug") Return False EndIf While Not Eof(dfile) Print ReadLine(dfile) Wend CloseFile(dfile) Return True End Function ;PARSING AND TOKENIZER FUNCTIONS ;=============================== Function SimpleTokenize(inp$,sep$,prsvQt=True) ;This tokenizes by given character. ;Always sets ID To -1 for seperation. prsvQt option is for excluding sep$ charecters in quotes. Local temp$,char$,stk.token,qt=False For i = 1 To Len(inp$) char$ = Mid(inp$,i,1) If char$=sep$ If qt=False And prsvQt=True stk.token = New token stk\id% = -1 stk\value$ = temp$ temp$="" EndIf Else If char$=dqt$ qt=Not qt Else temp$=temp$+char$ EndIf EndIf Next If Len(temp$)>0 stk.token = New token stk\id% = -1 stk\value$ = temp$ temp$="" EndIf End Function Function AdvancedTokenize(inp$,id%=0,smb%=0) ;This tokenizes by symbols and characters! Spiffy huh? ;Allows for stack ordering with the id% parameter ;smb% is to start tokenizing by symbols first. Local temp$,mode%=smb Local char$,kind%,qt=False,par=False For i = 1 To Len(inp$) char$ = Mid(inp$,i,1) ;Check type of character symbol or character! kind%=1 If Asc(char$)>=48 And Asc(char$)<=57;Number, counts as character kind%=0 Else If Asc(Lower(char$))>=97 And Asc(Lower(char$))<=122;letter kind%=0 Else If Asc(char$)=34 ;Quotes count too! SET QUOTE MODE kind%=0 qt = Not qt Else If Asc(char$)<>32 ;don't count spaces, symbol! kind%=1 EndIf ;Check last type with mode and add to temp If Not mode% ;characters If Not kind% ;If character temp$=temp$+char$ Else ;Broke loop add token and switch If qt=False If Trim(temp$)<>"" Then PushToken(temp$,id%) If Trim(char$)<>"" Then PushToken(char$,id%) mode%=1 Else temp$=temp$+char$ EndIf EndIf Else ;Symbols If kind% If Trim(char$)<>"" Then PushToken(char$,id%) Else ;Broke loop add token and switch back temp$=char$;Right(temp$,Len(temp$)-1) mode%=0 EndIf EndIf Next If temp$<>"" PushToken(temp$,id%) EndIf End Function Function PushToken(inp$,id%) ;Pushes a token to stack. Dunno why. tk.token = New token tk\value$ = inp$ tk\id% = id% last_tokcnt% = last_tokcnt% + 1 End Function Function PullToken$(id%=-1,del=True) ;Pull first token of matching ID, deletes after if del=True Local rtn$ For tk.token = Each token If tk\id%=id% Or id%=-1 rtn$=tk\value$ If del=True Delete tk EndIf Exit EndIf Next Return rtn$ End Function Function GetToken$(pos%,id%=-1) ;Will retrieve token # Local num% For tk.token = Each token If tk\id%=id% Or id%=-1 num%=num%+1 If num%=pos% Return tk\value$ EndIf EndIf Next AddError("Token number does not exist! Check ID# or Position#","GetToken()") Return "" End Function Function GotoToken%(pos%) Local cnt% For tk.token = Each token cnt%=cnt%+1 If cnt%=pos% Return True EndIf Next AddError("Token number does not exist! Check ID# or Position#","GotoToken()") Return False End Function Function GetNextToken$(id%=0) If id%=0 tk = After tk Return tk\value$ Else Repeat tk = After tk Until tk\id% = id% Return tk\value$ EndIf End Function Function ClearTokens(id%=-1) For tk.token = Each token If tk\id%=id% Or id%=-1 Delete tk EndIf Next last_tokcnt%=0 End Function Function DebugTokens(id%=-1) Local temp$ For tk.token = Each token If tk\id%=id% Or id%=-1 temp$=temp$+"'"+tk\value$+"' " EndIf Next DebugOut("~ TOKENS: "+temp$) End Function Function ContainsChar(inp$) ;Checks only for letters If Asc(Lower(inp$))>=97 And Asc(Lower(inp$))<=122 Return True EndIf Return False End Function Function TrimEnds$(inp$,amnt=1) ;Trims off the ends Return Mid(inp$,1+amnt,Len(inp$)-(1+amnt)) End Function ;DATA EDITING ;============ Function SetClassVariable(clName$,varName$,varValue$,varType$="$") ;Formats a variable to this... ; var [ClassName]_[VarName] = [VALUE] parent to cl_[ClassName] SetVariable(clName$+"_"+varName$,varValue$,varType$,"cl_"+clName$) End Function Function GetClassVariable$(objName$,varName$) ;Returns the value from a obj.var run Return FillVariable(objName$+"_"+varName$,True) End Function Function SetVariable(vname$,vvalue$,vtype$="$",parent$="",noChange=False) Local found=False For var.variable = Each variable If var\name$=vname$ And var\parent$=parent$;Change value If noChange=True Return False EndIf Select var\kind% Case 1 ;String vvalue$ = Mid(vvalue$,2,Len(vvalue$)-2) ;Strip quotes var\vStr$=vvalue$ Case 2 ;Float var\vFlt#=Float(vvalue$) Case 3 ;Integer var\vInt%=Int(vvalue$) Case 4 ;Function Pointer vvalue$ = Mid(vvalue$,2,Len(vvalue$)-2) ;Strip quotes var\vFnc$=vvalue$ Default AddError("Memory Access Violation, variable type incorrect!","SetVariable") End Select EndIf Next If Not found var.variable = New variable var\name$ = vname$ var\parent$ = parent$ Select vtype$ Case "$" var\kind%=1 vvalue$ = Mid(vvalue$,2,Len(vvalue$)-2) ;Strip quotes var\vStr$=vvalue$ Case "#" var\kind%=2 var\vFlt#=Float(vvalue$) Case "%" var\kind%=3 var\vInt%=Int(vvalue$) Case "&" var\kind%=4 vvalue$ = Mid(vvalue$,2,Len(vvalue$)-2) ;Strip quotes var\vFnc$=vvalue$ Default AddError("Memory Access Violation, variable type incorrect!","SetVariable") End Select EndIf End Function Function FillVariable$(inp$,clr=True) ;Returns variable value as string ;CLR is whether to return empty "" if not found, else return original input For var.variable = Each variable If var\name$ = inp$ Select var\kind% Case 1 ;String Return var\vStr$ Case 2 ;Float Return Str(var\vFlt#) Case 3 ;Integer Return Str(var\vInt%) Case 4 ;Function Pointer Return var\vFnc$ Default AddError("Memory Access Violation, variable type incorrect!","FillVariable") End Select EndIf Next Return inp$ End Function ;SCRIPTING FUNCTIONS ;=================== Function CreateNewScript%(name$) ;Pretty easy huh? Works off the global variable scr2.script to add to ;Search if name is taken For scr2.script = Each script If scr2\name$ = name$ AddError("A script with that name already exists!","CreateNewScript") Return False EndIf Next scr2.script = New script scr2\name$ = name$ DebugOut("- INFO: Created new script named '"+name$+"'") Return True End Function Function AddLineToScript%(inp$,name$) ;Add line of inp$ to script named name$ If Trim(inp$)="" Then Return True If Left(inp$,2)="//" Then Return True For scr2.script = Each script If scr2\name$ = name$ ;!!! Parse inputting line! inp$ = Replace(inp$,Chr$(9),"") ClearTokens() AdvancedTokenize(inp$) tk.token = First token Select Lower(Trim(tk\value$)) Case "function" If inFunction=True AddError("Can not declare function inside of another!","AddLineToScript") Return False EndIf temp1$ = GetNextToken$() temp2$ = "" temp3$ = "" If GetNextToken$()="(" ;Just make sure For i=1 To last_tokcnt%-3 temp$ = GetNextToken$() If temp$=")" ;Ship out parameters Exit Else If temp$="," ;Register variable SetVariable(Left(temp3$,Len(temp3$)-1),"",Right(temp3$,1),temp1$,True) temp3$ = temp3$ + temp$ temp2$ = temp2$ + temp3$ temp3$ = "" Else temp3$ = temp3$ + temp$ EndIf EndIf Next If Len(temp3$)<>0 SetVariable(Left(temp3$,Len(temp3$)-1),"",Right(temp3$,1),temp1$,True) temp3$ = temp3$ + temp$ temp2$ = temp2$ + temp3$ temp3$ = "" EndIf ;!!! NOW SAVE FUNCTION AND SET TO READ MODE! fnc.func = New func fnc\name$ = temp1$ fnc\params$ = temp2$ inFunction = True Else AddError("Incorrect format for function!","AddLineToScript") EndIf Case "endfunction" ;Now end it! If Not inFunction AddError("Function must first be initialized before ended!","AddLineToScript") Return False EndIf inFunction = False Default ;Just add the line to the script If Not inFunction scr2\ln.scrLine = New scrLine scr2\ln\parent$ = name$ scr2\ln\value$ = inp$ Else fnc\fln.fncLine = New fncLine fnc\fln\parent$ = fnc\name$ fnc\fln\value$ = inp$ EndIf End Select Return True EndIf Next AddError("Could not add line to script named '"+name$+"'!","AddLineToScript") Return False End Function Function LoadScript%(name$) ;Loads a script named 'Scripts\'+name$+'.ps' For scr2.script = Each script If scr2\name$ = name$ AddError("A script with that name already exists!","LoadScript") Return False EndIf Next file = ReadFile("Scripts\"+name$+".ps") If Not file AddError("Could not find file named Scripts\"+name$+".ps!","LoadScript") Return False EndIf scr2.script=New script scr2\name$=name$ While Not Eof(file) AddLineToScript(ReadLine(file),name$) Wend CloseFile(file) DebugOut("- INFO: Loaded script with name '"+name$+"'") Return True End Function Function ExportScript(name$) ;Exports the script, results is after pre-parseing. ;Only useful if saving programaticly generated scripts. Its de-commented and de-blank-lined For scr2.script = Each script If scr2\name$ = name$ Local temp = WriteFile("Scripts\"+name$+"_exp.ps") For scr2\ln.scrLine = Each scrLine If scr2\ln\parent$ = name$ WriteLine(temp,scr2\ln\value$) EndIf Next CloseFile(temp) EndIf Next End Function Function ExecuteScript(name$) runStart% = MilliSecs() Local found=False For scr2.script = Each script If scr2\name$ = name$ found = True Exit EndIf Next If Not found Then AddError("No script found with the name '"+name$+"'","ExecuteScript") ;Now we can start execution. We don't bother with ; characters. each line is a single call. For scr2\ln.scrLine = Each scrLine If scr2\ln\parent$ = name$ ClearTokens() AdvancedTokenize(scr2\ln\value$) ;BUILD TOKEN BANK DebugTokens() ;PRINT OUT THE TOKENS ParseTokens() ;ILLETERATE AND PARSE (NO IDEA ABOUT ID NUMS) EndIf Next runFinish% = MilliSecs() runTime% = runFinish%-runStart% DebugOut("- INFO: Time to execute = "+runTime%+"/ms") End Function Function ExecuteFunction() ;Works off global variable fncE.func for function to be executed For fncE\fln.fncLine = Each fncLine If fncE\fln\parent$ = fncE\name$ ClearTokens() AdvancedTokenize(fncE\fln\value$) DebugTokens() ParseTokens() EndIf Next End Function Function ParseTokens() ;Parsing! Check the first, then start formatting! tk.token = First token ;Some other functions set this to the end Select Lower(Trim(tk\value$)) ;Only need to check the first one Case "var" ;Settting variable! If inIf=False Or ifTrue=True temp1$=GetNextToken$() ;Name temp2$=GetNextToken$() ;Type If GetNextToken$()="=" ;Set initial value temp3$ = GetNextToken$() If last_tokcnt%>5 ;THERES MORE!?!? For i=1 To last_tokcnt%-5 temp3$=temp3$+GetNextToken$() Next temp3$ = ParseVariables(temp3$) EndIf Else ;Set empty If temp2$="$" temp3$="" Else temp3$="0" EndIf EndIf SetVariable(temp1$,temp3$,temp2$) DebugOut("- INFO: Variable '"+temp1$+"' was assigned '"+temp3$+"'!") EndIf Case "obj" ;Object handle If inIf=False Or ifTrue=True ;If statements... take up space but oh well temp1$=GetNextToken$() ;Object name If GetNextToken$()="=" ;As it should be temp2$=GetNextToken$() ;Operator, just use new Select temp2$ Case "new" temp3$=GetNextToken$() ;Class name! obj = ClassConstructor(temp3$,temp1$) Default AddError("Unknown creation operator!","ExecuteScript") End Select Else AddError("Expected = operator at object creation!","ExecuteScript") EndIf EndIf Case "if" isTrue=False If inIf=False inIf=True If (last_tokcnt%-1)>4 ;Muliple statements For i=1 To (last_tokcnt%-1)/4 Next Else ;Just a single statement temp1$=GetNextToken$() ;value 1 temp2$=GetNextToken$() ;operator temp3$=GetNextToken$() ;operator temp4$=GetNextToken$() ;value 2 temp1$=ParseVariables(temp1$) temp4$=ParseVariables(temp4$) If ContainsChar(temp1$)=False And ContainsChar(temp4$)=False var1#=Float(temp1$) var2#=Float(temp2$) EndIf DebugOut(temp1$+" "+temp2$+temp3$+" "+temp4$) If temp2$="=" And temp3$="=" ;EQUAL If temp1$=temp4$ Then isTrue=True Else If temp2$=">" And temp3$="=" ;LESS THEN EQUAL If temp1$>=temp4$ Then isTrue=True Else If temp2$="<" And temp3$="=" ;GREATER THEN EQUAL If temp1$<=temp4$ Then isTrue=True Else If temp2$=">" And temp3$=">" ;GREATER THEN If temp1$>temp4$ Then isTrue=True Else If temp2$="<" And temp3$="<" ;LESS THEN If temp1$<temp4$ Then isTrue=True Else If temp2$="<" And temp3$=">" ;NOT EQUAL If temp1$<>temp4$ Then isTrue=True Else If temp2$="!" And temp3$="=" ;NOT EQUAL If temp1$<>temp4$ Then isTrue=True Else AddError("ParseTokens::If - Invalid operator!","ExecuteScript") EndIf EndIf If isTrue=False wasFalse=True Else wasFalse=False DebugOut("False") EndIf Else AddError("ParseTokens::If - IF can only appear once in this statement!","ExecuteScript") EndIf Case "elseif" isTrue=False If inIf=True If wasFalse=True If (last_tokcnt%-1)>4 ;Muliple statements For i=1 To (last_tokcnt%-1)/4 Next Else ;Just a single statement temp1$=GetNextToken$() ;value 1 temp2$=GetNextToken$() ;operator temp3$=GetNextToken$() ;operator temp4$=GetNextToken$() ;value 2 temp1$=ParseVariables(temp1$) temp4$=ParseVariables(temp4$) If ContainsChar(temp1$)=False And ContainsChar(temp4$)=False var1#=Float(temp1$) var2#=Float(temp2$) EndIf DebugOut(temp1$+" "+temp2$+temp3$+" "+temp4$) isTrue=False If temp2$="=" And temp3$="=" ;EQUAL If temp1$=temp4$ Then isTrue=True Else If temp2$=">" And temp3$="=" ;LESS THEN EQUAL If temp1$>=temp4$ Then isTrue=True Else If temp2$="<" And temp3$="=" ;GREATER THEN EQUAL If temp1$<=temp4$ Then isTrue=True Else If temp2$=">" And temp3$=">" ;GREATER THEN If temp1$>temp4$ Then isTrue=True Else If temp2$="<" And temp3$="<" ;LESS THEN If temp1$<temp4$ Then isTrue=True Else If temp2$="<" And temp3$=">" ;NOT EQUAL If temp1$<>temp4$ Then isTrue=True Else If temp2$="!" And temp3$="=" ;NOT EQUAL If temp1$<>temp4$ Then isTrue=True Else AddError("ParseTokens::If - Invalid operator!","ExecuteScript") EndIf EndIf If isTrue=False wasFalse=True Else wasFalse=False DebugOut("False") EndIf EndIf Else AddError("ParseTokens::ElseIf - Requires an IF statement first!","ExecuteScript") EndIf Case "else" isTrue=False If inIf=True If wasFalse=True ;No true statements yet isTrue = True ;This one is true, execute script EndIf Else AddError("ParseTokens::Else - Requires an IF statement first!","ExecuteScript") EndIf Case "endif" If inIf=True inIf=False Else AddError("ParseTokens::EndIf - Requires an IF statement first!","ExecuteScript") EndIf Default ;Function! If inIf=False Or isTrue=True temp1$ = tk\value$ ;Function, or variable/object to change temp2$ = GetNextToken$() ;If ( then parse for function, else if = then variable temp3$ = "" If temp2$ = "(" ;Dealing with Function For i=1 To last_tokcnt%-2 temp$ = GetNextToken$() If temp$=")" ;Ship out parameters Exit Else temp3$ = temp3$ + temp$ EndIf Next RunFunction(temp1$,temp3$) Else If temp2$ = "=" ;Re-assigning variable temp3$ = GetNextToken$() If last_tokcnt%>3 ;THERES MORE!?!? For i=1 To last_tokcnt%-3 temp3$=temp3$+GetNextToken$() Next temp3$ = ParseVariables(temp3$) EndIf SetVariable(temp1$,temp3$) Else If temp2$ = "." ;Object operation temp2$ = GetNextToken$() ;Var Name, or function name temp4$ = GetNextToken$() If temp4$ = "=" ;Setting variable temp3$ = GetNextToken$() If last_tokcnt%>5 ;THERES MORE!?!? For i=1 To last_tokcnt%-5 temp3$=temp3$+GetNextToken$() Next temp3$ = ParseVariables(temp3$) EndIf SetClassVariable(temp1$,temp2$,temp3$) DebugOut("SETTING TO var "+temp1$+"."+temp2$+"="+temp3$) Else temp4$ = "(" For i=1 To last_tokcnt%-4 temp$ = GetNextToken$() If temp$=")" ;Ship out parameters Exit Else temp3$ = temp3$ + temp$ EndIf Next For obj.class = Each class If obj\name$ = temp1$ ;Getting className$ temp2$=obj\className$+"::"+temp2$ ;Compile the function for calling Exit EndIf Next CallFunction(temp2$,temp3$) EndIf Else ;Show error AddError("ParseTokens::Default - Unknown command, or incorrect format!","ExecuteScript") EndIf EndIf End Select End Function Function ParseVariables$(inp$) ;Fills variables AND Formats string concenations Local temp$,temp2$,found,mode% ClearTokens() AdvancedTokenize(inp$) For tk.token = Each token found=False For tmp.class = Each class If tk\value$=tmp\name$ ;Heres a class! If GetNextToken$()="." tname$=GetNextToken$() temp2$=FillVariable(tmp\name$+"_"+tname$,True) temp2$=Replace(temp2$,dqt$,"") ;Remove quotes temp$ = temp$ + temp2$ DebugOut("- INFO: Filled class variable "+tmp\name$+"."+tname$+" with "+temp2$) found=True Exit Else AddError("A period after the object name is required!","ParseVariable") EndIf EndIf Next If found=False temp2$ = FillVariable(tk\value$,False) ;Fill all variables temp2$=Replace(temp2$,dqt$,"") ;Remove quotes temp$ = temp$ + temp2$ EndIf Next If ContainsChar(temp$) ;Concenation temp$ = Replace(temp$,"+","") ;This should do it. No advanced parsing Else temp$ = MathToString$(temp$) EndIf Return temp$ End Function Function ParseParameters(fname$,params$) ;Fills function variables with params Local toknum%=0,varnum%,found ClearTokens() SimpleTokenize(params$,",") For tk2.token = Each token If tk2\id%=-1 ;This is our simple tokens, each one is conveniently our parameter toknum%=toknum%+1 varnum%=0:found=False For var.variable = Each variable If var\parent$ = fname$ varnum% = varnum% + 1 If varnum% = toknum% ;Alignment is crucial found=True Select var\kind% Case 1 var\vStr$ = tk2\value$ Case 2 var\vFlt# = Float(tk2\value$) Case 3 var\vInt% = Int(tk2\value$) Case 4 var\vFnc$ = tk2\value$ End Select EndIf EndIf Next If Not found AddError("To many parameters!","ParseParameters") EndIf EndIf Next End Function Function RunFunction(fname$,fparam$) ;Function name, and compiled parameters. fparam$ = ParseVariables$(fparam$) ; Fill variables now DebugOut("- INFO: Function '"+fname$+"' called with parameter(s) '"+fparam$+"'") ;ORDER ENABLES OVER-RIDING! BEWARE! For fnc.func = Each func If fnc\name$=fname$ fncE = fnc ParseParameters(fname$,fparam$) ExecuteFunction() Return True EndIf Next Select Lower(fname$) ;Pick function, will parse parameters per function Case "print" ;OUR FIRST FUNCTION! Print ">"+fparam$ ;Simple huh. Doesn't parse number or params or anything Default CallFunction(Lower(fname$),fparam$) End Select End Function ;THIRD PARTY FUNCTIONS (I DIDN'T WRITE THESE BUT THEY ARE GNU) ;============================================================= Function MathToString$(TheMath$, unit = 0, divnow = 0) Local MyParam$ = "*/^+-=<>&|%@", MyNumbs$ = "0123456789.", MyDivParam$ = "*/^" Local Ziffer$, ScanPos, MathAnswer#, MathArt$, MathPower#, OldMathPower# Local Scan, ScanNumber$, OldScanNumber$, MathScan$, MyScanText$ Local bscan, bscannow, bscanhave, ScanPosA, ScanPosB Local deScan, deMathScan$, deMath Local debsScan TheMath$ = Lower(TheMath$) TheMath$ = Replace(TheMath$, "and", "&") TheMath$ = Replace(TheMath$, "xor", "@") TheMath$ = Replace(TheMath$, "or", "|") TheMath$ = Replace(TheMath$, "mod", "%") MathScan$ = Replace(TheMath$, " ", "") : debsScan = 1 While bscan < Len(MathScan$) bscan = bscan + 1 If Mid$(MathScan$, bscan, 1) = "(" Then ScanPosA = bscan : bscannow = 1 While bscannow If Mid$(MathScan$, bscan, 1) = "(" Then bscanhave = bscanhave + 1 If Mid$(MathScan$, bscan, 1) = ")" Then bscanhave = bscanhave - 1 If bscanhave = 0 Then bscannow = 0 bscan = bscan + 1 If KeyDown(1) Then End Wend ScanPosB = bscan MyScanText$ = Mid$(MathScan$, ScanPosA+1, ScanPosB - ScanPosA - 2) MyScanText$ = MathToString$(MyScanText$, unit + 1) MathScan$ = Replace(MathScan$, Mid$(MathScan$, ScanPosA, ScanPosB - ScanPosA), MyScanText$) bscan = 0 End If If KeyDown(1) Then End Wend .NewMathScan deMathScan$ = MathScan$ Scan = InMid$(MathScan$, MyParam$) If Scan Then ScanNumber$ = Mid$(MathScan$, 1, Scan-1) MathScan$ = Mid$(MathScan$, Scan) MathAnswer = val2(ScanNumber$) Else Return MathScan$ End If deScan = 1 While Not MathScan$ = "" uu$ = MathScan$ MathArt$ = Mid$(MathScan$, 1, 1) MathScan$ = Mid$(MathScan$, 2) If Mid$(MathScan$,1,1) = "-" Then MathPower# = -1 MathScan$ = Mid$(MathScan$, 2) Else MathPower# = 1 End If Scan = InMid$(MathScan$, MyParam$) OldScanNumber$ = ScanNumber$ OldMathPower# = MathPower# ScanNumber$ = Mid$(MathScan$, 1, Scan-1) MathScan$ = Mid$(MathScan$, Len(ScanNumber$)+1) If MathArt$ = "+" Then MathAnswer# = MathAnswer# + (val2(ScanNumber$)*MathPower#) ElseIf MathArt$ = "-" Then MathAnswer# = MathAnswer# - (val2(ScanNumber$)*MathPower#) ElseIf MathArt$ = "*" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) * (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "*-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "*" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "/" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) / (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "/-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "/" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "^" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) ^ (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "^-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "^" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "=" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) = (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "=-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "=" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "<" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) < (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "<-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "<" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = ">" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) > (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + ">-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + ">" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "&" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) And (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "&-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "&" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "|" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) Or (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "|-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "|" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "%" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) Mod (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "%-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "%" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan ElseIf MathArt$ = "@" Then MathAnswer# = (val2(OldScanNumber$)*OldMathPower#) Xor (val2(ScanNumber$)*MathPower#) If MathPower# = -1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "@-" + ScanNumber$, "-" + Str$(MathAnswer)) ElseIf MathPower# = 1 Then MathScan$ = Replace(deMathScan$, OldScanNumber$ + "@" + ScanNumber$, Str$(MathAnswer)) End If Goto NewMathScan Else Return "SYNTAX ERROR" End If Wend Return Str(MathAnswer) End Function Function InMid$(A$, B$) ; in benutzung Local C, Q, W C = 0 For Q = 1 To Len(A$) For W = 1 To Len(B$) If (Mid$(A$, Q, 1) = Mid$(B$, W, 1)) And C = 0 Then C = Q : Exit Next If C>0 Then Exit Next Return C End Function Function val2#(sstring$) Local temp#=0 Local decimal=0 Local sign=1 Local a Local b Local c Local base=10 a=Instr(sstring$,"-",1) If a Then negative=-1 b=Instr(sstring$,"&",a+1) If b Then Select Mid$(sstring$,a+1,1) Case "B", "b" base=2 a=b+1 Case "O", "o" base=8 a=b+1 Case "H", "h" base=16 a=b+1 Default base=10 End Select End If decimal=0 For b=a+1 To Len(sstring$) c=Asc(Mid(sstring$,b,1)) Select c Case 44 ;"," Goto skip Case 45 ;"-" sign=-sign Case 46 ;"." decimal=1 Case 48,49,50,51,52,53,54,55,56,57 ;"0" To "9" temp#=temp*base+c-48 If decimal Then decimal=decimal*base Case 65,66,67,68,69,60 ;"A" to "F" If base=16 Then temp#=temp#*base+c-55 If decimal Then decimal=decimal*base Else Goto fini EndIf Case 97,98,99,100,101,102 ;"a" to "f" If base=16 Then temp#=temp#*base+c-87 If decimal Then decimal=decimal*base Else Goto fini EndIf Default Goto fini End Select .skip Next .fini If decimal Then temp#=temp#/decimal If negative = -1 Then Return -(temp#*sign) Else Return temp#*sign End If End Function |
Comments
None.
Code Archives Forum