lisp.pl

LISP interpreter implemented with PERL.

#!/usr/bin/perl
#
# Lisp.pl: A tiny Lisp interpreter using Perl.
#
# This file and all associated files and documentation:
#       Copyright (C) 2000 Ali Onur Cinar <[e-mail]>
#
# Latest version can be downloaded from:
#
#   ftp://ftp.cpan.org/pub/CPAN/authors/id/A/AO/AOCINAR/elmtag*
#   http://www.zdo.com
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version. And also
# please DO NOT REMOVE my name, and give me a CREDIT when you use
# whole or a part of this program in an other program.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#

###
### GLOBALS
###
	$DEBUG = 0;	# 0=off 1=on

###
### SYMBOL TABLE
###
	%SYMBOLS = (
		x	=> 3,
		y	=> 2,
		z	=> 4,
		list1	=> "(3 2 4)",
		list2	=> "(5 6)",
		list3	=> "nil"
	);

###
### MAIN 
### FUNCTION
###
###
	print "** Lisp Interpreter v1.0.0\n";
	print "**\n";
	print "**  Commands:\n";
	print "**   > debug       turn debug option on/off\n";
	print "**   > quit        exit from command line\n";
	print "**\n";
	print "**  Available Tests:\n";
	print "**   1. (+ 3 4 5 6 (* 2 4 (- 5) (+ 3)) (- (- 3 5)) (* 4))\n";
	print "**   2. (or (and (= 3 5) (= 3 3)) (if 7 3 2) nil)\n";
	print "**   3. (cons (list 5 3 6) (list 'ga 'ha (first '(7 4 (list 2 'ha)))))\n";
	print "**   4. (apply #'+ (rest (list (list 3 4 5) 6 (funcall #'- 2 3))))\n";
	print "**   5. (equal (list 3 5) (list 3 (- 7 2)))\n";
	print "**   6. (list list1 (apply #'+ list1) y)\n";
	print "**   7. (equal (cons list1 list2) (cons (list x y z) (cons (first list2) (rest list2))))\n";
	print "**   8. (first (rest (list 1 (+ 2 3 (* 4 5)) 6 7 8)))\n";
	print "**   9. (apply #'or ((funcall #'and 1 0) 1))\n";
	print "**\n\n";
	print "> ";

	# get users input from the command line
	# and then evaluate the given LISP code
	while (<STDIN>)
	{
	  # if user wants to quit then exit
	  if ($_ =~ /[Qq][Uu][Ii][Tt]/) {
	    print "\nGoodbye!\n\n";
	    exit 0;
	  }

	  # if user wants to turn on/off debug option
	  if ($_ =~ /[Dd][Ee][Bb][Uu][Gg]/) {
	    $DEBUG = ($DEBUG) ? 0 : 1;
            print "\nDebug is ".(($DEBUG)?'on':'off')."\n";
	  }
	  else {
	    # evaluate the given LISP code
	    Evaluate($_);
	  }

	  # print prompt
	  print "\n> ";
	}


###
### LISP INTERPRETER
### FUNCTION
###
### @param	: string -> lisp code
### @return	: n/a
### @output	: stdout -> result
###		  stderr -> errors
###
sub Evaluate ($)
{
	# INPUTED LIST CODE
	$LISP = shift @_;

	# CLEAN SPACES FROM THE BEGINNING OF CODE
	$LISP =~ s/^ +//;

	# GLOBALS
	$LEVEL = 0;		# Holds the numbers of levels
	@OPER  = undef;		# Stack for Operators
	@VALUES= undef;		# Stack for Value lists
	$next_is_oper=0;	# Set if next expected char
				# should be an operator

	# Go through the LISP expression and evaluate
	for ($i=0; $i<length($LISP); $i++) {

	    #read next available character
	    $char = substr($LISP,$i,1);

	    #if it is the first character and
	    #it is not ( then throw a syntax error
	    if (($i==0) && ($char ne "(")) {
	      print "\n! SYNTAX ERROR ON COLUMN 0\n";
	      return;
	    }

	    # if the expected character is an
	    # operator then identify the operator
	    # else throw a syntax error 
	    if ($next_is_oper == 1) {

	      if ($char eq "+") {	# If operator is +
                push(@OPER, "+");
	      }
	      elsif ($char eq "-") {	# If operator is -
 		push(@OPER, "-");
	      }
	      elsif ($char eq "*") {	# If operator is *
		push(@OPER, "*");
	      }
	      elsif ($char eq "=") {	# If operator is =
		push(@OPER, "=");
	      }
	      elsif ($char eq "a") {	# If operator is and
	        $char = substr($LISP,$i+1,1);
	        if ($char eq "n") {	
		  push(@OPER, "and");
		  $i+=2;
                } elsif ($char eq "p") {# If operator is apply
		  push(@OPER, "apply");
		  $i+=4;
		} else {
		  print "\n! UNKNOWN OPERATOR CALL \n";
		  return;
		}
	      }
	      elsif ($char eq "o") {	# If operator is or
		push(@OPER, "or");
		$i++;
	      }
	      elsif ($char eq "i") {	# If operator is if 
		push(@OPER, "if");
		$i++;
	      }
	      elsif ($char eq "l") {	# If operator is list
	        $char = substr($LISP,$i+1,1);
	        if ($char eq "i") {	
		  push(@OPER, "list");
		  $i+=3;
		} elsif ($char eq "a") {# If operator is lambda
		  push(@OPER, "lambda");
		  $i+=5;
		} else {
		  print "\n! UNKNOWN OPERATOR CALL \n";
		  return;
		}
	      }
	      elsif ($char eq "e") {	# If operator is equal
		push(@OPER, "=");
		$i+=4;
	      }
	      elsif ($char eq "f") {	# If operator is first
	        $char = substr($LISP,$i+1,1);
	        if ($char eq "i") {	
		  push(@OPER, "first");
		  $i+=4;
                } elsif ($char eq "u") {# If operator is funcall
		  push(@OPER, "funcall");
		  $i+=6;
		} else {
		  print "\n! UNKNOWN OPERATOR CALL \n";
		  return;
		}
	      }
	      elsif ($char eq "r") {	# If operator is rest
		push(@OPER, "rest");
		$i+=3;
	      }
	      elsif ($char eq "c") {	# If operator is cons
		push(@OPER, "cons");
		$i+=3;
	      }
	      else {			# probably a list
		push(@OPER, "list");
		$i--;
	      }

	      $next_is_oper=0;		# reset it

	    }
	    # If the next character is not a space
	    # then check if it is ( or ) or a value
	    elsif (($char ne " ") && ($char ne "'") && ($next_is_oper == 0)) {

	      if ($char eq "(") {	# If it is ( then
		$LEVEL++;		# start a new level

		$next_is_oper=1;	# next character should be 
					# an operator

		push (@VALUES, "");	# insert a blank value list
	      }
	      elsif ($char eq ")") {	# If it is ) then
					# finish the current level
					# And evaluate the expression

		# DEBUG 
		(print "DEBUG: level: $LEVEL  operator: ".$OPER[$LEVEL]
			." values: {" .$VALUES[$LEVEL]) if ($DEBUG);
		# DEBUG 

		# Put the values inside a list structure	
		@numbers = split (/,/,$VALUES[$LEVEL]);
		$VALUES[$LEVEL] = ''; # free some memory 

		# Shift the first element of list since it 
		# will be always a space 
		shift(@numbers);

		# Check symbol lookup table for pre-defined
		# symbol values
		for ($k=0;$k<=$#numbers;$k++) {
		  $numbers[$k] = symbolLookup($numbers[$k]);
		}

		# set eval = the first value in list
		$eval = $numbers[0];

		# check for apply
		if ($OPER[$LEVEL] eq "apply") {
		  $OPER[$LEVEL] = substr ($numbers[0], 2,length($numbers[0])-2);
		  @numbers = split(/ /, substr($numbers[1],1,length($numbers[1])-2));
		  $eval = $numbers[0];
		}

		# check for funcall
		if ($OPER[$LEVEL] eq "funcall") { 
		  $OPER[$LEVEL] = substr ($numbers[0], 2,length($numbers[0])-2);
		  $eval = $numbers[1];
		  shift @numbers;
		}

		if ($OPER[$LEVEL] eq "if") {
		  # check for condition, if numbers[0] is not equal to "nil"
		  # then return numbers[2] else return numbers[1]
		  if ($numbers[0] == 0) {
		    $eval = $numbers[2];
		  } else {
		    $eval = $numbers[1];
		  }
		}
		elsif ($OPER[$LEVEL] eq "lambda") {
		  foreach (@numbers) {
		    print "=> $_\n";
		  }
		}
		elsif ($OPER[$LEVEL] eq "list") {
		  $eval = '('.join (' ',@numbers).')';
		}
		elsif ($OPER[$LEVEL] eq "cons") {
		  $eval = '('.join (' ',@numbers).')';
		}
		elsif ($OPER[$LEVEL] eq "first") {
		  @tmp = splitIt(substr($numbers[0],1,length($numbers[0])-2));
		  $eval = $tmp[0];
		}
		elsif ($OPER[$LEVEL] eq "rest") {
		  @tmp = splitIt(substr($numbers[0],1,length($numbers[0])-2));
		  shift @tmp;
		  $eval = '('.join (' ',@tmp).')';
		}
		elsif ($#numbers == 0) { # if it is like (- 5)
					 # then it means -5
		    $eval =~ s/ //;

		    # ($eval = $eval * $eval) if ($OPER[$LEVEL] eq "*"); # 5^2 case
		    ($eval = -1 * $eval)    if ($OPER[$LEVEL] eq "-"); # -5 case
		}
		else {
		  # do the necessary steps if it's an operation
		  for ($j=1;$j<=$#numbers;$j++) {

		    ($eval *= int($numbers[$j])) if ($OPER[$LEVEL] eq "*"); # oper *
		    ($eval += int($numbers[$j])) if ($OPER[$LEVEL] eq "+"); # oper +
		    ($eval -= int($numbers[$j])) if ($OPER[$LEVEL] eq "-"); # oper -

		    ($eval = (($eval == int($numbers[$j])) ? "t" : "nil"))
				if ($OPER[$LEVEL] eq "=");	       # oper =

		    ($eval = (((int($numbers[$j])==0) || ($numbers[$j] eq "nil")) ? "nil" : $eval))
				if ($OPER[$LEVEL] eq "and");	       # oper and

		    ($eval = (((int($numbers[$j])==0) || ($numbers[$j] eq "nil")) ? $eval : int($numbers[$j])))
				if ($OPER[$LEVEL] eq "or");	       # oper or
		  }
		}

		# if it is a logic operation (= and or)
		# then just return 0 for 0 and 1 for the rest
		#if (($OPER[$LEVEL] eq "=")
		#    || ($OPER[$LEVEL] eq "and")
		#    || ($OPER[$LEVEL] eq "or")) {
		#
		#  $eval = ($eval == 0) ? 0 : 1;
		#}

		# DEBUG 
		(print "} eval: $eval\n\n") if ($DEBUG);
		# DEBUG 

		# close this level
		$LEVEL--;

		# check for completation of interpretation
		if ($LEVEL == 0) {	# it this was the last level
		   print "= Result: $eval\n"; # report the value

		} else {		# else add the value to the
					# end of parent level
		  $VALUES[$LEVEL] .= ",$eval";
		}
		pop (@OPER);
		pop (@VALUES);
	      }
	      else {			# Parse the number
		$value='';		# Clean the value first

		# Parse the whole number terminated by a space
		# or by a ) character
		while ( ($i<length($LISP)) && ($char ne " ") && ($char ne ")") ) {
		   $value .= $char;
		   $i++;
	    	   $char = substr($LISP,$i,1);
		}

		# if it is terminated by a space of ) then
		# decrease the cursor so we wont skip
		# a ) sign
		if (($char eq " ") || ($char eq ")")) {
		   $i--;
		}

		# if the value is "nil" then translate it to 0
		# if the value is "t" then translate it to 1
		#($value = 0) if ($value eq "nil");
		#($value = 1) if ($value eq "t");

		# add the current value to the end of the
		# value list for this level
		$VALUES[$LEVEL] .= ",$value";
	      }
            } else {			# catch spaces
	      # DEBUG 
	      # print "CC: $char ($next_is_oper)\n";
	      # DEBUG 
	    }
	}
}


###
### SPLITER
### FUNCTION
###
### @param	: string -> list string
### @return	: array
### @output	: n/a
###
sub splitIt ($)
{ 
	  # get input 
	  local $str = shift @_;
	  $str =~ s/\ \ +/ /g;

	  # vars
	  local @values = undef;
	  local $paran = 0;
	  local $index = 0;
	  local $i = 0;
	
	  push (@values, "");
	 
	  for ($i=0; $i<length($str); $i++) {
	    $char = substr($str,$i,1);
	
	    if ($char eq "(") {
	      $values[$index].='(';
	      $paran++;
	    }
	    elsif ($char eq ")") {
	      $values[$index].=')';
	      $paran--;
	    }
	    elsif (($char eq " ") && ($paran == 0)) {
	        $index++;
	        push (@values,"");
	    }
	    else {
	      $values[$index].=$char;
	    }
	  }
	
	  # return the array
	  return @values;
}

###
### SYMBOL TABLE LOOKUP
### FUNCTION
###
### @param	: string -> symbol name
### @return	: symbol value
### @output	: n/a
###
sub symbolLookup ($)
{ 
   local $name = shift @_;

   return ($SYMBOLS{$name} eq "") ? $name : $SYMBOLS{$name};
}