Plaster

(macroexpand '(bloop:bloop (5 LET A = 0) (10 LET A = (1+ A)) (15 PRINT "A:" _ A %) (20 IF (< 20 A) THEN 30) (25 GOSUB 10) (30 END))) (BLOCK BLOOP::BLOOP-PROG (LET* ((BLOOP::LINE-NUMS '(5 10 15 20 25 30 65536)) (BLOOP::RSTACK NIL) (BLOOP::LNUM 0)) (LABELS ((BLOOP::RT-HUH (BLOOP::TEST BLOOP::LABEL &REST REST) (OR BLOOP::TEST (IF BLOOP:*BREAK-ON-HUH* (BREAK) (ERROR "!~A@~D~{ ~A~}" BLOOP::LABEL BLOOP::LNUM REST)))) (BLOOP::RT-EVAL (BLOOP::X) (ANAPHORA:ACOND ((BLOOP::RT-ID BLOOP::X NIL) (SYMBOL-VALUE (OR (FIND-SYMBOL ANAPHORA:IT) (BLOOP::RT-HUH "ID" BLOOP::X)))) ((AND (SYMBOLP BLOOP::X) (BOUNDP BLOOP::X)) (SYMBOL-VALUE BLOOP::X)) ((SYMBOLP BLOOP::X) BLOOP::X) (T (MULTIPLE-VALUE-BIND (BLOOP::V BLOOP::E) (IGNORE-ERRORS (EVAL BLOOP::X)) (BLOOP::RT-HUH (NOT BLOOP::E) "EX" BLOOP::E) BLOOP::V)))) (BLOOP::RT-CALL (BLOOP::LNEXP) (BLOOP::RT-HUH (< (LENGTH BLOOP::RSTACK) 10) "DP") (PUSH (1+ BLOOP::LNUM) BLOOP::RSTACK) (BLOOP::RT-JUMP BLOOP::LNEXP)) (BLOOP::RT-JUMP (BLOOP::LNEXP) (LET* ((BLOOP::LN (LET ((BLOOP::R (BLOOP::RT-EVAL BLOOP::LNEXP))) (BLOOP::RT-HUH (TYPEP BLOOP::R '(INTEGER 1 65535)) "GO") BLOOP::R)) (BLOOP::TARG (FIND BLOOP::LN BLOOP::LINE-NUMS :TEST #'<=))) (SETF BLOOP::LNUM BLOOP::TARG))) (BLOOP::RT-TRUEP (BLOOP::X) (LET ((BLOOP::R (BLOOP::RT-EVAL BLOOP::X))) (TYPECASE BLOOP::R (NUMBER (NOT (ZEROP BLOOP::R))) (STRING (NOT (ALEXANDRIA:EMPTYP BLOOP::R))) (T (WHEN BLOOP::R T))))) (BLOOP::RT-ID (BLOOP::X &OPTIONAL (BLOOP::ERR T)) (LET* ((BLOOP::IDSTR (AND (TYPEP BLOOP::X '(OR STRING SYMBOL)) (STRING-UPCASE BLOOP::X))) (BLOOP::IDLEN (IF BLOOP::IDSTR (LENGTH BLOOP::IDSTR) 0)) (BLOOP::BEGOK (AND (PLUSP BLOOP::IDLEN) (CHAR<= #\A (AREF BLOOP::IDSTR 0) #\Z))) (BLOOP::MIDOK (OR (< BLOOP::IDLEN 3) (EVERY (LAMBDA (BLOOP::X) (CHAR<= #\0 BLOOP::X #\9)) (SUBSEQ BLOOP::IDSTR 1 (1- BLOOP::IDLEN))))) (BLOOP::ENDOK (OR (< BLOOP::IDLEN 2) (LET ((BLOOP::C (AREF BLOOP::IDSTR (1- BLOOP::IDLEN)))) (CHAR= #\$ BLOOP::C) (CHAR<= #\0 BLOOP::C #\9))))) (OR (AND BLOOP::BEGOK BLOOP::MIDOK BLOOP::ENDOK BLOOP::IDSTR) (AND BLOOP::ERR (BLOOP::RT-HUH NIL "ID" BLOOP::X))))) (BLOOP::RT-SET (BLOOP::ID BLOOP::VAL) (SETF (SYMBOL-VALUE (ALEXANDRIA:ENSURE-SYMBOL (STRING-UPCASE BLOOP::ID))) BLOOP::VAL)) (BLOOP::RT-PRINT (BLOOP::EXPRS) (LOOP :FOR BLOOP::PREV-CTL = NIL :THEN BLOOP::CTL :FOR BLOOP::PREV-VAL = NIL :THEN (NOT BLOOP::CTL) :FOR BLOOP::X BLOOP::IN BLOOP::EXPRS :FOR BLOOP::VAL = (BLOOP::RT-EVAL BLOOP::X) :FOR BLOOP::CTL = (AND (TYPEP BLOOP::VAL 'SYMBOL) (FIND (STRING BLOOP::X) '("%" "_") :TEST #'EQUAL)) :UNLESS (EQUAL BLOOP::CTL "_") :DO (FORMAT T "~:[~; ~]~@[~{~A~}~]~:[~;~0,8T~]" (AND BLOOP::PREV-VAL (NOT BLOOP::CTL)) (UNLESS BLOOP::CTL (LIST BLOOP::VAL)) (EQUAL BLOOP::CTL "%")) :FINALLY (UNLESS BLOOP::PREV-CTL (TERPRI))))) (TAGBODY 5 (LET ((BLOOP::ID (BLOOP::RT-ID 'A))) (BLOOP::RT-SET BLOOP::ID (BLOOP::RT-EVAL '0))) 10 (LET ((BLOOP::ID (BLOOP::RT-ID 'A))) (BLOOP::RT-SET BLOOP::ID (BLOOP::RT-EVAL '(1+ A)))) 15 (BLOOP::RT-PRINT '("A:" _ A %)) 20 (WHEN (BLOOP::RT-TRUEP '(< 20 A)) (BLOOP::RT-JUMP '30) (GO BLOOP::JUMP-TABLE)) 25 (BLOOP::RT-JUMP 10) (GO BLOOP::JUMP-TABLE) 30 (RETURN-FROM BLOOP::BLOOP-PROG T) 65536 (RETURN-FROM BLOOP::BLOOP-PROG T) BLOOP::JUMP-TABLE (ECASE BLOOP::LNUM (5 (GO 5)) (10 (GO 10)) (15 (GO 15)) (20 (GO 20)) (25 (GO 25)) (30 (GO 30)) (65536 (GO 65536)))))))