home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / cmpnew / cmpvs.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  5.1 KB  |  216 lines
  1.  
  2. /* (C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. */
  3. #include <cmpinclude.h>
  4. #include "cmpvs.h"
  5. init_cmpvs(start,size,data)char *start;int size;object data;
  6. {    register object *base=vs_top;register object *sup=base+VM2;vs_check;
  7.     Cstart=start;Csize=size;Cdata=data;set_VV(VV,VM1,data);
  8.     (void)(putprop(VV[0],VV[1],VV[2]));
  9.     (void)(putprop(VV[0],VV[3],VV[4]));
  10.     (void)(putprop(VV[5],VV[6],VV[4]));
  11.     (void)(putprop(VV[7],VV[8],VV[4]));
  12.     VV[10]->s.s_stype=(short)stp_special;
  13.     if(VV[10]->s.s_dbind == OBJNULL){
  14.     VV[10]->s.s_dbind = VV[9];}
  15.     VV[11]->s.s_stype=(short)stp_special;
  16.     if(VV[11]->s.s_dbind == OBJNULL){
  17.     VV[11]->s.s_dbind = VV[9];}
  18.     VV[12]->s.s_stype=(short)stp_special;
  19.     if(VV[12]->s.s_dbind == OBJNULL){
  20.     VV[12]->s.s_dbind = Cnil;}
  21.     VV[13]->s.s_stype=(short)stp_special;
  22.     if(VV[13]->s.s_dbind == OBJNULL){
  23.     VV[13]->s.s_dbind = VV[9];}
  24.     VV[14]->s.s_stype=(short)stp_special;
  25.     VV[15]->s.s_stype=(short)stp_special;
  26.     if(VV[15]->s.s_dbind == OBJNULL){
  27.     VV[15]->s.s_dbind = VV[9];}
  28.     MF(VV[18],L5,start,size,data);
  29.     MF(VV[1],L6,start,size,data);
  30.     MF(VV[3],L7,start,size,data);
  31.     MF(VV[6],L8,start,size,data);
  32.     MF(VV[8],L9,start,size,data);
  33.     MF(VV[19],L10,start,size,data);
  34.     MF(VV[20],L11,start,size,data);
  35.     MF(VV[21],L12,start,size,data);
  36.     vs_top=vs_base=base;
  37. }
  38. /*    function definition for VS-PUSH    */
  39.  
  40. static L5()
  41. {    register object *base=vs_base;
  42.     register object *sup=base+VM3;
  43.     vs_reserve(VM3);
  44.     check_arg(0);
  45.     vs_top=sup;
  46. TTL:;
  47.     base[0]= make_cons(symbol_value(VV[15]),symbol_value(VV[10]));
  48.     setq(VV[10],number_plus(symbol_value(VV[10]),VV[16]));
  49.     setq(VV[11],(number_compare(symbol_value(VV[10]),symbol_value(VV[11]))>=0?symbol_value(VV[10]):symbol_value(VV[11])));
  50.     vs_top=(vs_base=base+0)+1;
  51.     return;
  52. }
  53. /*    function definition for SET-VS    */
  54.  
  55. static L6()
  56. {    register object *base=vs_base;
  57.     register object *sup=base+VM4;
  58.     vs_reserve(VM4);
  59.     check_arg(2);
  60.     vs_top=sup;
  61. TTL:;
  62.     if(!(type_of(base[0])==t_cons)){
  63.     goto T15;}
  64.     if(!(car(base[0])==VV[0])){
  65.     goto T15;}
  66.     if(equal(cadr(base[0]),base[1])){
  67.     goto T16;}
  68. T15:;
  69.     princ_str("\n    ",VV[17]);
  70.     base[2]= base[1];
  71.     vs_top=(vs_base=base+2)+1;
  72.     L7();
  73.     vs_top=sup;
  74.     princ_str("= ",VV[17]);
  75.     base[2]= base[0];
  76.     (void)simple_symlispcall_no_event(VV[22],base+2,1);
  77.     princ_char(59,VV[17]);
  78.     base[2]= Cnil;
  79.     vs_top=(vs_base=base+2)+1;
  80.     return;
  81. T16:;
  82.     base[2]= Cnil;
  83.     vs_top=(vs_base=base+2)+1;
  84.     return;
  85. }
  86. /*    function definition for WT-VS    */
  87.  
  88. static L7()
  89. {    register object *base=vs_base;
  90.     register object *sup=base+VM5;
  91.     vs_reserve(VM5);
  92.     check_arg(1);
  93.     vs_top=sup;
  94. TTL:;
  95.     if(!(number_compare(car(base[0]),symbol_value(VV[15]))==0)){
  96.     goto T30;}
  97.     princ_str("base[",VV[17]);
  98.     base[1]= cdr(base[0]);
  99.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  100.     princ_char(93,VV[17]);
  101.     base[1]= Cnil;
  102.     vs_top=(vs_base=base+1)+1;
  103.     return;
  104. T30:;
  105.     princ_str("base",VV[17]);
  106.     base[1]= car(base[0]);
  107.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  108.     princ_char(91,VV[17]);
  109.     base[1]= cdr(base[0]);
  110.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  111.     princ_char(93,VV[17]);
  112.     base[1]= Cnil;
  113.     vs_top=(vs_base=base+1)+1;
  114.     return;
  115. }
  116. /*    function definition for WT-VS*    */
  117.  
  118. static L8()
  119. {    register object *base=vs_base;
  120.     register object *sup=base+VM6;
  121.     vs_reserve(VM6);
  122.     check_arg(1);
  123.     vs_top=sup;
  124. TTL:;
  125.     if(!(number_compare(car(base[0]),symbol_value(VV[15]))==0)){
  126.     goto T44;}
  127.     princ_str("(base[",VV[17]);
  128.     base[1]= cdr(base[0]);
  129.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  130.     princ_str("]->c.c_car)",VV[17]);
  131.     base[1]= Cnil;
  132.     vs_top=(vs_base=base+1)+1;
  133.     return;
  134. T44:;
  135.     princ_str("(base",VV[17]);
  136.     base[1]= car(base[0]);
  137.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  138.     princ_char(91,VV[17]);
  139.     base[1]= cdr(base[0]);
  140.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  141.     princ_str("]->c.c_car)",VV[17]);
  142.     base[1]= Cnil;
  143.     vs_top=(vs_base=base+1)+1;
  144.     return;
  145. }
  146. /*    function definition for WT-CCB-VS    */
  147.  
  148. static L9()
  149. {    register object *base=vs_base;
  150.     register object *sup=base+VM7;
  151.     vs_reserve(VM7);
  152.     check_arg(1);
  153.     vs_top=sup;
  154. TTL:;
  155.     princ_str("(base0[",VV[17]);
  156.     base[1]= number_minus(symbol_value(VV[14]),base[0]);
  157.     (void)simple_symlispcall_no_event(VV[22],base+1,1);
  158.     princ_str("]->c.c_car)",VV[17]);
  159.     base[1]= Cnil;
  160.     vs_top=(vs_base=base+1)+1;
  161.     return;
  162. }
  163. /*    function definition for CLINK    */
  164.  
  165. static L10()
  166. {    register object *base=vs_base;
  167.     register object *sup=base+VM8;
  168.     vs_reserve(VM8);
  169.     check_arg(1);
  170.     vs_top=sup;
  171. TTL:;
  172.     setq(VV[12],base[0]);
  173.     base[1]= symbol_value(VV[12]);
  174.     vs_top=(vs_base=base+1)+1;
  175.     return;
  176. }
  177. /*    function definition for WT-CLINK    */
  178.  
  179. static L11()
  180. {    register object *base=vs_base;
  181.     register object *sup=base+VM9;
  182.     vs_reserve(VM9);
  183.     if(vs_top-vs_base>1) too_many_arguments();
  184.     if(vs_base>=vs_top){vs_top=sup;goto T62;}
  185.     vs_top=sup;
  186.     goto T63;
  187. T62:;
  188.     base[0]= symbol_value(VV[12]);
  189. T63:;
  190.     if((base[0])!=Cnil){
  191.     goto T66;}
  192.     princ_str("Cnil",VV[17]);
  193.     base[1]= Cnil;
  194.     vs_top=(vs_base=base+1)+1;
  195.     return;
  196. T66:;
  197.     base[1]= base[0];
  198.     vs_top=(vs_base=base+1)+1;
  199.     L7();
  200.     return;
  201. }
  202. /*    function definition for CCB-VS-PUSH    */
  203.  
  204. static L12()
  205. {    register object *base=vs_base;
  206.     register object *sup=base+VM10;
  207.     vs_reserve(VM10);
  208.     check_arg(0);
  209.     vs_top=sup;
  210. TTL:;
  211.     setq(VV[13],number_plus(symbol_value(VV[13]),VV[16]));
  212.     base[0]= symbol_value(VV[13]);
  213.     vs_top=(vs_base=base+0)+1;
  214.     return;
  215. }
  216.