#!/usr/bin/perl

# The Algol Run-Time

#
# There's the stack.
$sp = 0;
@stack = ();
sub push {
  $stack[$sp--] = @_[0];
}
sub pop {
  return $stack[$++sp];
}

# There's the code array
$pc = 0;
@code = ();

sub read1 {
  if ($device != 1) {
    &indev;
  } else {
    &ttin;
  }
}

#
# The dispatch table.
@disp100 = (
  *next,   *array, *sdev,  *read,  *put,   *string, *print, *chin,
  *chout,  *jump,  *exitp, *en,    *get,   *add,    *iget,  *iput,
  *set,    *neg,   *pow,   *mul,   *div,   *sub,    *eq,    *ne,
  *lt,     *gt,    *le,    *ge,    *jnt,   *pnext,  *not,   *xand,
  *or,     *init,  *forst, *eo,    *ep,    *gp,     *gg,    *di,
  *skip,   *isign, *seth,  *fix,   *fls1,  *fcons,  *flneg, *setlab,
  *switch, *rpow,  *flmpy, *fls2,  *fldiv, *fladd,  *flsub, *pform,
  *fsign,  *jf,    *enf,   *epf,   *fstr,  *svs,    *gform, *stop,
}

#
# Implementations of each of the 64 instructions.
sub next {
  # Next (NOP)
  # Default behavior is to fetch the next instruction,
  # so nothing to do here.
}
sub array {
  # Allocate array(s).
  # s1 is depth of declaration
  # s2 is number of declarations
  # s3 is number of declarations
  # s4 is number of declarations
  # s5 is number of declarations
  # s6 is number of declarations
  # s7 is number of declarations
  # s8..N bounds of other subscripts
  $t4 = -&next6; # Number of declarations
  $t1 = &next6 + 16; # Address of first
  $t2 = &pop; # Bounds
  $t3 = &pop; # Bounds
  $t2 = $t2 - $t3 + 1; # Size
  while (++$t4) {
    $mem[$t1++] = $arbase - $t3 + 1;
    $arbase += $t2;
  }
}
sub sdev {
  # Set which I/O device.
  $device = &pop;
}
sub readi {
  # Read a value from the current input device.
  # BUGBUG: This is the integer version.  Is there an FP version?
  $t1 = $t2 = 0;
  while (1) {
    $ch = &read1;
    next if $ch == '\r';
    next if $ch == '\n';
    next if $ch == ' ';
    if ($ch == '-') {
      $ch = &read1;
    } else {
      $t2 = -1;
    }
    last;
  }
  while (1) {
    last unless ($ch >= '0') && ($ch <= '9');
    $t1 = $t1*10 + $ch - '0';
    $ch = &read1;
  }
  return ++$t2? -$t1 : $t1;
}
sub put {
  # Store S1 in the specified variable.
  $t1 = &next6 + $fp; # Destination address
  $memory[$t1] = &pop;
}
sub string {
  # Print a string.
  while (($ch = &next6)) {
    # PARITY: No mark parity done here.
    &xout($ch > 040? $ch : $ch+100);
  }
}
sub dig {
  return unless $t5 || $_[0];
  &xout($_[0]+'0');
  $t5 = 1;
}
sub printi {
  # Print the integer in S1.
  $sudomq = &pop;
  if ($sudomq < 0) {
    &xout('-')
    $sudomq = -$sudomq;
  }
  $t5 = 0;
  $t1 = $sudomq % 10; %sudomq /= 10;
  $t2 = $sudomq % 10; %sudomq /= 10;
  $t3 = $sudomq % 10; %sudomq /= 10;
  &dig($sudomq) if $sudomq;
  &dig($t3);
  &dig($t2);
  &xout($t1+'0');
}
sub chin {
  &push(&indev);
}
sub chout {
  &xout(&pop);
}
sub jump {
  $pc = $code[++$pc];
}
sub exitp {
  # Leave a procedure.
  $t1 = 0;
  $23 = $ax1 = $level - 1;
  $abas = $memory[++$ax1];
  $level = $memory[++$ax1];
  $pc = $memory[++$ax1];
  if (!++$t1) {
    $sw1 = 0;
# BUGBUG: Procedure and code results need fixing.
# (Has to do with PNEXT+1).
    return $memory[++$ax1];
  }
}
sub en {
  # Enter a parameterless procedure.
  $t3 = 0; # Number of parameters
  &akbchkl
# 10020 points to the start of the main program variables.
# 10021 points to base of the working stack for the current level.
# 10022 points to the start of the current procedure's variables.
#   [0] is the current procedure number.
#   [1] is the return address.
#   [2] is the base for the calling procedure (22).
#   [3] is the saved SP (wstack base, 21) of the previous level.
#   [3] is the array base (24) of the calling level.
# 10023 points to next free space on the vstack.
# 10024 points to base of the current aray stack level.
# 10026 is the current instruction word..
# 10027 is PC.
# 10032 is SP for the working stack.
# Result at offset 3
# Parameters at offsets 4..N.
# Integers are at offset +2 witin a variable.
# Code in field 0, data in field 1.
# V=00175 is the next free location in field 0.
  $ax1 = $23;
  $memory[++$ax1] = $abas;
  $t1 = $code[$pc+1]; # Procedure address
  $memory[$t1]
EN,	DCA T3; JMS I AKBCHK	/NUMBER OF PARAMS TO T3
	TAD 23; DCA 11	/ADDRESS V0 NEW LEVEL
	TAD ABAS; DCA I 11	/V0=OLD ARRAY BASE
	CDF 10; TAD I PC; DCA T1	/ADDRESS OF PROCEDURE
	TAD I T1; CDF; IAC; TAD 23; DCA 23 /ADD FIXED SPACE TO POINTER
	TAD 22; DCA I 11	/SAVE BASE OF OLD LEVEL IN V1
	CMA; TAD 11; DCA 22 /NEW BASE = OLD FREE SPACE POINTER+1
	TAD PC; DCA I 11	/SAVE RETURN ADDRESS IN V2
	TAD T1; DCA PC	/SET PC TO ENTER PROCEDURE
	TAD T3; SNA; JMP NEXA	/ENTER IF NO PARAMS
	TAD 11; IAC; DCA T2	/ADDRESS LAST PARAMATER
	TAD T3; CIA; DCA T3	/SET UP COUNT
EP1,	ISZ SP; TAD I SP; DCA I T2; ISZ T3; SKP; JMP NEXA
	CMA; TAD T2; DCA T2
	JMP EP1
}
sub get {
}
sub add {
}
sub iget {
}
sub iput {
}
sub set {
}
sub neg {
}
sub pow {
}
sub mul {
}
sub div {
}
sub sub {
}
sub eq {
}
sub ne {
}
sub lt {
}
sub gt {
}
sub le {
}
sub ge {
}
sub jnt {
}
sub pnext {
}
sub not {
}
sub xand {
}
sub or {
}
sub init {
}
sub forst {
}
sub eo {
}
sub ep {
}
sub gp {
}
sub gg {
}
sub di {
}
sub skip {
  # Print a newline.
  &xout('\r');
  &xout('\n');
}
sub isign {
}
sub seth {
}
sub fix {
}
sub fls1 {
}
sub fcons {
}
sub flneg {
}
sub setlab {
}
sub switch {
}
sub rpow {
}
sub flmpy {
}
sub fls2 {
}
sub fldiv {
}
sub fladd {
}
sub flsub {
}
sub pform {
}
sub fsign {
}
sub jf {
}
sub enf {
}
sub epf {
}
sub fstr {
}
sub svs {
}
sub gform {
}
sub stop {
  # Just stop running.
  $running = 0;
}

#
# Fetch the next 6bit quantity, advancing PC as needed.
$sw1 = 0;
sub next6 {
  if (!++$sw1) {
    return $word & 077;
  }
  $word = $code[++$pc];
  $sw1 = -1;
  return $word >> 6;
}

#
# Here's the main fetch-execute loop.
$running = 1;
while ($running) {
  # Fetch the next sixbit opcode.
  $inst = &next6;
  # Dispatch.
  *f = $dispatch[$inst];
  &f;
}
return 0;

sub xnext6 {
  local($arg1) = @_;
  if (!++$sw1) {
    return $word & 077;
  }
  $word = $code[$arg1];
  $sw1 = -1;
  return $word >> 6;
}
pnex:
  $stack[$sp--] = ac;
nex:
  if (!++$sw1) {
    &disp100[$word & 077];
  }
nexa:
  $word = $code[$pc];
  $sw1 = -1;
  &disp100[$word >> 6];
j:
  $sw1 = 0;
  $pc = $code[$pc-1];
JMP NEXA+1

EP,	NEXT6; JMP EN
EFOUR,	IAC
ETHRE,	IAC
ETWO,	IAC
EO,	IAC
EN,	DCA T3; JMS I AKBCHK	/NUMBER OF PARAMS TO T3
	TAD 23; DCA 11	/ADDRESS V0 NEW LEVEL
	TAD ABAS; DCA I 11	/V0=OLD ARRAY BASE
	CDF 10; TAD I PC; DCA T1	/ADDRESS OF PROCEDURE
	TAD I T1; CDF; IAC; TAD 23; DCA 23 /ADD FIXED SPACE TO POINTER
	TAD 22; DCA I 11	/SAVE BASE OF OLD LEVEL IN V1
	CMA; TAD 11; DCA 22 /NEW BASE = OLD FREE SPACE POINTER+1
	TAD PC; DCA I 11	/SAVE RETURN ADDRESS IN V2
	TAD T1; DCA PC	/SET PC TO ENTER PROCEDURE
	TAD T3; SNA; JMP NEXA	/ENTER IF NO PARAMS
	TAD 11; IAC; DCA T2	/ADDRESS LAST PARAMATER
	TAD T3; CIA; DCA T3	/SET UP COUNT
EP1,	ISZ SP; TAD I SP; DCA I T2; ISZ T3; SKP; JMP NEXA
	CMA; TAD T2; DCA T2
	JMP EP1


*400
GG,	NEXT6; TAD 20; DCA T1
	TAD I T1; JMP I PNEXT+1

EXTPR,	CMA
EXPR,	DCA T1
	CMA; TAD 22; DCA 11	/ADDRESS V0
	TAD 11; DCA 23	/FREE SPACE POINTER=OLD BASE-1
	TAD I 11; DCA ABAS
	TAD I 11; DCA 22	/RESTORE OLD BASE
	JMP EXCON


INIT,	DCA SW1; CLA; DCA PC; IAC; DCA DEV /TELETYPE
	TAD XEINT; DCA 20	/VARAIBLES START AFTER INTERPRETER
	TAD 20; DCA 22	/LOCAL BASE IS GLOBAL BASE
	TAD 21; TAD 22; DCA 23	/FREE SPACE POINTER
	TAD 23; DCA ABAS	/ARRAYS START AT BOTTOM OF FREE SPACE
	TAD STSP; DCA SP	/WORKING STACK BEFORE SYSTEM
	RFC; TLS; PLS; JMP NEXT
XEINT,	EINT
STSP,	5560	/JUST BELOW OS/8 DRIVER

AAAMUL=.
MUL,	DCA T4; JMS SIGN1; DCA M1; JMS SIGN1
	DCA SUDOMQ; JMS PSDMUY
M1,	0; JMP SIGN2

AAADIV=.
DIV,	DCA T4; JMS SIGN1; DCA D1; JMS SIGN1
	DCA SUDOMQ; JMS PSDDVI
D1,	0
SIGN2,	CLA; TAD SUDOMQ; DCA SIGN1; TAD T4; RAR; CLA
	TAD SIGN1; SZL; CIA; JMP PNEXT
SIGN1,	0; ISZ SP; TAD I SP; SPA; ISZ T4; SPA; CIA; JMP I SIGN1

IPUT,	ISZ SP; TAD I SP; DCA T1	/VALUE
	NEXT6; TAD 20; DCA T2	/ADDRESS ARRAY VARIABLE
	TAD I T2; ISZ SP; TAD I SP; DCA T2	/ADDRESS ELEMENT
	TAD T1; DCA I T2; JMP I NEXT+1

NEG,	ISZ SP; TAD I SP; CIA; JMP I PNEXT+1

NOT,	ISZ SP; TAD I SP; CMA; JMP I PNEXT+1

XAND,	ISZ SP; TAD I SP; DCA T1; ISZ SP; TAD I SP
	AND T1; JMP I PNEXT+1

XPARAM,	0
	ISZ SW1; NOP; CDF 10
	TAD I PC; CDF; JMP I XPARAM

STOP,	JMP I .+1; WAIT

SDEV,	ISZ SP; TAD I SP; DCA DEV; JMP I NEXT+1

SUB,	POP; CIA; POP; JMP I PNEXT+1

EQ,	ISZ SP; TAD I SP; CIA
	ISZ SP; TAD I SP; SNA CLA; CMA; JMP I PNEXT+1

*600

NE,	ISZ SP; TAD I SP; CIA; ISZ SP; TAD I SP
	SZA CLA; CMA; JMP I PNEXT+1

LT,	POP; CIA; POP; SPA CLA; CMA; JMP I PNEXT+1

GT,	POP; CIA; POP; SMA SZA CLA; CMA; JMP I PNEXT+1

LE,	POP; CIA; POP; SPA SNA CLA; CMA; JMP I PNEXT+1

GE,	POP; CIA; POP; SMA CLA; CMA; JMP I PNEXT+1

JNT,	CDF 10; TAD I PC
	CDF; DCA T1; ISZ SP; TAD I SP; SZA CLA; JMP I .+5
	CMA; TAD T1; DCA PC; JMP I .+1; NEXA

AAAOR=.
OR,	POP; DCA T1; POP; SZA CLA; JMP ORTRU
	TAD T1; JMP I PNEXT+1
ORTRU,	CMA; JMP I PNEXT+1

CHIN,	JMS INDEV; JMP I PNEXT+1

SETH,	NEXT6; JMP I PNEXT+1

FORST,	ISZ SP; TAD I SP; DCA T3	/FINAL VALUE
	ISZ SP; TAD I SP; DCA T2	/INCREMENT
	NEXT6; TAD P20; DCA T1	/GLOBAL OR LOCAL BASE
	NEXT6; TAD I T1; DCA T1	/ADDRESS CONTROLLED VARIABLE
	TAD T2; SMA CLA; CMA; DCA T4 /T4=0 IF INCR. NEGATIVE
	TAD T2; TAD I T1; DCA I T1	/DO INCREMENT
	TAD I T1; CIA; TAD T3; ISZ T4; CIA /FINAL-CURRENT
	SMA CLA; CMA; JMP I PNEXT+1
P20,	20

SET,	TAD SW1; SZA CLA; JMP SET1	/IS CONSTANT IN NEXT WORD?
	CDF 10; TAD I PC; CDF; JMP I PNEXT+1	/YES
AASET1=.
SET1,	TAD WORD; AND (77; DCA T2	/MS BITS
	CDF 10; TAD I PC; CDF; DCA WORD
	TAD WORD; RAL; AND (7600 /LS BITS
	TAD T2; RTL; RTL; RTL; JMP I PNEXT+1

IGET,	NEXT6; TAD 20; DCA T1	/ADDRESS ARRAY VARIABLE
	ISZ SP; TAD I SP; TAD I T1; DCA T1	/ADDRESS ELEMENT
	TAD I T1; JMP I PNEXT+1

GP,	NEXT6; TAD 20; DCA T1
	ISZ SP; TAD I SP; DCA I T1; JMP I NEXT+1

*1000

READ,	DCA T1; DCA T2; JMS READ1
	TAD (-215; SNA; JMP READ+2
	TAD (215-240; SNA; JMP READ+2
	TAD (240-212; SNA; JMP READ+2
	TAD (212-255; SZA; JMP POS
	JMS READ1; JMP LOOPR
POS,	TAD (255; DCA T4; CMA; DCA T2; TAD T4
LOOPR,	TAD (-260; SPA; JMP EREAD
	TAD (-11; SMA SZA; JMP EREAD
	TAD (11; DCA T3
	TAD T1; CLL RTL; TAD T1; CLL RAL
	TAD T3; DCA T1; JMS READ1; JMP LOOPR
EREAD,	CLA; TAD T1; ISZ T2; CIA; JMP PNEXT

READ1,	0
	CLA CMA; TAD DEV; SZA CLA; JMP NOECHO
	JMS TTIN; JMP I READ1
NOECHO,	JMS INDEV; JMP I READ1

STRING,	NEXT6; SNA; JMP I NEXT+1
	TAD (-40; SPA; TAD (100; TAD (240
	JMS I XOUT; JMP STRING

AAPRIN=.
PRINT,	POP; CLL; SPA; CIA CML; DCA SUDOMQ
	TAD (255; SZL; JMS I XOUT; CLA; DCA T5
	JMS PSDDVI; 12; DCA T1; JMS PSDDVI; 12; DCA T2
	JMS PSDDVI; 12; DCA T3; TAD SUDOMQ; SZA; JMS DIG
	TAD T3; JMS DIG; TAD T2; JMS DIG
	TAD T1; TAD (260; JMS I XOUT; JMP NEXT

DIG,	0; SNA; JMP D0
PRDIG,	TAD (260; JMS I XOUT; JMP I DIG
D0,	TAD T5; SNA CLA; JMP I DIG; JMP PRDIG

GET,	NEXT6; TAD 22; DCA T1
	TAD I T1; JMP I PNEXT+1


*1200

INDLST,	ERR; LSI; HSI; ERR; ERR; ERR; ERR; ERR
OUTLST,	DUM; TTO; HSO; ERR; ERR; ERR; ERR; ERR

PSDDVI,	0
	DCA PSDCAM; TAD I PSDDVI; ISZ PSDDVI
	CLL CIA; DCA MQLMUY
	TAD P7763; DCA PSDLSR; JMP .+11
	TAD PSDCAM; RAL; DCA PSDCAM
	TAD PSDCAM; TAD MQLMUY; SZL
	DCA PSDCAM; CLA; TAD SUDOMQ; RAL; DCA SUDOMQ
	ISZ PSDLSR; JMP .-14
	TAD PSDCAM; JMP I PSDDVI
PSDCAM,	0
MQLMUY,	0
PSDLSR,	0
P7763,	7763

PSDMUY,	0
	CLA CLL; DCA MQLMUY; TAD P7763; DCA PSDLSR
	TAD I PSDMUY; DCA PSDCAM; ISZ PSDMUY; JMP .+10
	TAD MQLMUY; SNL; JMP .+3
	CLL; TAD PSDCAM; RAR
	DCA MQLMUY; TAD SUDOMQ; RAR; DCA SUDOMQ
	ISZ PSDLSR; JMP .-13; TAD MQLMUY; JMP I PSDMUY


DI,	POP; JMS I ADIX; JMP NEXT

INDEV,	0; TAD DEV; SNA; JMP INZER
	TAD XINLST; DCA .+1; HLT
	SNA; JMP .-2; TAD (-377; SNA; JMP .-5
	TAD (377; JMP I INDEV
INZER,	TAD 60; JMP I INDEV

OUTDEV,	0; DCA T5; TAD DEV; TAD XOUTLST; DCA .+2
	TAD T5; HLT; CLA; JMP I OUTDEV
XINLST,	JMS I INDLST
XOUTLS,	JMS I OUTLST

LSI,	0; KSF; JMP .-1; JMS I AKBCHK; KRB; JMP I LSI

SHL6,	0; RTL; RTL; RTL; AND (7700; JMP I SHL6

PUT,	NEXT6; TAD 22; DCA T1
	ISZ SP; TAD I SP; DCA I T1; JMP I NEXT+1

EXCON,	TAD I 11; DCA PC	/RESTORE PC
	ISZ T1; JMP NEXA	/TYPE PROCEDURE?
	DCA SW1; TAD I 11; JMP I PNEXT+1	/YES, GET RESULT

*1400

MESS,	0; TAD I MESS; ISZ MESS; SNA; JMP I MESS
	JMS TTO; CLA; JMP MESS+1

OCTOUT,	0; DCA SUDOMQ
	JMS PSDDVI; 10; TAD (260; DCA DIG4
	JMS PSDDVI; 10; TAD (260; DCA DIG3
	JMS PSDDVI; 10; TAD (260; DCA DIG2
	TAD SUDOMQ; TAD (260; JMS TTO
	CLA CLL; JMS MESS
DIG2,	0
DIG3,	0
DIG4,	0; 0; JMP I OCTOUT

TTIN,	0; JMS LSI; JMS TTO
	TAD XM215; SNA; JMP CR
CROUT,	TAD X215; JMP I TTIN
CR,	TAD X212; JMS TTO; CLA; JMP CROUT
X215,	215
X212,	212
XM215,	-215

ERR,	0; CLA; TAD (277; JMS TTO; CLA
	TAD ERR; JMS OCTOUT
WAIT,	KCC; JMS MESS; 215; 212; 336; 0
	JMS KBCHK; JMP .-1

KBCHK,	0;
X7600,	7600; KSF; JMP I KBCHK
	KRS; TAD (-220; SNA; JMP EXECUT
	TAD (220-223; SNA; JMP WAIT
	TAD (223-203; SZA CLA; JMP I KBCHK
	KCC; CDF CIF; JMP I X7600
EXECUT,	KCC; CDF CIF; JMP I X200
X200,	200


HSI,	0; JMS KBCHK; RSF; JMP .-2; RRB RFC; JMP I HSI
DUM,	0; JMP I DUM
TTO,	0; TSF; JMP .-1; TLS; JMP I TTO
HSO,	0; PSF; JMP .-1; PLS; JMP I HSO

ADD,	ISZ SP; TAD I SP; ISZ SP; TAD I SP; JMP I PNEXT+1

CHOUT,	ISZ SP; TAD I SP; JMS I XOUT; JMP I NEXT+1

SKIP,	TAD (215; JMS I XOUT; TAD (212; JMS I XOUT; JMP I NEXT+1

PAGE
EINT=.
$