TL;DR Fixing some really old Prolog implementation written in Pascal

Recently I’ve been interested in Logic Programming, notably in learning Prolog so I’m in a process of reading two great books, Programming for Artificial Intelligence and The Art of Prolog. If you want to get a quick feel of Prolog I recommend you take a look at Bernardo Pires’s Gentle Introduction to Prolog and Prologomenon blog. To put it simply Prolog is all about logic, deduction and backtracking

While browsing /r/prolog I’ve stumbled upon Prolog for Programmers originally published in 1985, an old book indeed and honestly sometimes hard to follow. I can’t recommend it as a starter book about Prolog but it’s still quite interesting to read. However it has a whole two chapters describing implementation of Prolog interpreter which is quite a complex task and sparkled my interest in continuing reading this book. Authors provide source code of two version of Prolog interpreter, the one they originally wrote in Pascal back in 1983 and it’s port to C in 2013 which, as stated on their website, was done because they couldn’t compile old Pascal code with Free Pascal Compiler and because… well Pascal is quite out of fashion nowadays. Couldn’t compile?! Well, challenge accepted!

We’ll start with toy.p (original source code) and syskernel (boot file written in toy’s original prolog syntax) file. Let’s create a Makefile and try compiling the software with fpc.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ############ FPC=/usr/bin/fpc FPCFLAGS=-O3 ############ all: toy toy: toy.p $(FPC) $(FPCFLAGS) $< ############ clean: rm -f toy*.o distclean: clean rm -f toy

Let’s try running make

1 2 3 4 5 6 7 8 9 10 11 /usr/bin/fpc -O3 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(260,1) Error: Goto statements aren't allowed between different procedures toy.p(306,1) Error: Goto statements aren't allowed between different procedures toy.p(348,18) Error: Incompatible type for arg no. 2: Got "Array[1..35] Of Char", expected "LongInt" toy.p(351,20) Error: Incompatible type for arg no. 2: Got "Array[1..35] Of Char", expected "LongInt" toy.p(453,21) Fatal: Syntax error, "identifier" expected but "STRING" found Fatal: Compilation aborted

First two errors are goto statement related, let’s see the source code.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 label 1 , 2 ; (* error halt & almost-fatal error recovery only *) procedure halt ; (* this might be implementation-dependent *) begin writeln ; writeln ( ' ******toyprolog aborted******' ) ; goto 1 end ; procedure errror ( id : errid ) ; begin writeln ; write ( ' ++++++error : ' ) ; .... if id in [ ctovflw , protovflw , loadfile , sysinit , usereof ] then halt else goto 2 end ; begin (*********** toy prolog ************) initvars ; loadsyskernel ; 2 : repeat readtogoal ( goalstmnt , ngoalvars ) ; resolve ( goalstmnt , ngoalvars ) until terminate ; 1 : closefile ( true ) ; closefile ( false ) end .

Well, apparently back in the 80’s you could jump between procedures in Pascal using goto statements, some primitive try/catch mechanism. Now that’s a neat thing but unfortunetly no, you can’t do that anymore. Let’s change this code to use exceptions. One thing to note we can substitute goto 1 with halt(1) which will make our program exit on critical error. Also we’ll need to add -S2 flag to FPCFLAGS variable in Makefile since we’ll be using exceptions which is related to classes mechanism of Pascal. And just to be sure we don’t override any system procedures we’ll rename our halt to haltsys

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 use sysutils ; type .... error = class ( Exception ) ; procedure haltsys ; (* this might be implementation-dependent *) begin writeln ; writeln ( ' ******toyprolog aborted******' ) ; halt ( 1 ) end ; procedure errror ( id : errid ) ; begin writeln ; write ( ' ++++++error : ' ) ; .... if id in [ ctovflw , protovflw , loadfile , sysinit , usereof ] then haltsys else raise error . create ( 'error' ) end ; (*********** toy prolog ************) begin initvars ; loadsyskernel ; repeat try readtogoal ( goalstmnt , ngoalvars ) ; resolve ( goalstmnt , ngoalvars ) except on error do end ; until terminate ; closefile ( true ) ; closefile ( false ) end .

Let’s try running make again

1 2 3 4 5 6 7 8 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(349,18) Error: Incompatible type for arg no. 2: Got "Array[1..35] Of Char", expected "LongInt" toy.p(352,20) Error: Incompatible type for arg no. 2: Got "Array[1..35] Of Char", expected "LongInt" toy.p(454,21) Fatal: Syntax error, "identifier" expected but "STRING" found

Good, now goto related error is gone and next we have is something bizzare, let’s see the source code.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 procedure openfile ( name : ctx ; forinput : boolean ) ; (* open the file (si or so according to 2nd parameter) whose name is given by a string in character table. a file is opened rewound. if a previous file is open, it is closed. *) const ln = 35 ; (* for RSX-11 *) var nm : array [ 1 .. ln ] of char ; k : 1 .. ln ; begin k := 1 ; while ( k <> ln ) and ( ct [ name ] <> chr ( eos ) ) do begin nm [ k ] := ct [ name ] ; name := name + 1 ; k := k + 1 end ; if ct [ name ] <> chr ( eos ) then errror ( longfilename ) ; for k := k to ln do nm [ k ] := ' ' ; closefile ( forinput ) ; (* only 1 file per stream *) if forinput then begin reset ( si , nm ) ; seeing := true end else begin rewrite ( so , nm ) ; telling := true ; solinesize := 0 end end (*openfile*) ;

Well apparently reset and rewrite procedures don’t accept file name as second argument anymore, instead we need to first assign file name and then open it for reading.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 procedure openfile ( name : ctx ; forinput : boolean ) ; (* open the file (si or so according to 2nd parameter) whose name is given by a string in character table. a file is opened rewound. if a previous file is open, it is closed. *) const ln = 35 ; (* for RSX-11 *) var nm : array [ 1 .. ln ] of char ; k : 1 .. ln ; begin k := 1 ; while ( k <> ln ) and ( ct [ name ] <> chr ( eos ) ) do begin nm [ k ] := ct [ name ] ; name := name + 1 ; k := k + 1 end ; if ct [ name ] <> chr ( eos ) then errror ( longfilename ) ; for k := k to ln do nm [ k ] := ' ' ; closefile ( forinput ) ; (* only 1 file per stream *) if forinput then begin assign ( si , nm ) ; reset ( si ) ; seeing := true end else begin assign ( so , nm ) ; rewrite ( so ) ; telling := true ; solinesize := 0 end end (*openfile*) ;

Let’s try running make again

1 2 3 4 5 6 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(456,21) Fatal: Syntax error, "identifier" expected but "STRING" found

Let’s see what we have here

1 2 3 4 5 function charlast ( string : ctx ) : ctx ; (* locate the last character (except eos) of this string *) begin while ct [ string ] <> chr ( eos ) do string := string + 1 ; charlast := string - 1 (*correct because lowest string not empty*) end ;

We can’t use string as identifier since it’s used as a type keyword nowadays so let’s change that

1 2 3 4 5 function charlast ( str : ctx ) : ctx ; (* locate the last character (except eos) of this str *) begin while ct [ str ] <> chr ( eos ) do str := str + 1 ; charlast := str - 1 (*correct because lowest str not empty*) end ;

Let’s try running make again

1 2 3 4 5 6 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(922,7) Fatal: Syntax error, "identifier" expected but "is" found

Ahh, same identifier problem but now with is keyword, let’s quickly change that too. Next is same problem but now with class keyword, okey fixed that one too. And again is keyword related problems, fixed.

And now running make again

1 2 3 4 5 6 7 8 9 10 11 12 13 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(1951,36) Error: Identifier not found "success" toy.p(1956,10) Error: Identifier not found "id" toy.p(1957,18) Error: Constant and CASE types do not match toy.p(1957,27) Error: Identifier not found "success" toy.p(1958,8) Error: Constant and CASE types do not match toy.p(1959,18) Error: Constant and CASE types do not match toy.p(1960,18) Error: Constant and CASE types do not match ........

ZOMFG, tons of errors :( no worries no worries let’s see the code!

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 procedure sysroutcall (* ( id : sysroutid; var success, stop : boolean ) *) ; (* perform a system routine call *) var k : nsysparam ; begin syserror := false ; success := true ; (* might change yet *) for k := 1 to getarity ( ccall ) do begin spar [ k ] := argument ( ccall , ancenv , k ) ; if isint ( spar [ k ] ) then sparv [ k ] := intval ( spar [ k ] ) end ; case id of idfail : success := false ; (* keep this as first *) idtag , idcall : ; (* never called ! (cf. control) *) idslash : slash ; idtagcut : tagcut ( success ) ; idtagfail : tagfail ( success ) ; idtagexit : tagexit ( success ) ; idancestor : ancestor ( success ) ; ......... end (*case*) end (*sysroutcall*) ;

Ehh… why is the procedure argument block commented? Wait we have another sysroutcall defined in a file previously which is…

1 2 procedure sysroutcall ( id : sysroutid ; var success , stop : boolean ) ; forward ; (*----------------------------------------------------------*)

Ahh it’s just a forward definition, well aparently nowadays if you are defining a forward definition that doesn’t mean you don’t need to specify procedure arguments again. Let’s uncomment the arguments and try running make again.

1 2 3 4 5 6 7 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(2132,33) Fatal: Syntax error, ":" expected but ";" found Fatal: Compilation aborted

Let’s see the code

1 2 3 4 5 function rdterm (* : integer *) ; (* read a term and return a prot for a non-var or a negated offset for a var. sequences processed recursively to allow proper ground prot treatment. *) var sign : - 1 .. 1 ; varoff : varnumb ; prot : integer ; dot : protx ; begin skipbl ;

Function result type is commented, probably a typo, let’s uncomment it and run make again.

1 2 3 4 5 6 7 8 9 10 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(2138,22) Warning: Function result variable does not seem to initialized toy.p(2280,26) Error: Incompatible type for arg no. 2: Got "Constant String", expected "LongInt" toy.p(2314,9) Error: Label used but not defined "2" toy.p(2314,9) Fatal: Syntax error, ";" expected but "REPEAT" found Fatal: Compilation aborted

That’s a weird error. Let’s examine the code.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 function rdterm : integer ; (* read a term and return a prot for a non-var or a negated offset for a var. sequences processed recursively to allow proper ground prot treatment. *) var sign : - 1 .. 1 ; varoff : varnumb ; prot : integer ; dot : protx ; begin skipbl ; writeln ( 'rdterm ' , cch ) ; if cch = '(' then begin (* eg. a . (b . c) . d *) rd ; prot := rdterm ; skipbl ; if cch <> ')' then synterr ; rd end else if cch = '_' then begin (* a dummy variable *) rd ; prot := dumvarx (* treated as non-var here *) end else if cch = ':' then begin (* a variable *) rd ; varoff := rddigits ; prot := - varoff ; if varoff + 1 > nclvars then nclvars := varoff + 1 end else if ( cch = '+' ) or ( cch = '-' ) or ( cc [ cch ] = cdigit ) then begin if cch = '-' then sign := - 1 else sign := 1 ; if cc [ cch ] <> cdigit then rd ; (* number itself processed as positive : this causes loss of smallest integer in two's complement *) prot := newintprot ( sign * rddigits ) end else begin prot := rdnonvarint ; skipbl end ; if cch <> '.' then rdterm := prot else begin (* a sequence, as it turns out *) dot := initprot ( std [ atmdot ] ) ; mkarg ( dot , car , prot ) ; rd ; skipcombl ; mkarg ( dot , cdr , rdterm ) ; rdterm := wrapprot ( dot ) end end (*rdterm*) ;

Seems like fpc can’t distinguesh between a recursive function call and a function result value, so let’s add some brackets for function calls.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 function rdterm : integer ; (* read a term and return a prot for a non-var or a negated offset for a var. sequences processed recursively to allow proper ground prot treatment. *) var sign : - 1 .. 1 ; varoff : varnumb ; prot : integer ; dot : protx ; begin skipbl ; writeln ( 'rdterm ' , cch ) ; if cch = '(' then begin (* eg. a . (b . c) . d *) rd ; prot := rdterm () ; skipbl ; if cch <> ')' then synterr ; rd end else if cch = '_' then begin (* a dummy variable *) rd ; prot := dumvarx (* treated as non-var here *) end else if cch = ':' then begin (* a variable *) rd ; varoff := rddigits ; prot := - varoff ; if varoff + 1 > nclvars then nclvars := varoff + 1 end else if ( cch = '+' ) or ( cch = '-' ) or ( cc [ cch ] = cdigit ) then begin if cch = '-' then sign := - 1 else sign := 1 ; if cc [ cch ] <> cdigit then rd ; (* number itself processed as positive : this causes loss of smallest integer in two's complement *) prot := newintprot ( sign * rddigits ) end else begin prot := rdnonvarint ; skipbl end ; if cch <> '.' then rdterm := prot else begin (* a sequence, as it turns out *) dot := initprot ( std [ atmdot ] ) ; mkarg ( dot , car , prot ) ; rd ; skipcombl ; mkarg ( dot , cdr , rdterm () ) ; rdterm := wrapprot ( dot ) end end (*rdterm*) ;

1 2 3 4 5 6 7 8 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p toy.p(2280,26) Error: Incompatible type for arg no. 2: Got "Constant String", expected "LongInt" toy.p(2322) Fatal: There were 1 errors compiling module, stopping Fatal: Compilation aborted

Ahh we are getting closer to the end, same reset related error, let’s fix it by adding assign and run make again.

1 2 3 4 5 6 7 8 /usr/bin/fpc -O3 -S2 toy.p Free Pascal Compiler version 2.4.0-2ubuntu1.10.04 [2011/06/17] for i386 Copyright (c) 1993-2009 by Florian Klaempfl Target OS: Linux for i386 Compiling toy.p Linking toy /usr/bin/ld: warning: link.res contains output sections; did you forget -T? 2322 lines compiled, 0.3 sec

And we did it! Congratulations, it compiles. Let’s try running toy executable!

1 2 3 4 5 6 7 8 bash$ ./toy Toy-Prolog listening: ?- X=1. X = 1 ; no ?- display('Hello World!'), nl. Segmentation fault

Well it runs, but function call crashes the toy prolog interpreter. Let’s investigate this issue using gdb debugger. We’ll need to compile code with -g flag to do actual debugging so just add it to your FPCFLAGS variable in Makefile

Now let’s start debugging

1 2 3 4 5 6 7 8 9 10 11 12 bash$ gdb ./toy GNU gdb (GDB) 7.1-ubuntu Copyright (C) 2010 Free Software Foundation, Inc. License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> (gdb) run Starting program: /home/troydm/projects/toytest/toy Toy-Prolog listening: ?- a. Program received signal SIGSEGV, Segmentation fault. 0x0804a831 in PURGETRAIL (LOW=37294) at toy.p:1224 1224 if (tt [high] < frozenvars) or (tt [high] > frozenheap)

It seems purgetail procedure is at fault.

1 2 3 4 5 6 7 8 9 10 11 12 13 procedure purgetrail ( low : ttx ) ; (* remove unnecessary trail entries at and above low , either after a successful unifyordont call or after popping backtrack-points in a non-backtracking context ( unfreeze ). this is necessary, as unfrozen vars might be moved or destroyed - it also saves trail space. *) var high : ttx ; begin for high := low to ttop - 1 do if ( tt [ high ] < frozenvars ) or ( tt [ high ] > frozenheap ) then begin tt [ low ] := tt [ high ] ; low := low + 1 end ; ttop := low end ;

Hmm, it’s starts from low and goes till ttop-1 to remove unused trail entries from array. Let’s add some writeln output of low and ttop values to see what makes it really crash.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 procedure purgetrail ( low : ttx ) ; (* remove unnecessary trail entries at and above low , either after a successful unifyordont call or after popping backtrack-points in a non-backtracking context ( unfreeze ). this is necessary, as unfrozen vars might be moved or destroyed - it also saves trail space. *) var high : ttx ; begin writeln ( 'low = ' , low , ' ttop = ' , ttop ) ; for high := low to ttop - 1 do if ( tt [ high ] < frozenvars ) or ( tt [ high ] > frozenheap ) then begin tt [ low ] := tt [ high ] ; low := low + 1 end ; ttop := low end ;

Let’s run toy again

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 bash$ ./toy Toy-Prolog listening: ?- a. low = 1 ttop = 3 low = 0 ttop = 1 low = 0 ttop = 1 low = 0 ttop = 3 low = 0 ttop = 1 low = 0 ttop = 1 low = 0 ttop = 1 low = 0 ttop = 4 low = 0 ttop = 1 low = 0 ttop = 1 low = 0 ttop = 1 low = 0 ttop = 0 Segmentation fault

It crashes when both values are 0’s. Hmm it seems we don’t need to iterate anything unless low < ttop, Since the trail array is empty, so let’s add this fix into purgetrail.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 procedure purgetrail ( low : ttx ) ; (* remove unnecessary trail entries at and above low , either after a successful unifyordont call or after popping backtrack-points in a non-backtracking context ( unfreeze ). this is necessary, as unfrozen vars might be moved or destroyed - it also saves trail space. *) var high : ttx ; begin if low < ttop then for high := low to ttop - 1 do if ( tt [ high ] < frozenvars ) or ( tt [ high ] > frozenheap ) then begin tt [ low ] := tt [ high ] ; low := low + 1 end ; ttop := low end ;

Let’s run make and then run toy interpreter again

1 2 3 4 5 bash$ ./toy Toy-Prolog listening: ?- display('Hello World!'), nl. Hello World! yes

And we did it! It works :) It might have some other bugs since it’s an old software but I haven’t encountered any more yet. I’ve also ported btoy.p the same way stumbling upon same kind of errors and same purgetrail bug.