Algol 68 Genie

genie-call.c

     
   1  //! @file genie-call.c
   2  //! @author J. Marcel van der Veer
   3  
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2026 J. Marcel van der Veer [algol68g@algol68genie.nl].
   8  
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Interpreter routines for procedure calls.
  25  
  26  // Algol 68 Genie implements Charles Lindsey's proposal for partial parametrization.
  27  // A procedure has a locale to store parameters until the pack is complete, and only
  28  // then the procedure is actually called.
  29  
  30  #include "a68g.h"
  31  #include "a68g-genie.h"
  32  #include "a68g-frames.h"
  33  #include "a68g-prelude.h"
  34  #include "a68g-transput.h"
  35  
  36  void genie_argument (NODE_T * p, NODE_T ** seq)
  37  {
  38    for (; p != NO_NODE; FORWARD (p)) {
  39      if (IS (p, UNIT)) {
  40        GENIE_UNIT_NO_GC (p);
  41        STACK_DNS (p, MOID (p), A68G_FP);
  42        SEQUENCE (*seq) = p;
  43        (*seq) = p;
  44        return;
  45      } else if (IS (p, TRIMMER)) {
  46        return;
  47      } else {
  48        genie_argument (SUB (p), seq);
  49      }
  50    }
  51  }
  52  
  53  //! @brief Evaluate partial call.
  54  
  55  void genie_partial_call (NODE_T * p, MOID_T * p_mode, MOID_T * pproc, MOID_T * pmap, A68G_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp)
  56  {
  57  // Get or make locale for the new procedure descriptor.
  58    A68G_REF ref; A68G_HANDLE *locale;
  59    if (LOCALE (&z) == NO_HANDLE) {
  60      size_t size = 0;
  61      for (PACK_T *s = PACK (p_mode); s != NO_PACK; FORWARD (s)) {
  62        size += (SIZE (M_BOOL) + SIZE (MOID (s)));
  63      }
  64      ref = heap_generator (p, p_mode, size);
  65      locale = REF_HANDLE (&ref);
  66    } else {
  67      size_t size = SIZE (LOCALE (&z));
  68      ref = heap_generator (p, p_mode, size);
  69      locale = REF_HANDLE (&ref);
  70      COPY (POINTER (locale), POINTER (LOCALE (&z)), size);
  71    }
  72  // Move arguments from stack to locale using pmap.
  73    BYTE_T *u = POINTER (locale), *v = STACK_ADDRESS (pop_sp);
  74  // Uninitialised arguments are VOID.
  75    int voids = 0;
  76    PACK_T *s = PACK (p_mode);
  77    for (PACK_T *t = PACK (pmap); t != NO_PACK && s != NO_PACK; FORWARD (t)) {
  78  // Skip already initialised arguments.
  79      while (u != NULL && VALUE ((A68G_BOOL *) & u[0])) {
  80        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
  81        FORWARD (s);
  82      }
  83      if (u != NULL && MOID (t) == M_VOID) {
  84  // Move to next field in locale.
  85        voids++;
  86        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
  87        FORWARD (s);
  88      } else {
  89  // Move argument from stack to locale.
  90        A68G_BOOL w;
  91        STATUS (&w) = INIT_MASK;
  92        VALUE (&w) = A68G_TRUE;
  93        *(A68G_BOOL *) & u[0] = w;
  94        COPY (&(u[SIZE (M_BOOL)]), v, SIZE (MOID (t)));
  95        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
  96        v = &(v[SIZE (MOID (t))]);
  97        FORWARD (s);
  98      }
  99    }
 100    A68G_SP = pop_sp;
 101    LOCALE (&z) = locale;
 102  // When closure is complete, push locale onto the stack and call procedure body.
 103    if (voids == 0) {
 104      A68G_SP = pop_sp;
 105      u = POINTER (locale);
 106      v = STACK_ADDRESS (A68G_SP);
 107      for (s = PACK (p_mode); s != NO_PACK; FORWARD (s)) {
 108        size_t size = SIZE (MOID (s));
 109        COPY (v, &u[SIZE (M_BOOL)], size);
 110        u = &(u[SIZE (M_BOOL) + size]);
 111        v = &(v[SIZE (MOID (s))]);
 112        INCREMENT_STACK_POINTER (p, size);
 113      }
 114      genie_call_procedure (p, p_mode, pproc, M_VOID, &z, pop_sp, pop_fp);
 115    } else {
 116  //  Closure is not complete. Return procedure body.
 117      PUSH_PROCEDURE (p, z);
 118    }
 119  }
 120  
 121  //! @brief Closure and deproceduring of routines with PARAMSETY.
 122  
 123  void genie_call_procedure (NODE_T * p, MOID_T * p_mode, MOID_T * pproc, MOID_T * pmap, A68G_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp)
 124  {
 125    if (pmap != M_VOID && p_mode != pmap) {
 126      genie_partial_call (p, p_mode, pproc, pmap, *z, pop_sp, pop_fp);
 127    } else if (STATUS (z) & STANDENV_PROC_MASK) {
 128      NODE_T *save = A68G (f_entry);
 129      A68G (f_entry) = p;
 130      (void) ((*(PROCEDURE (&(BODY (z))))) (p));
 131      A68G (f_entry) = save;
 132    } else if (STATUS (z) & SKIP_PROCEDURE_MASK) {
 133      A68G_SP = pop_sp;
 134      genie_push_undefined (p, SUB ((MOID (z))));
 135    } else {
 136      NODE_T *body = NODE (&(BODY (z)));
 137      if (IS (body, ROUTINE_TEXT)) {
 138        NODE_T *entry = SUB (body);
 139        ADDR_T fp0 = 0;
 140  // Copy arguments from stack to frame.
 141        OPEN_PROC_FRAME (entry, ENVIRON (z));
 142        INIT_STATIC_FRAME (entry);
 143        FRAME_DNS (A68G_FP) = pop_fp;
 144        for (PACK_T *args = PACK (p_mode); args != NO_PACK; FORWARD (args)) {
 145          size_t size = SIZE (MOID (args));
 146          COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size);
 147          fp0 += size;
 148        }
 149        A68G_SP = pop_sp;
 150        ARGSIZE (GINFO (p)) = fp0;
 151  // Interpret routine text.
 152        if (DIM (p_mode) > 0) {
 153  // With PARAMETERS.
 154          entry = NEXT (NEXT_NEXT (entry));
 155        } else {
 156  // Without PARAMETERS.
 157          entry = NEXT_NEXT (entry);
 158        }
 159        GENIE_UNIT_TRACE (entry);
 160        if (A68G_FP == A68G_MON (finish_frame_pointer)) {
 161          change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK, A68G_TRUE);
 162        }
 163        CLOSE_FRAME;
 164        STACK_DNS (p, SUB (p_mode), A68G_FP);
 165      } else {
 166        OPEN_PROC_FRAME (body, ENVIRON (z));
 167        INIT_STATIC_FRAME (body);
 168        FRAME_DNS (A68G_FP) = pop_fp;
 169        GENIE_UNIT_TRACE (body);
 170        if (A68G_FP == A68G_MON (finish_frame_pointer)) {
 171          change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK, A68G_TRUE);
 172        }
 173        CLOSE_FRAME;
 174        STACK_DNS (p, SUB (p_mode), A68G_FP);
 175      }
 176    }
 177  }
 178  
 179  //! @brief Call event routine.
 180  
 181  void genie_call_event_routine (NODE_T * p, MOID_T * m, A68G_PROCEDURE * proc, ADDR_T pop_sp, ADDR_T pop_fp)
 182  {
 183    if (NODE (&(BODY (proc))) != NO_NODE) {
 184      A68G_PROCEDURE save = *proc;
 185      set_default_event_procedure (proc);
 186      genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp);
 187      (*proc) = save;
 188    }
 189  }
 190  
 191  //! @brief Call PROC with arguments and push result.
 192  
 193  PROP_T genie_call_standenv_quick (NODE_T * p)
 194  {
 195    NODE_T *save = A68G (f_entry);
 196    A68G (f_entry) = p;
 197    NODE_T *pr = SUB (p);
 198    TAG_T *proc = TAX (SOURCE (&GPROP (pr)));
 199  // Get arguments.
 200    for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
 201      GENIE_UNIT_NO_GC (q);
 202      STACK_DNS (p, MOID (q), A68G_FP);
 203    }
 204    (void) ((*(PROCEDURE (proc))) (p));
 205    A68G (f_entry) = save;
 206    return GPROP (p);
 207  }
 208  
 209  //! @brief Call PROC with arguments and push result.
 210  
 211  PROP_T genie_call_quick (NODE_T * p)
 212  {
 213    ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
 214  // Get procedure.
 215    NODE_T *proc = SUB (p);
 216    GENIE_UNIT_NO_GC (proc);
 217    A68G_PROCEDURE z;
 218    POP_OBJECT (proc, &z, A68G_PROCEDURE);
 219    genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
 220  // Get arguments.
 221    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 222      NODE_T top_seq;
 223      GINFO_T g;
 224      NODE_T *seq = &top_seq;
 225      GINFO (seq) = &g;
 226      SEQUENCE (seq) = NO_NODE;
 227      genie_argument (NEXT (proc), &seq);
 228      SEQUENCE (p) = SEQUENCE (&top_seq);
 229      STATUS_SET (p, SEQUENCE_MASK);
 230    } else {
 231      for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
 232        GENIE_UNIT_NO_GC (q);
 233        STACK_DNS (p, MOID (q), A68G_FP);
 234      }
 235    }
 236    genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
 237    return GPROP (p);
 238  }
 239  
 240  //! @brief Call PROC with arguments and push result.
 241  
 242  PROP_T genie_call (NODE_T * p)
 243  {
 244    ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
 245    PROP_T self;
 246    UNIT (&self) = genie_call_quick;
 247    SOURCE (&self) = p;
 248  // Get procedure.
 249    NODE_T *proc = SUB (p);
 250    GENIE_UNIT_NO_GC (proc);
 251    A68G_PROCEDURE z;
 252    POP_OBJECT (proc, &z, A68G_PROCEDURE);
 253    genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
 254  // Get arguments.
 255    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 256      NODE_T top_seq;
 257      GINFO_T g;
 258      NODE_T *seq = &top_seq;
 259      GINFO (seq) = &g;
 260      SEQUENCE (seq) = NO_NODE;
 261      genie_argument (NEXT (proc), &seq);
 262      SEQUENCE (p) = SEQUENCE (&top_seq);
 263      STATUS_SET (p, SEQUENCE_MASK);
 264    } else {
 265      for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
 266        GENIE_UNIT_NO_GC (q);
 267      }
 268    }
 269    genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
 270    if (PARTIAL_LOCALE (GINFO (proc)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) {
 271      ;
 272    } else if (STATUS (&z) & STANDENV_PROC_MASK) {
 273      if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) {
 274        UNIT (&self) = genie_call_standenv_quick;
 275      }
 276    }
 277    return self;
 278  }