10 // SLPL/SCOR - Simple List Processsing Language 20 // Shock Course On Recursion 30 // Written in COMAL by Jos Visser 1987 40 // Adapted for PDComal by Jos Visser 1993 50 // OpenComal sample as of 2002 60 // (c) Copyright 1987-2004 Jos Visser 70 // Licensed for use under the GNU General Public License (GPL) 80 // 90 PRINT 100 PRINT "SLPL/SCOR -- Initialising...", 110 // 120 noids#:=100 // Number of identifiers 130 memsize#:=1500 // number of words in memory 140 // 150 DIM ident$(noids#) OF 32 160 DIM idtable#(noids#) 170 DIM memory#(memsize#) 180 DIM errmsg$ OF 80 190 DIM memmap$ OF memsize# 200 // 210 waserr#:=FALSE 220 quitslpl#:=FALSE 230 nofree#:=FALSE 240 // 250 list#:=0; atom#:=1 260 // 270 idlistptr#:=-1; firstptr#:=-2; restptr#:=-3 280 plusptr#:=-4; subtractptr#:=-5; multiplyptr#:=-6 290 divideptr#:=-7; quoteptr#:=-9; quitptr#:=-10 300 setptr#:=-11; evaluateptr#:=-12; saveptr#:=-14 310 loadptr#:=-15; makelistptr#:=-16; appendptr#:=-17 320 progptr#:=-18; ifptr#:=-19; greaterptr#:=-20; lessptr#:=-21 330 leqptr#:=-22; eqlptr#:=-23; geqptr#:=-24; neqptr#:=-25 340 andptr#:=-26; orptr#:=-27; printptr#:=-28; inputptr#:=-29 350 // 360 enteridentifier("IDLIST", idlistptr#) 370 enteridentifier("QUIT", quitptr#) 380 enteridentifier("FIRST", firstptr#) 390 enteridentifier("REST", restptr#) 400 enteridentifier("+", plusptr#) 410 enteridentifier("-", subtractptr#) 420 enteridentifier("*", multiplyptr#) 430 enteridentifier("/", divideptr#) 440 enteridentifier("QUOTE", quoteptr#) 450 enteridentifier("SET", setptr#) 460 enteridentifier("EVALUATE", evaluateptr#) 470 enteridentifier("SAVE", saveptr#) 480 enteridentifier("LOAD", loadptr#) 490 enteridentifier("MAKELIST", makelistptr#) 500 enteridentifier("APPEND", appendptr#) 510 enteridentifier("PROG", progptr#) 520 enteridentifier("IF", ifptr#) 530 enteridentifier(">", greaterptr#) 540 enteridentifier("<", lessptr#) 550 enteridentifier("=", eqlptr#) 560 enteridentifier(">=", geqptr#) 570 enteridentifier("<=", leqptr#) 580 enteridentifier("<>", neqptr#) 590 enteridentifier("OR", orptr#) 600 enteridentifier("AND", andptr#) 610 enteridentifier("PRINT", printptr#) 620 enteridentifier("INPUT", inputptr#) 630 // 640 build'free'space'managment 650 mainloop 660 // 670 PROC enteridentifier(id$, ptr#) CLOSED 680 IMPORT noids#, ident$(), idtable#() 690 pos#:=lookforidentifier#(id$) 700 IF pos#<>0 THEN 710 freestructure(idtable#(pos#)) 720 idtable#(pos#):=ptr# 730 ELSE 740 pos#:=1 750 WHILE pos#<=noids# AND THEN ident$(pos#)<>"" DO pos#:+1 760 IF pos#<=noids# THEN 770 ident$(pos#):=id$ 780 idtable#(pos#):=ptr# 790 ENDIF 800 ENDIF 810 ENDPROC 820 // 830 FUNC lookforidentifier#(id$) CLOSED 840 IMPORT noids#, ident$() 850 IF id$="" THEN RETURN 0 860 pos#:=1 870 WHILE pos#<=noids# AND THEN ident$(pos#)<>id$ DO pos#:+1 880 IF pos#>noids# THEN pos#:=0 890 RETURN pos# 900 ENDFUNC 910 // 920 PROC deleteidentifier(id$) CLOSED 930 IMPORT ident$(), idtable#, noids# 940 pos#:=lookforidentifier(id$) 950 ident$(pos#):="" 960 idtable#(pos#):=0 970 ENDPROC 980 // 990 PROC skipspaces(REF inv$) CLOSED 1000 WHILE inv$<>"" AND THEN inv$(1:1)=" " DO getrest(inv$) 1010 ENDPROC 1020 // 1030 PROC build'free'space'managment CLOSED 1040 IMPORT memsize#, memmap$ 1050 memmap$:="" 1060 FOR f#:=1 TO memsize# DO memmap$:+"0" 1070 ENDPROC 1080 // 1090 FUNC getblock#(blksize#) CLOSED 1100 IMPORT memmap$ 1110 DIM alloc$ OF blksize# 1120 alloc$:="" 1130 FOR f#:=1 TO blksize# DO alloc$:+"0" 1140 blkstart#:=alloc$ IN memmap$ 1150 IF blkstart#=0 THEN 1160 error("Cannot allocate "+STR$(blksize#)+" word(s) of contiguous storage") 1170 RETURN 0 1180 ENDIF 1190 FOR f#:=1 TO blksize# DO memmap$(blkstart#+f#-1:blkstart#+f#-1):="1" 1200 RETURN blkstart# 1210 ENDFUNC 1220 // 1230 PROC freeblock(ptr#) CLOSED 1240 IMPORT memmap$ 1250 IF ptr#>0 THEN 1260 IF isatom#(ptr#) THEN 1270 blksize#:=2+getmem#(ptr#+1) 1280 ELSE 1290 blksize#:=3 1300 ENDIF 1310 FOR f#:=1 TO blksize# DO memmap$(ptr#+f#-1:ptr#+f#-1):="0" 1320 ENDIF 1330 ENDPROC 1340 // 1350 PROC freestructure(ptr#) CLOSED 1360 IF ptr#>0 THEN 1370 IF NOT(isatom#(ptr#)) THEN 1380 freestructure(getmem#(ptr#+1)) 1390 freestructure(getmem#(ptr#+2)) 1400 ENDIF 1410 freeblock(ptr#) 1420 ENDIF 1430 ENDPROC 1440 // 1450 FUNC nextitem$(REF inv$, level#, prompt$) CLOSED 1460 DIM result$ OF 32 1470 skipspaces(inv$) 1480 WHILE inv$="" DO 1490 IF level#=0 THEN 1500 PRINT prompt$, 1510 ELSE 1520 PRINT ">>>>>>>>>>>>>>>>>>>>>>>>"(1:level#), 1530 ENDIF 1540 INPUT "": inv$ 1550 skipspaces(inv$) 1560 ENDWHILE 1570 CASE inv$(1:1) OF 1580 WHEN "(" 1590 result$:="(" 1600 getrest(inv$) 1610 WHEN ")" 1620 result$:=")" 1630 getrest(inv$) 1640 WHEN "'" 1650 result$:="'" 1660 getrest(inv$) 1670 OTHERWISE 1680 WHILE inv$<>"" AND THEN (NOT(inv$(1:1) IN " )(")) DO 1690 result$:+inv$(1:1) 1700 getrest(inv$) 1710 ENDWHILE 1720 ENDCASE 1730 RETURN result$ 1740 ENDFUNC 1750 // 1760 FUNC scaninput#(REF inv$, level#, prompt$) CLOSED 1770 IMPORT list# 1780 DIM item$ OF 32 1790 item$:=nextitem$(inv$, level#, prompt$) 1800 IF item$="(" THEN 1810 level#:+1 1820 item$:=nextitem$(inv$, level#, prompt$) 1830 root#:=0; lasto#:=0 1840 WHILE item$<>")" DO 1850 work#:=getblock#(3) 1860 putmem(work#, list#) 1870 putmem(work#+2, 0) 1880 inv$:=item$+" "+inv$ 1890 putmem(work#+1, scaninput#(inv$, level#, prompt$)) 1900 IF lasto#=0 THEN 1910 root#:=work# 1920 ELSE 1930 putmem(lasto#+2, work#) 1940 ENDIF 1950 lasto#:=work# 1960 item$:=nextitem$(inv$, level#, prompt$) 1970 ENDWHILE 1980 level#:-1 1990 ELIF item$="'" 2000 workitem#:=scaninput#(inv$, level#, prompt$) 2010 work1#:=getblock#(3) 2020 work2#:=getblock#(3) 2030 putmem(work1#, list#) 2040 putmem(work2#, list#) 2050 putmem(work1#+1, storeatom#("QUOTE")) 2060 putmem(work2#+1, workitem#) 2070 putmem(work1#+2, work2#) 2080 putmem(work2#+2, 0) 2090 root#:=work1# 2100 ELSE 2110 root#:=storeatom#(item$) 2120 ENDIF 2130 RETURN root# 2140 ENDFUNC 2150 // 2160 PROC mainloop CLOSED 2170 IMPORT waserr#, errmsg$, quitslpl#, nofree#, memmap$ 2180 DIM dummy$ OF 254 2190 dummy$:="" 2200 signon 2210 WHILE NOT(quitslpl#) DO 2220 waserr#:=FALSE 2230 errmsg$:=" ** Noerr **" 2240 inptr#:=scaninput#(dummy$, 0, "Evaluate : ") 2250 evalptr#:=evaluate#(inptr#) 2260 PRINT 2270 IF waserr# THEN 2280 NULL 2290 ELSE 2300 PRINT "Value is : ", 2310 printstructure(evalptr#) 2320 ENDIF 2330 PRINT 2340 PRINT 2350 IF NOT(nofree#) THEN 2360 freestructure(evalptr#) 2370 freestructure(inptr#) 2380 ENDIF 2390 // PRINT memmap$ 2400 nofree#:=FALSE 2410 ENDWHILE 2420 ENDPROC 2430 // 2440 PROC printstructure(ptr#) CLOSED 2450 IMPORT list# 2460 IF ptr#<0 THEN 2470 PRINT "Internal#",-ptr#, 2480 ELIF ptr#=0 2490 PRINT "NIL ", 2500 ELIF isatom#(ptr#) 2510 PRINT getatom$(ptr#), 2520 PRINT " ", 2530 ELSE 2540 PRINT "( ", 2550 WHILE ptr#<>0 DO 2560 printstructure(getmem#(ptr#+1)) 2570 ptr#:=getmem#(ptr#+2) 2580 ENDWHILE 2590 PRINT ") ", 2600 ENDIF 2610 ENDPROC 2620 // 2630 // 2640 FUNC getatom$(ptr#) CLOSED 2650 IF ptr#<=0 THEN RETURN "" 2660 DIM res$ OF 32 2670 FOR f#:=1 TO getmem#(ptr#+1) DO res$:+CHR$(getmem#(ptr#+f#+1)) 2680 RETURN res$ 2690 ENDFUNC 2700 // 2710 FUNC storeatom#(atomm$) CLOSED 2720 IMPORT atom# 2730 ptr#:=getblock#(LEN(atomm$)+2) 2740 putmem(ptr#, atom#) 2750 putmem(ptr#+1, LEN(atomm$)) 2760 FOR f#:=1 TO LEN(atomm$) DO putmem(ptr#+1+f#, ORD(atomm$(f#:f#))) 2770 RETURN ptr# 2780 ENDFUNC 2790 // 2800 PROC error(msg$) CLOSED 2810 IMPORT waserr#, errmsg$ 2820 waserr#:=TRUE 2830 errmsg$:=msg$ 2840 PRINT 2850 PRINT "Error : ",msg$ 2860 PRINT "Traceback : " 2870 ENDPROC 2880 // 2890 FUNC evaluate#(ptr#) CLOSED 2900 IMPORT atom#, idtable#(), waserr# 2910 DIM atomm$ OF 32 2920 IF waserr# THEN 2930 RETURN 0 2940 ELSE 2950 IF ptr#=0 THEN 2960 result#:=0 2970 ELSE 2980 IF isatom#(ptr#) THEN 2990 atomm$:=getatom$(ptr#) 3000 IF isnumeric#(atomm$) THEN 3010 result#:=copystruc#(ptr#) 3020 ELSE 3030 index#:=lookforidentifier#(atomm$) 3040 IF index#=0 THEN 3050 error("Identifier '"+atomm$+"' not found") 3060 result#:=0 3070 ELSE 3080 result#:=copystruc#(idtable#(index#)) 3090 ENDIF 3100 ENDIF 3110 ELSE 3120 result#:=listevaluate#(ptr#) 3130 ENDIF 3140 ENDIF 3150 IF waserr# THEN 3160 PRINT "Arg : ", 3170 printstructure(ptr#) 3180 PRINT 3190 PRINT "Value : ", 3200 printstructure(result#) 3210 PRINT 3220 PRINT 3230 ENDIF 3240 RETURN result# 3250 ENDIF 3260 ENDFUNC 3270 // 3280 FUNC isnumeric#(num$) CLOSED 3290 error#:=FALSE 3300 TRAP 3310 valu#:=VAL(num$) 3320 HANDLER 3330 error#:=TRUE 3340 ENDTRAP 3350 RETURN NOT(error#) 3360 ENDFUNC 3370 // 3380 FUNC listevaluate#(ptr#) CLOSED 3390 IMPORT atom#, idtable#() 3400 DIM atomm$ OF 32 3410 IF ptr#=0 THEN 3420 RETURN 0 3430 ELSE 3440 ptr#:+1 3450 IF NOT(isatom#(getmem#(ptr#))) THEN 3460 error("Illegal function call -- Atom expected") 3470 RETURN 0 3480 ENDIF 3490 atomm$:=getatom$(getmem#(ptr#)) 3500 index#:=lookforidentifier#(atomm$) 3510 IF index#=0 THEN 3520 error("Identifier '"+atomm$+"' not found") 3530 RETURN 0 3540 ELIF idtable#(index#)<0 3550 RETURN sysexec#(idtable#(index#), getmem#(ptr#+1)) 3560 ELSE 3570 RETURN slplcall#(getmem#(ptr#+1), idtable#(index#)) 3580 ENDIF 3590 ENDIF 3600 ENDFUNC 3610 // 3620 FUNC sysexec#(function#, params#) CLOSED 3630 IMPORT memsize#, noids#, ident$(), idtable#(), memory#(), memmap$ 3640 IMPORT atom#, list#, quitslpl# 3650 IMPORT idlistptr#, firstptr#, restptr#, plusptr#, subtractptr# 3660 IMPORT multiplyptr#, divideptr#, quoteptr#, quitptr#, setptr# 3670 IMPORT evaluateptr#, saveptr#, loadptr#, makelistptr#, appendptr# 3680 IMPORT progptr#, ifptr#, eqlptr#, lessptr#, greaterptr# 3690 IMPORT leqptr#, geqptr#, neqptr#, andptr#, orptr#, printptr#, inputptr# 3700 DIM parptr#(31) 3710 DIM atomm$ OF 32 3720 aantalpars#:=1 3730 WHILE params#<>0 AND aantalpars#<=31 DO 3740 parptr#(aantalpars#):=getmem#(params#+1) 3750 params#:=getmem#(params#+2) 3760 aantalpars#:+1 3770 ENDWHILE 3780 aantalpars#:-1 3790 IF aantalpars#=31 THEN 3800 error("Too many parameters specified") 3810 RETURN 0 3820 ENDIF 3830 CASE function# OF 3840 WHEN idlistptr# 3850 IF notpars#(0, "IDLIST", aantalpars#) THEN RETURN 0 3860 root#:=0; lasto#:=0 3870 FOR f#:=1 TO noids# DO 3880 IF ident$(f#)<>"" THEN 3890 work#:=getblock#(3) 3900 putmem(work#, list#) 3910 putmem(work#+1, storeatom#(ident$(f#))) 3920 putmem(work#+2, 0) 3930 IF root#=0 THEN 3940 root#:=work# 3950 ELSE 3960 putmem(lasto#+2, work#) 3970 ENDIF 3980 lasto#:=work# 3990 ENDIF 4000 ENDFOR 4010 RETURN root# 4020 WHEN quitptr# 4030 IF notpars#(0, "QUIT", aantalpars#) THEN RETURN 0 4040 quitslpl#:=TRUE 4050 RETURN storeatom#("Bye-Bye") 4060 WHEN plusptr#, subtractptr#, multiplyptr#, divideptr# 4070 RETURN arithop#(function#, aantalpars#, parptr#) 4080 WHEN eqlptr# 4090 IF aantalpars#<2 THEN 4100 error("At least 2 parameters needed for '='") 4110 RETURN 0 4120 ENDIF 4130 work#:=evaluate#(parptr#(1)) 4140 eq#:=TRUE 4150 f#:=2 4160 WHILE eq#=TRUE AND f#<=aantalpars# DO 4170 work1#:=evaluate#(parptr#(f#)) 4180 eq#:=equal2#(work#, work1#) 4190 freestructure(work1#) 4200 f#:+1 4210 ENDWHILE 4220 freestructure(work#) 4230 IF eq# THEN 4240 RETURN storeatom#("TRUE") 4250 ELSE 4260 RETURN storeatom#("FALSE") 4270 ENDIF 4280 WHEN greaterptr#, lessptr#, geqptr#, leqptr#, neqptr# 4290 RETURN compare#(function#, aantalpars#, parptr#) 4300 WHEN orptr#, andptr# 4310 RETURN logical#(function#, aantalpars#, parptr#) 4320 WHEN quoteptr# 4330 IF notpars#(1, "QUOTE", aantalpars#) THEN RETURN 0 4340 RETURN copystruc#(parptr#(1)) 4350 WHEN setptr# 4360 IF notpars#(2, "SET", aantalpars#) THEN RETURN 0 4370 parptr#(1):=evaluate#(parptr#(1)) 4380 parptr#(2):=evaluate#(parptr#(2)) 4390 IF isatom#(parptr#(1)) THEN 4400 work#:=parptr#(2) 4410 enteridentifier(getatom$(parptr#(1)), work#) 4420 ELSE 4430 error("SET - 1st parameter must evaluate to an atom") 4440 work#:=0 4450 ENDIF 4460 freestructure(parptr#(1)) 4470 RETURN copystruc#(work#) 4480 WHEN firstptr#, restptr# 4490 IF notpars#(1, "FIRST/REST", aantalpars#) THEN RETURN 0 4500 work#:=evaluate#(parptr#(1)) 4510 IF work#=0 THEN RETURN 0 4520 IF work#<0 THEN 4530 error("Parameter should be a list") 4540 RETURN 0 4550 ENDIF 4560 IF isatom#(getmem#(work#)) THEN 4570 error("Parameter should be a list") 4580 RETURN 0 4590 ENDIF 4600 IF function#=firstptr# THEN 4610 fwork#:=copystruc#(getmem#(work#+1)) 4620 ELSE 4630 fwork#:=copystruc#(getmem#(work#+2)) 4640 ENDIF 4650 freestructure(work#) 4660 RETURN fwork# 4670 WHEN evaluateptr# 4680 IF notpars#(1, "EVALUATE", aantalpars#) THEN RETURN 0 4690 work#:=evaluate#(parptr#(1)) 4700 work1#:=evaluate#(work#) 4710 freestructure(work#) 4720 RETURN work1# 4730 WHEN loadptr#, saveptr# 4740 IF notpars#(1, "LOAD/SAVE", aantalpars#) THEN RETURN 0 4750 work#:=evaluate#(parptr#(1)) 4760 IF NOT(isatom#(work#)) THEN 4770 error("Filename should be an atom") 4780 RETURN 0 4790 ENDIF 4800 IF diskio#(function#, getatom$(work#)) THEN 4810 RETURN storeatom#("Ok") 4820 ELSE 4830 RETURN 0 4840 ENDIF 4850 WHEN makelistptr# 4860 IF notpars#(1, "MAKELIST", aantalpars#) THEN RETURN 0 4870 work2#:=getblock#(3) 4880 putmem(work2#, list#) 4890 putmem(work2#+1, evaluate#(parptr#(1))) 4900 putmem(work2#+2, 0) 4910 RETURN work2# 4920 WHEN progptr# 4930 FOR f#:=1 TO aantalpars#-1 DO freestructure(evaluate#(parptr#(f#))) 4940 RETURN evaluate#(parptr#(aantalpars#)) 4950 WHEN ifptr# 4960 DIM truth$ OF 5 4970 IF aantalpars#>3 THEN 4980 error("Not more than 3 parameters for IF") 4990 RETURN 0 5000 ENDIF 5010 work#:=evaluate#(parptr#(1)) 5020 truth$:=getatom$(work#) 5030 freestructure(work#) 5040 IF truth$="TRUE" THEN 5050 RETURN evaluate#(parptr#(2)) 5060 ELIF truth$="FALSE" 5070 RETURN evaluate#(parptr#(3)) 5080 ELSE 5090 error("IF -- 1st parameter evaluation should result in TRUE or FALSE") 5100 RETURN 0 5110 ENDIF 5120 WHEN appendptr# 5130 IF notpars#(2, "APPEND", aantalpars#) THEN RETURN 0 5140 work1#:=evaluate#(parptr#(1)) 5150 work2#:=evaluate#(parptr#(2)) 5160 IF isatom#(work1#) OR isatom#(work2#) THEN 5170 error("APPEND - both parameters should be lists") 5180 RETURN 0 5190 ENDIF 5200 traverse#:=work1#; lastptr#:=0 5210 WHILE traverse#<>0 DO 5220 lastptr#:=traverse# 5230 traverse#:=getmem#(traverse#+2) 5240 ENDWHILE 5250 IF lastptr#=0 THEN 5260 RETURN work2# 5270 ELSE 5280 putmem(lastptr#+2, work2#) 5290 RETURN work1# 5300 ENDIF 5310 WHEN printptr# 5320 work#:=0 5330 FOR f#:=1 TO aantalpars# DO 5340 work#:=evaluate#(parptr#(f#)) 5350 printstructure(work#) 5360 IF f#1 THEN 5650 IF isptrnumeric#(parptr#(1)) THEN 5660 result#:=VAL(getatom$(parptr#(1))) 5670 ELSE 5680 error("Nonnumeric parameter in parameterlist") 5690 ENDIF 5700 f#:=2 5710 WHILE f#<=aantalpars# AND NOT(waserr#) DO 5720 IF isptrnumeric#(parptr#(f#)) THEN 5730 TRAP 5740 number#:=VAL(getatom$(parptr#(f#))) 5750 CASE operator# OF 5760 WHEN plusptr# 5770 result#:+number# 5780 WHEN subtractptr# 5790 result#:-number# 5800 WHEN multiplyptr# 5810 result#:=result#*number# 5820 WHEN divideptr# 5830 result#:=result# DIV number# 5840 ENDCASE 5850 HANDLER 5860 result#:=1 5870 error(ERRTEXT$) 5880 ENDTRAP 5890 ELSE 5900 error("Nonnumeric parameter in parameterlist") 5910 ENDIF 5920 f#:+1 5930 ENDWHILE 5940 FOR f#:=1 TO aantalpars# DO freestructure(parptr#(f#)) 5950 ENDIF 5960 RETURN storeatom#(STR$(result#)) 5970 ENDFUNC 5980 // 5990 FUNC notpars#(wanted#, function$, received#) CLOSED 6000 IF wanted#=received# THEN 6010 RETURN FALSE 6020 ELSE 6030 error(STR$(wanted#)+" parameter(s) needed for "+function$) 6040 RETURN TRUE 6050 ENDIF 6060 ENDFUNC 6070 // 6080 FUNC isatom#(ptr#) CLOSED 6090 IMPORT atom# 6100 IF ptr#<=0 THEN RETURN FALSE 6110 IF getmem#(ptr#)=atom# THEN 6120 RETURN TRUE 6130 ELSE 6140 RETURN FALSE 6150 ENDIF 6160 ENDFUNC 6170 // 6180 FUNC copystruc#(ptr#) CLOSED 6190 IMPORT atom#, list# 6200 IF ptr#<=0 THEN 6210 RETURN ptr# 6220 ELSE 6230 IF isatom#(ptr#) THEN 6240 RETURN storeatom#(getatom$(ptr#)) 6250 ELSE 6260 root#:=0 6270 lasto#:=0 6280 WHILE ptr#<>0 DO 6290 work#:=getblock#(3) 6300 IF work#=0 THEN 6310 freeblock(root) 6320 RETURN 0 6330 ENDIF 6340 putmem(work#, list#) 6350 putmem(work#+2, 0) 6360 putmem(work#+1, copystruc#(getmem#(ptr#+1))) 6370 IF lasto#=0 THEN 6380 root#:=work# 6390 ELSE 6400 putmem(lasto#+2, work#) 6410 ENDIF 6420 lasto#:=work# 6430 ptr#:=getmem#(ptr#+2) 6440 ENDWHILE 6450 RETURN root# 6460 ENDIF 6470 ENDIF 6480 ENDFUNC 6490 // 6500 PROC putmem(addr#, word#) CLOSED 6510 IMPORT memory#(), memmap$ 6520 IF memmap$(addr#:addr#)="0" THEN 6530 PRINT 6540 PRINT "Attempt writing unallocated memory at ",addr# 6550 STOP 6560 ELSE 6570 memory#(addr#):=word# 6580 ENDIF 6590 ENDPROC 6600 // 6610 FUNC getmem#(addr#) CLOSED 6620 IMPORT memory#(), memmap$ 6630 IF memmap$(addr#:addr#)="0" THEN 6640 PRINT 6650 PRINT "Attempt reading unallocated memory at ",addr# 6660 STOP 6670 ELSE 6680 RETURN memory#(addr#) 6690 ENDIF 6700 ENDFUNC 6710 // 6720 FUNC diskio#(function#, filnam$) CLOSED 6730 IMPORT noids#, memsize#, memory#(), ident$(), idtable#(), memmap$, nofree# 6740 IMPORT loadptr#, saveptr# 6750 TRAP 6760 IF function#=loadptr# THEN 6770 OPEN FILE 1, filnam$, READ 6780 READ FILE 1: snoids#, smemsize# 6790 IF snoids#<>noids# THEN 6800 PRINT "Idtable sizes unequal : Current = ",noids#," File = ",snoids# 6810 ENDIF 6820 IF smemsize#<>memsize# THEN 6830 PRINT "Memsized unequal : Current = ",memsize#," File = ",smemsize# 6840 ENDIF 6850 IF snoids#<>noids# OR smemsize#<>memsize# THEN 6860 CLOSE FILE 1 6870 error("Workspace LOAD failed") 6880 RETURN FALSE 6890 ENDIF 6900 READ FILE 1: ident$, idtable#, memory#, memmap$ 6910 CLOSE FILE 1 6920 nofree#:=TRUE 6930 RETURN TRUE 6940 ELSE 6950 OPEN FILE 1, filnam$, WRITE 6960 WRITE FILE 1: noids#, memsize# 6970 WRITE FILE 1: ident$, idtable#, memory#, memmap$ 6980 CLOSE FILE 1 6990 RETURN TRUE 7000 ENDIF 7010 HANDLER 7020 error(ERRTEXT$+" - Current workspace may be corrupt") 7030 CLOSE FILE 1 7040 RETURN FALSE 7050 ENDTRAP 7060 ENDFUNC 7070 // 7080 FUNC equal2#(ptr1#, ptr2#) CLOSED 7090 IF isatom#(ptr1#) AND isatom#(ptr2#) THEN 7100 RETURN getatom$(ptr1#)=getatom$(ptr2#) 7110 ELIF NOT(isatom#(ptr1#)) AND NOT(isatom#(ptr2#)) 7120 IF ptr1#=ptr2# THEN RETURN TRUE 7130 IF ptr1#<=0 OR ptr2#<=0 THEN RETURN FALSE 7140 RETURN equal2#(getmem#(ptr1#+1), getmem#(ptr2#+1)) AND equal2#(getmem#(ptr1#+2), getmem#(ptr2#+2)) 7150 ELSE 7160 RETURN FALSE 7170 ENDIF 7180 ENDFUNC 7190 // 7200 PROC signon 7210 PAGE 7220 PRINT "+-------------------------------------------------+" 7230 PRINT "| |" 7240 PRINT "| SLPL/SCOR |" 7250 PRINT "| |" 7260 PRINT "| SLPL - Simple List Processing Language |" 7270 PRINT "| SCOR - Shock Course On Recursion |" 7280 PRINT "| |" 7290 PRINT "| 1987: Written in IBM COMAL-80 by Jos Visser |" 7300 PRINT "| 1993: Adapted for PDComal |" 7310 PRINT "| 2002: Released with OpenComal |" 7320 PRINT "| |" 7330 PRINT "+-------------------------------------------------+" 7340 PRINT 7350 ENDPROC 7360 // 7370 FUNC slplcall#(pars#, defi#) CLOSED 7380 IMPORT idtable#() 7390 DIM parname$(32) OF 32, parval#(32), atomm$ OF 32 7400 perr#:=isatom#(defi#) 7410 IF defi#=0 THEN perr#:=TRUE 7420 IF NOT(perr#) AND THEN getmem#(defi#+2)=0 THEN perr#:=TRUE 7430 IF perr# THEN 7440 error("Function should be a list containing 2 lists") 7450 RETURN 0 7460 ENDIF 7470 parlist#:=getmem#(defi#+1) 7480 body#:=getmem#(getmem#(defi#+2)+1) 7490 work#:=parlist#; parno#:=0 7500 WHILE work#<>0 DO 7510 parno#:+1 7520 IF NOT(isatom#(getmem#(work#+1))) THEN 7530 error("Parameters should be a list consisting of atoms only") 7540 RETURN 0 7550 ENDIF 7560 atomm$:=getatom$(getmem#(work#+1)) 7570 index#:=lookforidentifier#(atomm$) 7580 IF index#=0 THEN 7590 enteridentifier(atomm$, 0) 7600 index#:=lookforidentifier#(atomm$) 7610 ENDIF 7620 parname$(parno#):=atomm$ 7630 parval#(parno#):=copystruc#(idtable#(index#)) 7640 IF pars#=0 THEN 7650 enteridentifier(atomm$, 0) 7660 ELSE 7670 enteridentifier(atomm$, evaluate#(getmem#(pars#+1))) 7680 pars#:=getmem#(pars#+2) 7690 ENDIF 7700 work#:=getmem#(work#+2) 7710 ENDWHILE 7720 retval#:=evaluate#(body#) 7730 FOR f#:=1 TO parno# DO enteridentifier(parname$(f#), parval#(f#)) 7740 RETURN retval# 7750 ENDFUNC 7760 // 7770 FUNC logical#(function#, aantalpars#, parptr#()) CLOSED 7780 IMPORT orptr#, andptr# 7790 f#:=1 7800 IF function#=andptr# THEN 7810 retval#:=TRUE 7820 ELSE 7830 retval#:=FALSE 7840 ENDIF 7850 WHILE f#<=aantalpars# AND ((retval#=TRUE AND function#=andptr#) OR function#=orptr#) DO 7860 work#:=evaluate#(parptr#(f#)) 7870 thisval#:=getatom$(work#)="TRUE" 7880 freestructure(work#) 7890 CASE function# OF 7900 WHEN orptr# 7910 retval#:=retval# OR thisval# 7920 WHEN andptr# 7930 retval#:=retval# AND thisval# 7940 ENDCASE 7950 f#:+1 7960 ENDWHILE 7970 IF retval#=TRUE THEN 7980 RETURN storeatom#("TRUE") 7990 ELSE 8000 RETURN storeatom#("FALSE") 8010 ENDIF 8020 ENDFUNC 8030 // 8040 FUNC compare#(function#, aantalpars#, parptr#()) CLOSED 8050 IMPORT greaterptr#, lessptr#, leqptr#, geqptr#, neqptr#, waserr# 8060 IF aantalpars#=0 THEN 8070 error(">,<,>=,<=,<> should have at least one parameter") 8080 RETURN storeatom#("FALSE") 8090 ENDIF 8100 FOR f#:=1 TO aantalpars# DO parptr#(f#):=evaluate#(parptr#(f#)) 8110 result#:=TRUE 8120 IF isptrnumeric#(parptr#(1)) THEN 8130 compareval#:=VAL(getatom$(parptr#(1))) 8140 ELSE 8150 error("Nonnumeric parameter in parameterlist") 8160 RETURN storeatom#("FALSE") 8170 ENDIF 8180 f#:=2 8190 WHILE f#<=aantalpars# AND NOT(waserr#) AND result#=TRUE DO 8200 IF isptrnumeric#(parptr#(f#)) THEN 8210 TRAP 8220 number#:=VAL(getatom$(parptr#(f#))) 8230 CASE function# OF 8240 WHEN greaterptr# 8250 result#:=result# AND (number#compareval#) 8280 WHEN leqptr# 8290 result#:=result# AND (number#>=compareval#) 8300 WHEN geqptr# 8310 result#:=result# AND (number#<=compareval#) 8320 WHEN neqptr# 8330 result#:=result# AND (number#<>compareval#) 8340 ENDCASE 8350 compareval#:=number# 8360 HANDLER 8370 result#:=FALSE 8380 error(ERRTEXT$) 8390 ENDTRAP 8400 ELSE 8410 error("Nonnumeric parameter in parameterlist") 8420 ENDIF 8430 f#:+1 8440 ENDWHILE 8450 FOR f#:=1 TO aantalpars# DO freestructure(parptr#(f#)) 8460 IF result#=TRUE THEN 8470 RETURN storeatom#("TRUE") 8480 ELSE 8490 RETURN storeatom#("FALSE") 8500 ENDIF 8510 ENDFUNC 8520 // 8530 PROC getrest(REF a$) 8540 IF LEN(a$)=1 THEN 8550 a$:="" 8560 ELSE 8570 a$:=a$(2:) 8580 ENDIF 8590 ENDPROC