.gitignore

@@ -4,4 +4,5 @@
 /vecfun
 /btree
 /game-of-life
+/prime-sum
 /compile_commands.json

Makefile

@@ -4,7 +4,7 @@ CC=gcc
 FORMAT=clang-format -i
 PRESCHEME=prescheme
 
-CFLAGS=-g -Wall
+CFLAGS=-O2 -g -Wall
 CFLAGS+=$(shell pkg-config --cflags prescheme)
 LDLIBS+=$(shell pkg-config --libs prescheme)
 
@@ -23,7 +23,8 @@ TARGETS= hello \
          vecfun \
          recfun \
          btree \
-         game-of-life
+         game-of-life \
+         prime-sum
 
 all: $(TARGETS)
 
@@ -47,6 +48,7 @@ all: $(TARGETS)
 	  echo " '(copy (ps-vector vector-for-each1))"; \
 	  echo " '(copy (ps-vector vector-for-each2))"; \
 	  echo " '(copy (ps-vector vector-for-each3))"; \
+	  echo " '(copy (ps-vector vector-fill!))"; \
 	  echo ")"; \
 	  echo ",exit" ) \
 	| $(PRESCHEME)

README.org

@@ -22,6 +22,7 @@ https://groups.scheme.org/prescheme/1.3/
 - recfun.scm - Simple demonstration of records (structs)
 - btree.scm - Example of a recursive record type
 - game-of-life.scm - Conway's Game of Life in Pre-Scheme with SDL2
+- prime-sum.scm - Sum of primes using Sieve of Eratosthenes
 
 The generated C for each of the demo programs is also included, so you
 can review the code generation without needing to build anything.

lib/ps-vector.scm

@@ -31,7 +31,7 @@
           result
           (begin
             (vector-set! result i (proc i))
-            (loop (+ i 1)))))))
+            (goto loop (+ i 1)))))))
 
 (define (vector-unfold1 proc len seed)
   (let ((result (receive (val next)
@@ -43,7 +43,7 @@
           (receive (val next)
               (proc i seed)
             (vector-set! result i val)
-            (loop (+ i 1) next))))))
+            (goto loop (+ i 1) next))))))
 
 (define (vector-unfold2 proc len seed1 seed2)
   (let ((result (receive (val next1 next2)
@@ -55,7 +55,7 @@
           (receive (val next1 next2)
               (proc i seed1 seed2)
             (vector-set! result i val)
-            (loop (+ i 1) next1 next2))))))
+            (goto loop (+ i 1) next1 next2))))))
 
 (define (vector-unfold3 proc len seed1 seed2 seed3)
   (let ((result (receive (val next1 next2 next3)
@@ -67,7 +67,7 @@
           (receive (val next1 next2 next3)
               (proc i seed1 seed2 seed3)
             (vector-set! result i val)
-            (loop (+ i 1) next1 next2 next3))))))
+            (goto loop (+ i 1) next1 next2 next3))))))
 
 ;;; vector-fold
 
@@ -84,14 +84,14 @@
   (let loop ((i 0) (result init))
     (if (= i len)
         result
-        (loop (+ i 1) (proc i result (vector-ref vec i))))))
+        (goto loop (+ i 1) (proc i result (vector-ref vec i))))))
 
 (define (vector-fold2 proc init vec1 len1 vec2 len2)
   (let ((len (min len1 len2)))
     (let loop ((i 0) (result init))
       (if (= i len)
           result
-          (loop (+ i 1) (proc i result
+          (goto loop (+ i 1) (proc i result
                               (vector-ref vec1 i)
                               (vector-ref vec2 i)))))))
 
@@ -100,7 +100,7 @@
     (let loop ((i 0) (result init))
       (if (= i len)
           result
-          (loop (+ i 1) (proc i result
+          (goto loop (+ i 1) (proc i result
                               (vector-ref vec1 i)
                               (vector-ref vec2 i)
                               (vector-ref vec3 i)))))))
@@ -202,3 +202,13 @@
                  (proc i val1 val2 val3)
                  res)
                (unspecific) vec1 len1 vec2 len2 vec3 len3))
+
+;;; vector-fill!
+
+(define (vector-fill! vec fill start end)
+  (let loop ((i 0))
+    (if (= i end)
+        (unspecific)
+        (begin
+          (vector-set! vec i fill)
+          (goto loop (+ i 1))))))

manifest.scm

@@ -13,6 +13,7 @@
              (gnu packages pkg-config)
              (gnu packages scheme)
              (gnu packages sdl)
+             (gnu packages texinfo)
              (ice-9 popen)
              (ice-9 textual-ports))
 
@@ -31,7 +32,7 @@
    (native-search-paths
     (list (search-path-specification
            (variable "SCHEME48_LOAD_PATH")
-           (files '("share/s48-r7rs-0.1")))))
+           (files '("share/scheme48-r7rs-0.1")))))
    (home-page "https://codeberg.org/prescheme/s48-r7rs")
    (synopsis "Incomplete R7RS implementation for Scheme 48")
    (description
@@ -53,7 +54,7 @@ top of the venerable Scheme 48, providing:
    (inputs
     (list scheme48-r7rs))
    (native-inputs
-    (list autoconf-2.69 automake libtool))
+    (list autoconf-2.69 automake libtool texinfo))
    (home-page "https://prescheme.org")
    (synopsis "Pre-Scheme compiler from Scheme 48, ported to R7RS")
    (description
@@ -63,7 +64,8 @@ to run on R7RS Scheme implementations, and runs on top of the Scheme 48 R7RS com
    (license license:bsd-3)))
 
 (packages->manifest
- (list scheme48-prescheme
+ (list scheme48-r7rs
+       scheme48-prescheme
        gcc-toolchain
        gnu-make
        pkg-config

packages.scm

@@ -23,7 +23,8 @@
           (vector-fold :syntax) vector-fold1 vector-fold2 vector-fold3
           (vector-map! :syntax) vector-map1! vector-map2! vector-map3!
           (vector-map :syntax) vector-map1 vector-map2 vector-map3
-          (vector-for-each :syntax) vector-for-each1 vector-for-each2 vector-for-each3)
+          (vector-for-each :syntax) vector-for-each1 vector-for-each2 vector-for-each3
+          vector-fill!)
   (open prescheme
         ps-receive)
   (files (lib ps-vector)))
@@ -99,3 +100,9 @@
         ps-sdl2
         ps-grid)
   (files game-of-life))
+
+(define-structure prime-sum (export main sum-of-primes)
+  (open prescheme
+        ps-utils
+        ps-vector)
+  (files prime-sum))

prime-sum.c

@@ -0,0 +1,134 @@
+#include "include/ps-init.h"
+#include "prescheme.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+long sum_of_primes(long);
+long main(long, char **);
+
+long sum_of_primes(long limit_0X) {
+  long arg0K1;
+  long arg0K0;
+  long v_8X;
+  long j_7X;
+  long result_6X;
+  long i_5X;
+  long j_4X;
+  long i_3X;
+  long i_2X;
+  char *sieve_1X;
+  {
+    if ((limit_0X < 2)) {
+      return 0;
+    } else {
+      sieve_1X = (char *)malloc(sizeof(char) * (1 + limit_0X));
+      arg0K0 = 0;
+      goto L166;
+    }
+  }
+L166 : {
+  i_2X = arg0K0;
+  if ((i_2X == (1 + limit_0X))) {
+    *(sieve_1X + 0) = 0;
+    *(sieve_1X + 1) = 0;
+    arg0K0 = 2;
+    goto L106;
+  } else {
+    *(sieve_1X + i_2X) = 1;
+    arg0K0 = (1 + i_2X);
+    goto L166;
+  }
+}
+L106 : {
+  i_3X = arg0K0;
+  j_4X = i_3X * i_3X;
+  if ((limit_0X < j_4X)) {
+    arg0K0 = 0;
+    arg0K1 = 0;
+    goto L260;
+  } else {
+    if ((*(sieve_1X + i_3X))) {
+      arg0K0 = j_4X;
+      goto L120;
+    } else {
+      goto L136;
+    }
+  }
+}
+L260 : {
+  i_5X = arg0K0;
+  result_6X = arg0K1;
+  if ((i_5X == (1 + limit_0X))) {
+    free(sieve_1X);
+    return result_6X;
+  } else {
+    if ((*(sieve_1X + i_5X))) {
+      arg0K0 = (result_6X + i_5X);
+      goto L270;
+    } else {
+      arg0K0 = result_6X;
+      goto L270;
+    }
+  }
+}
+L120 : {
+  j_7X = arg0K0;
+  if ((limit_0X < j_7X)) {
+    goto L136;
+  } else {
+    *(sieve_1X + j_7X) = 0;
+    arg0K0 = (j_7X + i_3X);
+    goto L120;
+  }
+}
+L136 : {
+  arg0K0 = (1 + i_3X);
+  goto L106;
+}
+L270 : {
+  v_8X = arg0K0;
+  arg0K0 = (1 + i_5X);
+  arg0K1 = v_8X;
+  goto L260;
+}
+}
+long main(long argc_9X, char **argv_10X) {
+  long result_15X;
+  long v_14X;
+  long limit_13X;
+  FILE *err_12X;
+  FILE *out_11X;
+  {
+    out_11X = stdout;
+    err_12X = stderr;
+    if ((2 == argc_9X)) {
+      limit_13X = atol((*(argv_10X + 1)));
+      if ((limit_13X < 0)) {
+        ps_write_string("Limit must be non-negative", err_12X);
+        PS_WRITE_CHAR(10, err_12X, v_14X)
+        return v_14X;
+      } else {
+        result_15X = sum_of_primes(limit_13X);
+        ps_write_string("Sum of primes up to ", out_11X);
+        ps_write_integer(limit_13X, out_11X);
+        ps_write_string(" is ", out_11X);
+        ps_write_integer(result_15X, out_11X);
+        {
+          long ignoreXX;
+          PS_WRITE_CHAR(10, out_11X, ignoreXX)
+        }
+        return 0;
+      }
+    } else {
+      ps_write_string("usage: ", err_12X);
+      ps_write_string((*(argv_10X + 0)), err_12X);
+      ps_write_string(" <limit>", err_12X);
+      {
+        long ignoreXX;
+        PS_WRITE_CHAR(10, err_12X, ignoreXX)
+      }
+      return 1;
+    }
+  }
+}

prime-sum.scm

@@ -0,0 +1,51 @@
+;;; prime-sum --- Sieve of Eratosthenes in Pre-Scheme
+
+(define string->number
+  (external "atol" (=> ((^ char)) integer)))
+
+(define (sum-of-primes limit)
+  (if (< limit 2)
+      0
+      (let ((sieve (make-vector (+ limit 1) #t)))
+        (vector-fill! sieve #t 0 (+ limit 1))
+        (vector-set! sieve 0 #f)
+        (vector-set! sieve 1 #f)
+        (let loop1 ((i 2))
+          (let ((j (* i i)))
+            (unless (> j limit)
+              (when (vector-ref sieve i)
+                (let loop2 ((j j))
+                  (unless (> j limit)
+                    (vector-set! sieve j #f)
+                    (goto loop2 (+ j i)))))
+              (goto loop1 (+ i 1)))))
+        (let ((result (vector-fold (lambda (x result prime?)
+                                     (if prime?
+                                         (+ result x)
+                                         result))
+                                   0 sieve (+ limit 1))))
+          (deallocate sieve)
+          result))))
+
+(define (main argc argv)
+  (define out (current-output-port))
+  (define err (current-error-port))
+  (cond ((not (= argc 2))
+         (write-string "usage: " err)
+         (write-string (vector-ref argv 0) err)
+         (write-string " <limit>" err)
+         (newline err)
+         1)
+        (else
+         (let ((limit (string->number (vector-ref argv 1))))
+           (cond ((< limit 0)
+                  (write-string "Limit must be non-negative" err)
+                  (newline err))
+                 (else
+                  (let ((result (sum-of-primes limit)))
+                    (write-string "Sum of primes up to " out)
+                    (write-integer limit out)
+                    (write-string " is " out)
+                    (write-integer result out)
+                    (newline out)
+                    0)))))))

vecfun.c

@@ -58,16 +58,16 @@ long main(void) {
     out_3X = stdout;
     ps_write_string("Print vec-a with vector-for-each:\n", out_3X);
     arg0K0 = 0;
-    goto L401;
+    goto L402;
   }
-L401 : {
+L402 : {
   i_4X = arg0K0;
   if ((5 == i_4X)) {
     ps_write_string("Print the last value of vec-a with vector-fold:\n",
                     out_3X);
     arg0K0 = 0;
     arg0K1 = -1;
-    goto L418;
+    goto L419;
   } else {
     val_5X = *(Qvec_a + i_4X);
     ps_write_string(" vec-a[", out_3X);
@@ -79,10 +79,10 @@ L401 : {
       PS_WRITE_CHAR(10, out_3X, ignoreXX)
     }
     arg0K0 = (1 + i_4X);
-    goto L401;
+    goto L402;
   }
 }
-L418 : {
+L419 : {
   i_6X = arg0K0;
   result_7X = arg0K1;
   if ((5 == i_6X)) {
@@ -106,19 +106,19 @@ L418 : {
     v_8X = procD00_return_value;
     arg0K0 = 0;
     arg3K1 = ((long *)malloc(sizeof(long) * 5));
-    goto L442;
+    goto L443;
   } else {
     arg0K0 = (1 + i_6X);
     arg0K1 = (*(Qvec_a + i_6X));
-    goto L418;
+    goto L419;
   }
 }
-L442 : {
+L443 : {
   i_9X = arg0K0;
   result_10X = arg3K1;
   if ((5 == i_9X)) {
     arg0K0 = 0;
-    goto L468;
+    goto L469;
   } else {
     merged_arg0K0 = (*(Qvec_a + i_9X));
     merged_arg0K1 = (*(Qvec_a + i_9X));
@@ -133,10 +133,10 @@ L442 : {
     *(result_10X + i_9X) = v_11X;
     arg0K0 = (1 + i_9X);
     arg3K1 = result_10X;
-    goto L442;
+    goto L443;
   }
 }
-L468 : {
+L469 : {
   i_12X = arg0K0;
   if ((5 == i_12X)) {
     free(result_10X);
@@ -152,7 +152,7 @@ L468 : {
     v_13X = procD10_return_value;
     arg0K0 = 0;
     arg2K1 = ((char **)malloc(sizeof(char *) * 5));
-    goto L486;
+    goto L487;
   } else {
     val_14X = *(result_10X + i_12X);
     ps_write_string(" sums[", out_3X);
@@ -164,15 +164,15 @@ L468 : {
       PS_WRITE_CHAR(10, out_3X, ignoreXX)
     }
     arg0K0 = (1 + i_12X);
-    goto L468;
+    goto L469;
   }
 }
-L486 : {
+L487 : {
   i_15X = arg0K0;
   result_16X = arg2K1;
   if ((5 == i_15X)) {
     arg0K0 = 0;
-    goto L504;
+    goto L505;
   } else {
     merged_arg0K0 = (*(Qvec_a + i_15X));
 #ifdef USE_DIRECT_THREADING
@@ -186,14 +186,14 @@ L486 : {
     *(result_16X + i_15X) = v_17X;
     arg0K0 = (1 + i_15X);
     arg2K1 = result_16X;
-    goto L486;
+    goto L487;
   }
 }
-L504 : {
+L505 : {
   i_18X = arg0K0;
   if ((5 == i_18X)) {
     arg0K0 = 0;
-    goto L520;
+    goto L521;
   } else {
     val_19X = *(result_16X + i_18X);
     ps_write_string(" strs[", out_3X);
@@ -209,10 +209,10 @@ L504 : {
       PS_WRITE_CHAR(10, out_3X, ignoreXX)
     }
     arg0K0 = (1 + i_18X);
-    goto L504;
+    goto L505;
   }
 }
-L520 : {
+L521 : {
   i_20X = arg0K0;
   if ((5 == i_20X)) {
     free(result_16X);
@@ -220,7 +220,7 @@ L520 : {
   } else {
     free((*(result_16X + i_20X)));
     arg0K0 = (1 + i_20X);
-    goto L520;
+    goto L521;
   }
 }
 procD1 : {
@@ -230,9 +230,9 @@ procD1 : {
     total_22X = len_21X * val_2X;
     target_23X = (char *)calloc(1, 1 + total_22X);
     arg0K0 = 0;
-    goto L108;
+    goto L109;
   }
-L108 : {
+L109 : {
   ix_24X = arg0K0;
   if ((ix_24X == total_22X)) {
     procD10_return_value = target_23X;
@@ -244,20 +244,20 @@ L108 : {
   } else {
     arg0K0 = ix_24X;
     arg0K1 = 0;
-    goto L41;
+    goto L42;
   }
 }
-L41 : {
+L42 : {
   tgt_25X = arg0K0;
   src_26X = arg0K1;
   if ((src_26X == len_21X)) {
     arg0K0 = (ix_24X + len_21X);
-    goto L108;
+    goto L109;
   } else {
     *(target_23X + tgt_25X) = (*("x" + src_26X));
     arg0K0 = (1 + tgt_25X);
     arg0K1 = (1 + src_26X);
-    goto L41;
+    goto L42;
   }
 }
 #ifndef USE_DIRECT_THREADING