home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 01 / levelki / lisplist.inc < prev    next >
Encoding:
Text File  |  1988-09-29  |  3.1 KB  |  129 lines
  1. (*******************************************************)
  2. (*                      LISP.PAS                       *)
  3. (*         Include-Modul des LittleLisp-Systems        *)
  4. (*          (C) 1988 Reinhard Häring & TOOLBOX         *)
  5. (*******************************************************)
  6.  
  7.  
  8. PROCEDURE error(n:lstring);
  9.   BEGIN
  10.     WriteLn('Internal Error --- ',n);
  11.   END;
  12.  
  13. FUNCTION car(x:objp):objp;
  14.   BEGIN
  15.     IF x^.typ<>3 THEN
  16.       error('car of atom or integer: '+outlist(x))
  17.     ELSE car:=x^.o.car;
  18.   END;
  19.  
  20. FUNCTION cdr(x:objp):objp;
  21.   BEGIN
  22.     IF x^.typ<>3 THEN
  23.       error('cdr of atom or integer :'+outlist(x))
  24.     ELSE cdr:=x^.o.cdr;
  25.   END;
  26.  
  27. FUNCTION cons(a,b:objp):objp;
  28.   VAR o:objp;
  29.   BEGIN
  30.     New(o);
  31.     o^.typ:=3; o^.o.car:=a; o^.o.cdr:=b; cons:=o;
  32.   END;
  33.  
  34. FUNCTION equal(a,b:objp):BOOLEAN;
  35.   BEGIN  equal:=FALSE;
  36.     IF a^.typ=b^.typ THEN
  37.       CASE a^.typ OF
  38.         -1:equal:=TRUE;
  39.         0:equal:=a^.i=b^.i;
  40.         1:equal:=a^.s^=b^.s^;
  41.         2:equal:=a^.a^=b^.a^;
  42.         3:equal:= equal(a^.o.car,b^.o.car)
  43.                   AND equal(a^.o.cdr,b^.o.cdr);
  44.         ELSE error('Unknown Type in Equal');
  45.       END;
  46.     END;
  47.  
  48. FUNCTION eq(a,b:objp):BOOLEAN;
  49.   BEGIN  eq:=FALSE;
  50.     IF a^.typ=b^.typ THEN
  51.       CASE a^.typ OF
  52.         -1:eq:=TRUE;
  53.         0:eq:=a^.i=b^.i;
  54.         1:eq:=a^.s^=b^.s^;
  55.         2:eq:=a^.a^=b^.a^;
  56.         3:eq:= a=b;
  57.         ELSE error('Unknown Type in Eq');
  58.       END;
  59.     END;
  60.  
  61.  
  62. FUNCTION nullp(x:objp):BOOLEAN;
  63.   BEGIN nullp:=-1=x^.typ; END;
  64.  
  65. FUNCTION assoc(a,list:objp):objp;
  66.   BEGIN
  67.   IF list^.typ=-1 THEN assoc:=null ELSE
  68.     IF list^.typ<>3 THEN
  69.       error('Not an AList in assoc: '+outlist(list))
  70.       ELSE BEGIN
  71.        IF equal(a,car(car(list))) THEN assoc:=car(list)
  72.          ELSE assoc:=assoc(a,cdr(list))
  73.   END; END;
  74.  
  75. FUNCTION member(a,l:objp):BOOLEAN;
  76.   BEGIN
  77.     IF nullp(l) THEN member:=FALSE ELSE
  78.       IF 3<>l^.typ THEN member:=FALSE ELSE
  79.         IF equal(car(l),a) THEN member:=TRUE ELSE
  80.           member:=member(a,cdr(l));
  81.   END;
  82.  
  83. FUNCTION llen(a:objp):INTEGER;
  84.   BEGIN
  85.     IF nullp(a) THEN llen:=0 ELSE
  86.       IF a^.typ<>3 THEN
  87.         error('no list for length: '+outlist(a)) ELSE
  88.         llen:=1+llen(cdr(a));
  89.   END;
  90.  
  91. FUNCTION append(a,b:objp):objp;
  92.   BEGIN
  93.     IF nullp(a) THEN append:=b ELSE
  94.     IF nullp(b) THEN append:=a ELSE
  95.     IF a^.typ<>3 THEN
  96.       error('no list for append: '+outlist(a))
  97.     ELSE IF b^.typ<>3 THEN
  98.       error('no list for append: '+outlist(b))
  99.     ELSE
  100.       append:=cons(car(a),append(cdr(a),b));
  101.   END;
  102.  
  103. FUNCTION setcar(list,newcar:objp):objp;
  104.   BEGIN
  105.     IF list^.typ<>3 THEN
  106.         error('setcars argument is no pair: '+outlist(list))
  107.       ELSE BEGIN
  108.         list^.o.car:=newcar;
  109.         setcar:=list;
  110.       END;
  111.   END;
  112.  
  113. FUNCTION setcdr(list,newcdr:objp):objp;
  114.   BEGIN
  115.     IF list^.typ<>3 THEN
  116.         error('setcdrs argument is no pair: '+outlist(list))
  117.       ELSE BEGIN
  118.         list^.o.cdr:=newcdr;
  119.         setcdr:=list;
  120.       END;
  121.   END;
  122.  
  123. FUNCTION make_number(a:INTEGER):objp;
  124.   VAR o:objp;
  125.   BEGIN
  126.     New(o);
  127.     o^.typ:=0; o^.i:=a; make_number:=o;
  128.   END;
  129.