-- JaMTypeImpl.mesa
-- Last edit by Doug Wyatt,  8-Oct-81  0:16:49

DIRECTORY
  JaMBasic USING [Object, ObType],
  JaMInternal USING [Frame, Stack],
  JaMOps USING [DictLength, Equality, Error, Install, InstallReason, limitchk,
    MakeName, NameToString, Pop, Push, PushBoolean, PushInteger, PushReal,
    rangechk, RegisterExplicit, StringCompare, StringToken, Top, typechk],
  Inline USING [LowHalf],
  Real USING [Fix];

JaMTypeImpl: PROGRAM
IMPORTS JaMOps, Inline, Real
EXPORTS JaMOps = {
OPEN JaMOps, JaMInternal, JaMBasic;

-- Globals

typeName: ARRAY ObType OF name Object;

-- Procedures

Length: PUBLIC PROC[ob: Object] RETURNS[CARDINAL] = {
  len: CARDINAL _ 1; -- default length is 1
  WITH ob:ob SELECT FROM
    string => len _ ob.length;
    array => len _ ob.length;
    dict => len _ DictLength[ob];
    name => len _ NameToString[ob].length;
    ENDCASE;
  RETURN[len];
  };

Compare: PUBLIC PROC[a,b: Object] RETURNS[Equality] = {
  -- Checks for equality of values of objects
  WITH a:a SELECT FROM
    null => WITH b:b SELECT FROM
      null => RETURN[T];
      ENDCASE;
    integer => WITH b:b SELECT FROM
      integer => RETURN[IF a.ivalue=b.ivalue THEN T ELSE F];
      real => RETURN[IF a.ivalue=b.rvalue THEN T ELSE F];
      ENDCASE;
    real => WITH b:b SELECT FROM
      integer => RETURN[IF a.rvalue=b.ivalue THEN T ELSE F];
      real => RETURN[IF a.rvalue=b.rvalue THEN T ELSE F];
      ENDCASE;
    boolean => WITH b:b SELECT FROM
      boolean => RETURN[IF a.bvalue=b.bvalue THEN T ELSE F];
      ENDCASE;
    name => WITH b:b SELECT FROM
      name => RETURN[IF a.id=b.id THEN T ELSE F];
      string => RETURN[IF StringMatch[NameToString[a],b] THEN T ELSE F];
      ENDCASE;
    string => WITH b:b SELECT FROM
      name => RETURN[IF StringMatch[a,NameToString[b]] THEN T ELSE F];
      string => RETURN[IF StringMatch[a,b] THEN T ELSE F];
      ENDCASE;
    stream => WITH b:b SELECT FROM
      stream => RETURN[IF a.index=b.index AND a.stamp=b.stamp THEN T ELSE F];
      ENDCASE;
    command => WITH b:b SELECT FROM
      command => RETURN[IF a.index=b.index THEN T ELSE F];
      ENDCASE;
    dict => WITH b:b SELECT FROM
      dict => RETURN[IF a.dict=b.dict THEN T ELSE F];
      ENDCASE;
    array => WITH b:b SELECT FROM
      array => RETURN[IF a.length=b.length AND a.base=b.base THEN T ELSE F];
      ENDCASE;
    mark => WITH b:b SELECT FROM
      mark => RETURN[T];
      ENDCASE;
    user => WITH b:b SELECT FROM
      user => RETURN[IF a.data=b.data AND a.stamp=b.stamp THEN T ELSE F];
      ENDCASE;
    exec => WITH b:b SELECT FROM
      exec => RETURN[T];
      ENDCASE;
    loop => WITH b:b SELECT FROM
      loop => RETURN[T];
      ENDCASE;
    scope => WITH b:b SELECT FROM
      scope => RETURN[IF a.top=b.top AND a.id=b.id THEN T ELSE F];
      ENDCASE;
    ENDCASE;
  RETURN[nil];
  };

StringMatch: PROC[a,b: string Object] RETURNS[BOOLEAN] = INLINE {
  IF a.length=b.length THEN RETURN[StringCompare[a,b]=0]
  ELSE RETURN[FALSE] };

-- Type-specific stack operations

PopInteger: PUBLIC PROC[stack: Stack] RETURNS[LONG INTEGER] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    integer => RETURN[ob.ivalue];
    ENDCASE => ERROR Error[typechk] };

PopCardinal: PUBLIC PROC[stack: Stack, limit: CARDINAL _ 0]
  RETURNS[CARDINAL] = {
  ob: Object _ Pop[stack];
  max: CARDINAL _ limit;
  IF max=0 THEN max _ LAST[CARDINAL];
  WITH ob:ob SELECT FROM
    integer => { i: LONG INTEGER _ ob.ivalue;
      IF i<0 THEN ERROR Error[rangechk];
      IF i>max THEN ERROR Error[IF limit=0 THEN rangechk ELSE limitchk];
      RETURN[Inline.LowHalf[i]] };
    ENDCASE => ERROR Error[typechk] };

PopReal: PUBLIC PROC[stack: Stack] RETURNS[REAL] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    integer => RETURN[ob.ivalue];
    real => RETURN[ob.rvalue];
    ENDCASE => ERROR Error[typechk] };

PopBoolean: PUBLIC PROC[stack: Stack] RETURNS[BOOLEAN] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    boolean => RETURN[ob.bvalue];
    ENDCASE => ERROR Error[typechk] };

PopString: PUBLIC PROC[stack: Stack] RETURNS[string Object] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    string => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

PopArray: PUBLIC PROC[stack: Stack] RETURNS[array Object] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    array => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

PopDict: PUBLIC PROC[stack: Stack] RETURNS[dict Object] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    dict => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

PopCommand: PUBLIC PROC[stack: Stack] RETURNS[command Object] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    command => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

PopStream: PUBLIC PROC[stack: Stack] RETURNS[stream Object] = {
  ob: Object _ Pop[stack];
  WITH ob:ob SELECT FROM
    stream => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

TopInteger: PUBLIC PROC[stack: Stack] RETURNS[LONG INTEGER] = {
  ob: Object _ Top[stack];
  WITH ob:ob SELECT FROM
    integer => RETURN[ob.ivalue];
    ENDCASE => ERROR Error[typechk] };

TopDict: PUBLIC PROC[stack: Stack] RETURNS[dict Object] = {
  ob: Object _ Top[stack];
  WITH ob:ob SELECT FROM
    dict => RETURN[ob];
    ENDCASE => ERROR Error[typechk] };

-- Intrinsics

JLength: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  PushInteger[frame.opstk,Length[ob]];
  };

JLitChk: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  PushBoolean[frame.opstk,(ob.tag=L)];
  };

JType: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  name: name Object _ typeName[ob.type];
  Push[frame.opstk,name];
  };

JCvLit: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  ob.tag _ L; Push[frame.opstk,ob];
  };

JCvX: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  ob.tag _ X; Push[frame.opstk,ob];
  };

StringToInteger: PROC[frame: Frame, string: string Object]
  RETURNS[LONG INTEGER] = {
  found: BOOLEAN; token: Object;
  [found: found, token: token] _ StringToken[frame,string];
  IF found THEN WITH tok:token SELECT FROM
    integer => RETURN[tok.ivalue];
    ENDCASE;
  ERROR Error[typechk];
  };

StringToReal: PROC[frame: Frame, string: string Object]
  RETURNS[REAL] = {
  found: BOOLEAN; token: Object;
  [found: found, token: token] _ StringToken[frame,string];
  IF found THEN WITH tok:token SELECT FROM
    integer => RETURN[tok.ivalue];
    real => RETURN[tok.rvalue];
    ENDCASE;
  ERROR Error[typechk];
  };

JCvI: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  i: LONG INTEGER;
  WITH ob:ob SELECT FROM
    integer => i _ ob.ivalue;
    real => IF ob.rvalue IN[FIRST[LONG INTEGER]..LAST[LONG INTEGER]]
      THEN i _ Real.Fix[ob.rvalue] ELSE ERROR Error[rangechk];
    string => i _ StringToInteger[frame,ob];
    ENDCASE => ERROR Error[typechk];
  PushInteger[frame.opstk,i];
  };

JCvR: PUBLIC PROC[frame: Frame] = {
  ob: Object _ Pop[frame.opstk];
  r: REAL;
  WITH ob:ob SELECT FROM
    integer => r _ ob.ivalue;
    real => r _ ob.rvalue;
    string => r _ StringToReal[frame,ob];
    ENDCASE => ERROR Error[typechk];
  PushReal[frame.opstk,r];
  };

-- Initialization

InstallType: PROC[why: InstallReason, frame: Frame] = { SELECT why FROM
  register => {
    typeName _ [
      null: MakeName[".nulltype"L],
      integer: MakeName[".integertype"L],
      real: MakeName[".realtype"L],
      boolean: MakeName[".booleantype"L],
      name: MakeName[".nametype"L],
      string: MakeName[".stringtype"L],
      stream: MakeName[".streamtype"L],
      command: MakeName[".commandtype"L],
      dict: MakeName[".dicttype"L],
      array: MakeName[".arraytype"L],
      mark: MakeName[".marktype"L],
      exec: MakeName[".exectype"L],
      loop: MakeName[".looptype"L],
      scope: MakeName[".scopetype"L]
      ];
    RegisterExplicit[frame, ".length"L, JLength];
    RegisterExplicit[frame, ".litchk"L, JLitChk];
    RegisterExplicit[frame, ".type"L, JType];
    RegisterExplicit[frame, ".cvlit"L, JCvLit];
    RegisterExplicit[frame, ".cvi"L, JCvI];
    RegisterExplicit[frame, ".cvli"L, JCvI]; -- just in case
    RegisterExplicit[frame, ".cvr"L, JCvR];
    RegisterExplicit[frame, ".cvx"L, JCvX];
    };
  ENDCASE;
  };

Install[InstallType];

}.