Basic Interpreter, sectorlisp example translated to Common Lisp

basicinterpreter.lisp

; source https://github.com/woodrush/sectorlisp-examples/blob/main/lisp/basic.lisp
; Common Lisp translation: joswig@lisp.de, 2022
; https://gist.github.com/lispm/a2f56a1a6dc5599a039eb7134d99cd4a

(defun basic-example ()
  (BASICINTERPRETER
    (QUOTE (
	    (10   REM FIND AND PRINT PRIME NUMBERS BELOW N_MAX.   )
	    (20   LET N_MAX = (1 1 1 1 1   1 1 1 1 1   1 1 1 1 1) )
	    (30   LET I = (1 1)                                   )
	    (40   IF N_MAX <= I THEN 200                          )
	    (50       LET J = (1 1)                               )
	    (60       IF I <= J THEN 110                          )
	    (70           LET R = I % J                           )
	    (80           IF R <= () THEN 120                     )
	    (90           LET J = J + (1)                         )
	    (100      GOTO 60                                     )
	    (110      PRINT I                                     )
	    (120      LET I = I + (1)                             )
	    (130  GOTO 40                                         )
	    ))))


(defun basicinterpreter (fulllisting)
  (labels ((EXECLINE (STATE FULLLISTING)
             ((LAMBDA (CURSTATEMENT VARENV CURLISTING OUTPUT)
                ((LAMBDA (LABEL STATEMENT BODY)
                   (declare (ignore label))
                   (COND
		     ((eql STATEMENT (QUOTE REM))
		      (CONSSTATE VARENV (CDR CURLISTING) OUTPUT))
		     ((eql STATEMENT (QUOTE LET))
		      (CONSSTATE ((LAMBDA (VARNAME EXPR)
				    (VARENVPREPEND
				      VARNAME
				      (EVALEXPR EXPR VARENV)
				      VARENV))
				  (CAR BODY) (CDR (CDR BODY)))
				 (CDR CURLISTING)
				 OUTPUT))
		     ((eql STATEMENT (QUOTE IF))
		      (CONSSTATE VARENV
				 ((LAMBDA (IFBODY)
				    ((LAMBDA (N DESTLABEL)
				       (COND
					 ((eql NIL N)
					  (CDR CURLISTING))
					 ((QUOTE T)
					  (FINDLABELLISTING
					    DESTLABEL
					    FULLLISTING))))
				     (EVALEXPR (CAR IFBODY) VARENV)
				     (CDR IFBODY)))
				  (PARSEIF BODY))
				 OUTPUT))
		     ((eql STATEMENT (QUOTE PRINT))
		      (CONSSTATE VARENV
				 (CDR CURLISTING)
				 (bAPPEND
				   OUTPUT
				   (CONS (EVALEXPR BODY VARENV) NIL))))
		     ((eql STATEMENT (QUOTE GOTO))
		      (CONSSTATE VARENV
				 (FINDLABELLISTING
				   (CAR BODY) FULLLISTING)
				 OUTPUT))))
                 (CAR CURSTATEMENT)
                 (CAR (CDR CURSTATEMENT))
                 (CDR (CDR CURSTATEMENT))))
              (CAR (CAR (CDR STATE)))
              (CAR STATE)
              (CAR (CDR STATE))
              (CAR (CDR (CDR STATE)))))
           (CONSSTATE (VARENV CURLISTING OUTPUT)
             (CONS VARENV (CONS CURLISTING (CONS OUTPUT ()))))
           (FINDLABELLISTING (LABEL CURLISTING)
             (COND
	       ((eql NIL CURLISTING) NIL)
	       ((eql (CAR (CAR CURLISTING)) LABEL) CURLISTING)
	       ((QUOTE T) (FINDLABELLISTING LABEL (CDR CURLISTING)))))
           (b+ (N M)
             (COND
	       ((eql NIL M) N)
	       ((QUOTE T) (b+ (CONS (QUOTE 1) N) (CDR M)))))
           (b- (N M)
             (COND
	       ((eql NIL N) ())
	       ((eql NIL M) N)
	       ((QUOTE T) (b- (CDR N) (CDR M)))))
           (b% (N M)
             (COND
	       ((b<= N (b- M (QUOTE (1)))) N)
	       ((QUOTE T) (b% (b- N M) M))))

           (b<=  (N M)
             (COND
	       ((eql NIL (b- N M)) (QUOTE (1)))
	       ((QUOTE T) NIL)))
           (resolvevar (VARNAME VARENV)
             (COND
	       ((eql (ATOM VARNAME) NIL) VARNAME)
	       ((eql NIL VARENV) ())
	       ((eql VARNAME (CAR (CAR VARENV))) (CDR (CAR VARENV)))
	       ((QUOTE T) (RESOLVEVAR VARNAME (CDR VARENV)))))
           (VARENVPREPEND (VARNAME N VARENV)
             (CONS (CONS VARNAME N) VARENV))
           (EVALEXPR (EXPR VARENV)
             (COND
	       ((eql NIL (CDR EXPR)) (RESOLVEVAR (CAR EXPR) VARENV))
	       ((QUOTE T)
		((LAMBDA (X OPERAND Y)
		   (COND
		     ((eql OPERAND (QUOTE +))  (b+ X Y))
		     ((eql OPERAND (QUOTE -))  (b- X Y))
		     ((eql OPERAND (QUOTE %))  (b% X Y))
		     ((eql OPERAND (QUOTE <=)) (b<= X Y))))
		 (RESOLVEVAR (CAR EXPR) VARENV)
		 (CAR (CDR EXPR))
		 (RESOLVEVAR (CAR (CDR (CDR EXPR))) VARENV)))))
           (PARSEIF (BODY)
             (COND
	       ((eql (CAR (CDR BODY)) (QUOTE THEN))
		(CONS (CONS (CAR BODY) NIL)
		      (CAR (CDR (CDR BODY)))))
	       ((QUOTE T)
		(CONS
		  (CONS (CAR BODY)
			(CONS (CAR (CDR BODY))
			      (CONS (CAR (CDR (CDR BODY)))
				    ())))
		  (CAR (CDR (CDR (CDR (CDR BODY)))))))))
           (bAPPEND (L ITEM)
             (COND
	       ((eql NIL L) ITEM)
	       ((QUOTE T) (CONS (CAR L) (bAPPEND (CDR L) ITEM))))))
    ((LAMBDA (STATE LOOP)
       (funcall LOOP STATE LOOP))
     (CONSSTATE NIL FULLLISTING NIL)
     (LAMBDA (STATE LOOP)
       (COND
	 ((eql NIL (CAR (CDR STATE))) (CAR (CDR (CDR STATE))))
	 ((QUOTE T)
	  (funcall LOOP (EXECLINE STATE FULLLISTING) LOOP)))))))