objpascal/mal_types.pas

   1 unit mal_types;
   2
   3 {$H+} // Use AnsiString
   4
   5 interface
   6
   7 uses sysutils,
   8      fgl;
   9
  10 // Ancestor of all Mal types
  11
  12 type TMal = class(TObject);
  13
  14
  15 // Some general type definitions
  16
  17 type
  18     TMalArray = array of TMal;
  19     // TODO: use http://bugs.freepascal.org/view.php?id=27206 when
  20     // incorporated into FPC
  21     TMalDict = specialize TFPGMap<string,TMal>;
  22
  23 type TMalException = class(Exception)
  24     public
  25         Val: TMal;
  26
  27         constructor Create(V : TMal);
  28 end;
  29
  30
  31 // Mal types
  32
  33 type TMalNil = class(TMal);
  34 type TMalTrue = class(TMal);
  35 type TMalFalse = class(TMal);
  36
  37 type TMalInt = class(TMal)
  38     public
  39         Val: int64;
  40
  41         constructor Create(V : int64);
  42 end;
  43
  44 type TMalString = class(TMal)
  45     public
  46         Val: string;
  47
  48         constructor Create(V : string);
  49 end;
  50
  51 type TMalSymbol = class(TMal)
  52     public
  53         Val: string;
  54
  55         constructor Create(V : string);
  56 end;
  57
  58
  59 type TMalList = class(TMal)
  60     public
  61         Val:  TMalArray;
  62         Meta: TMal;
  63
  64         constructor Create();
  65         constructor Create(V : TMalArray);
  66         function Rest() : TMalList;
  67
  68         constructor Clone(L : TMalList);
  69 end;
  70
  71 type TMalVector = class(TMalList)
  72 end;
  73
  74 type TMalAtom = class(TMal)
  75     public
  76         Val: TMal;
  77
  78         constructor Create(V : TMal);
  79 end;
  80
  81 type TMalHashMap = class(TMal)
  82     public
  83         Val: TMalDict;
  84         Meta: TMal;
  85
  86         constructor Create();
  87         constructor Create(V : TMalDict);
  88         constructor Create(V : TMalArray);
  89
  90         constructor Clone(HM : TMalHashMap);
  91
  92         function assoc_BANG(KVs: TMalArray) : TMal;
  93         function dissoc_BANG(Ks: TMalArray) : TMal;
  94 end;
  95
  96
  97 // General type functions
  98
  99 function GetBacktrace(E: Exception) : string;
 100
 101 function wrap_tf(x : Boolean) : TMal;
 102
 103 function _equal_Q(A : TMal; B : TMal) : Boolean;
 104
 105 function _sequential_Q(Obj: TMal) : Boolean;
 106
 107 function _list() : TMalList;
 108 function _list(A: TMal) : TMalList;
 109 function _list(A: TMal; B: TMal) : TMalList;
 110 function _list(A: TMal; B: TMal; C: TMal) : TMalList;
 111
 112 function _concat(A: TMalArray; B: TMalArray) : TMalArray;
 113
 114 function _string_Q(Obj: TMal) : Boolean;
 115
 116 ////////////////////////////////////////////////////////////
 117
 118 implementation
 119
 120 constructor TMalException.Create(V : TMal);
 121 begin
 122     inherited Create('MalException');
 123     Self.Val := V;
 124 end;
 125
 126 //
 127 // Mal types
 128 //
 129
 130 constructor TMalInt.Create(V : int64);
 131 begin
 132     inherited Create();
 133     Self.Val := V;
 134 end;
 135
 136 constructor TMalString.Create(V : string);
 137 begin
 138     inherited Create();
 139     Self.Val := V;
 140 end;
 141
 142 constructor TMalSymbol.Create(V : string);
 143 begin
 144     inherited Create();
 145     Self.Val := V;
 146 end;
 147
 148 constructor TMalList.Create();
 149 begin
 150     inherited Create();
 151     SetLength(Self.Val, 0);
 152 end;
 153
 154 constructor TMalList.Create(V : TMalArray);
 155 begin
 156     inherited Create();
 157     Self.Val := V;
 158 end;
 159
 160 constructor TMalList.Clone(L : TMalList);
 161 begin
 162     inherited Create();
 163     Self.Val := copy(L.Val, 0, Length(L.Val));
 164 end;
 165
 166
 167 function TMalList.Rest() : TMalList;
 168 begin
 169     if Length(Val) <= 1 then
 170         Rest := (_list() as TMalList)
 171     else
 172         Rest := TMalList.Create(copy(Val, 1, Length(Val)-1));
 173 end;
 174
 175 // Hash Maps
 176
 177 constructor TMalHashMap.Create();
 178 begin
 179     inherited Create();
 180     Self.Val := TMalDict.Create;
 181 end;
 182
 183 constructor TMalHashMap.Create(V : TMalDict);
 184 begin
 185     inherited Create();
 186     Self.Val := V;
 187 end;
 188
 189 function TMalHashMap.assoc_BANG(KVs: TMalArray) : TMal;
 190 var
 191     I : longint;
 192 begin
 193     I := 0;
 194     while I < Length(KVs) do
 195     begin
 196         Self.Val[(KVs[I] as TMalString).Val] := KVs[I+1];
 197         I := I + 2;
 198     end;
 199     assoc_BANG := Self;
 200 end;
 201
 202 function TMalHashMap.dissoc_BANG(Ks: TMalArray) : TMal;
 203 var
 204     I : longint;
 205 begin
 206     for I := 0 to Length(Ks)-1 do
 207         Self.Val.Remove((Ks[I] as TMalString).Val);
 208     dissoc_BANG := Self;
 209 end;
 210
 211
 212 constructor TMalHashMap.Create(V : TMalArray);
 213 begin
 214     Self.Create();
 215     Self.assoc_BANG(V);
 216 end;
 217
 218 constructor TMalHashMap.Clone(HM : TMalHashMap);
 219 var
 220     I : longint;
 221 begin
 222     Self.Create();
 223     I := 0;
 224     while I < HM.Val.Count do
 225     begin
 226         Self.Val[HM.Val.Keys[I]] := HM.Val[HM.Val.Keys[I]];
 227         I := I + 1;
 228     end;
 229 end;
 230
 231
 232 // Atoms
 233
 234 constructor TMalAtom.Create(V : TMal);
 235 begin
 236     inherited Create();
 237     Self.Val := V;
 238 end;
 239
 240 //
 241 // General type functions
 242 //
 243
 244 function GetBacktrace(E: Exception) : string;
 245 var
 246   I: Integer;
 247   Frames: PPointer;
 248 begin
 249   GetBacktrace := BackTraceStrFunc(ExceptAddr);
 250   Frames := ExceptFrames;
 251   for I := 0 to ExceptFrameCount - 1 do
 252     GetBacktrace := GetBacktrace + #10 + BackTraceStrFunc(Frames[I]);
 253 end;
 254
 255 function wrap_tf(x : Boolean) : TMal;
 256 begin
 257     if x = true then wrap_tf := TMalTrue.Create
 258     else             wrap_tf := TMalFalse.Create;
 259 end;
 260
 261 function _equal_Q(A : TMal; B : TMal) : Boolean;
 262 var
 263     I            : longint;
 264     ArrA, ArrB   : TMalArray;
 265     DictA, DictB : TMalDict;
 266     Key          : string;
 267 begin
 268     if not ((A.ClassType = B.ClassType) or
 269             ((A is TMalList) and (B is TMalList))) then
 270         _equal_Q := false
 271     else
 272     begin
 273         if A is TMalList then
 274         begin
 275             ArrA := (A as TMalList).Val;
 276             ArrB := (B as TMalList).Val;
 277             if Length(ArrA) <> Length(ArrB) then
 278                 Exit(false);
 279             for I := 0 to Length(ArrA)-1 do
 280                 if not _equal_Q(ArrA[I], ArrB[I]) then
 281                     Exit(false);
 282             _equal_Q := true;
 283         end
 284         else if A is TMalHashMap then
 285         begin
 286             DictA := (A as TMalHashMap).Val;
 287             DictB := (B as TMalHashMap).Val;
 288             if DictA.Count <> DictB.Count then
 289                 Exit(false);
 290             for I := 0 to DictA.Count-1 do
 291             begin
 292                 Key := DictA.Keys[I];
 293                 if DictB.IndexOf(Key) < 0 then
 294                     Exit(false);
 295                 if not _equal_Q(DictA[Key], DictB[Key]) then
 296                     Exit(false);
 297             end;
 298             _equal_Q := true;
 299         end
 300         else if A is TMalString then
 301             _equal_Q := (A as TMalString).Val = (B as TMalString).Val
 302         else if A is TMalSymbol then
 303             _equal_Q := (A as TMalSymbol).Val = (B as TMalSymbol).Val
 304         else if A is TMalInt then
 305             _equal_Q := (A as TMalInt).Val = (B as TMalInt).Val
 306         else if A is TMalNil then
 307             _equal_Q := B is TMalNil
 308         else if A is TMalTrue then
 309             _equal_Q := B is TMalTrue
 310         else if A is TMalFalse then
 311             _equal_Q := B is TMalFalse
 312         else
 313             _equal_Q := A = B;
 314     end
 315 end;
 316
 317 function _sequential_Q(Obj: TMal) : Boolean;
 318 begin
 319     _sequential_Q := Obj is TMalList;
 320 end;
 321
 322
 323 function _list() : TMalList;
 324 var
 325     Arr: TMalArray;
 326 begin
 327     SetLength(Arr, 0);
 328     _list := TMalList.Create(Arr);
 329 end;
 330
 331 function _list(A: TMal) : TMalList;
 332 var
 333     Arr: TMalArray;
 334 begin
 335     SetLength(Arr, 1);
 336     Arr[0] := A;
 337     _list := TMalList.Create(Arr);
 338 end;
 339
 340 function _list(A: TMal; B: TMal) : TMalList;
 341 var
 342     Arr: TMalArray;
 343 begin
 344     SetLength(Arr, 2);
 345     Arr[0] := A;
 346     Arr[1] := B;
 347     _list := TMalList.Create(Arr);
 348 end;
 349
 350 function _list(A: TMal; B: TMal; C: TMal) : TMalList;
 351 var
 352     Arr: TMalArray;
 353 begin
 354     SetLength(Arr, 3);
 355     Arr[0] := A;
 356     Arr[1] := B;
 357     Arr[2] := C;
 358     _list := TMalList.Create(Arr);
 359 end;
 360
 361 function _concat(A: TMalArray; B: TMalArray) : TMalArray;
 362 var
 363     Res : TMalArray;
 364     I   : longint;
 365 begin
 366     SetLength(Res, Length(A) + Length(B));
 367     for I := 0 to Length(A)-1 do
 368         Res[I] := A[I];
 369     for I := 0 to Length(B)-1 do
 370         Res[I+Length(A)] := B[I];
 371     _concat := Res;
 372 end;
 373
 374 function _string_Q(Obj: TMal) : Boolean;
 375 var
 376     Str : string;
 377 begin
 378     if (Obj is TMalString) then
 379     begin
 380         Str := (Obj as TMalString).Val;
 381         _string_Q := (Length(Str) = 0) or (Str[1] <> #127)
 382     end
 383     else
 384         _string_Q := false;
 385 end;
 386
 387 end.