Add c-stdio library

Makefile

@@ -51,7 +51,7 @@ init-venv: build
 
 run-test: init-venv
 	if [ "${RNRS}" = "r6rs" ]; then ./venv/bin/scheme-compile venv/test.sps; fi
-	if [ "${RNRS}" = "r7rs" ]; then VENV_CSC_ARGS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
+	if [ "${RNRS}" = "r7rs" ]; then CSC_OPTIONS="-L -lcurl" ./venv/bin/scheme-compile venv/test.scm; fi
 	./venv/test
 
 test-r7rs:

retropikzel/c-stdio.scm

@@ -0,0 +1,22 @@
+(define-c-library libc '("stdio.h") #f '())
+(define-c-procedure fopen libc 'fopen 'pointer '(pointer pointer))
+(define-c-procedure fclose libc 'fclose 'int '(pointer))
+(define-c-procedure feof 'feof 'int '(pointer))
+(define-c-procedure ferror 'ferror 'int '(pointer))
+(define-c-procedure fgetc 'fgetc 'int '(pointer))
+(define-c-procedure fgetcs 'fgetcs 'pointer '(pointer int pointer))
+(define-c-procedure fputc 'fputc 'int '(int pointer))
+(define-c-procedure fputs 'fputs 'int '(pointer pointer))
+(define-c-procedure fread 'fread 'int '(pointer int int pointer))
+(define-c-procedure fseek 'fseek 'int '(pointer long int))
+(define-c-procedure ftell 'ftell 'long '(pointer))
+(define-c-procedure fwrite 'fwrite 'int '(pointer int int pointer))
+(define-c-procedure getc 'fwrite 'int '(pointer))
+(define-c-procedure getchar 'getchar 'int '())
+(define-c-procedure putc 'putc 'int '(int pointer))
+(define-c-procedure putchar 'putchar 'int '(int))
+(define-c-procedure puts 'puts 'int '(pointer))
+(define-c-procedure remove 'remove 'int '(pointer))
+(define-c-procedure rename 'rename 'int '(pointer pointer))
+(define-c-procedure rewind 'rewind 'int '(pointer))
+

retropikzel/c-stdio.sld

@@ -0,0 +1,35 @@
+(define-library
+  (retropikzel c-stdio)
+  (import (scheme base)
+          (scheme write)
+          (foreign c))
+  (export fopen
+          fclose
+          feof
+          ferror
+          fgetc
+          fgets
+          ;fprintf ;; TODO
+          fputc
+          fputs
+          fread
+          ;fscanf ;; TODO
+          fseek
+          ftell
+          fwrite
+          getc
+          getchar
+          ;printf ;; TODO
+          putc
+          putchar
+          puts
+          remove
+          rename
+          rewind
+          ;scanf ;; TODO
+          ;snprintf ;; TODO
+          ;sprintf ;; TODO
+          ;sscanf ;; TODO
+          )
+  (include "c-stdio.scm"))
+

retropikzel/c-stdio/README.md

@@ -0,0 +1,18 @@
+stdio.h bindings
+
+
+Does not have:
+    - fprintf
+        - (foreign c) has no way to pass variable number of arguments
+    - fscanf
+        - (foreign c) has no way to pass variable number of arguments
+    - printf
+        - (foreign c) has no way to pass variable number of arguments
+    - scanf
+        - (foreign c) has no way to pass variable number of arguments
+    - snprintf
+        - (foreign c) has no way to pass variable number of arguments
+    - sprintf
+        - (foreign c) has no way to pass variable number of arguments
+    - sscanf
+        - (foreign c) has no way to pass variable number of arguments

retropikzel/c-stdio/test.scm

@@ -0,0 +1,3 @@
+
+(test-begin "c-stdio")
+(test-end "c-stdio")

retropikzel/requests.scm

@@ -13,7 +13,7 @@
 (define CURLINFO-COOKIELIST 4194332)
 (define randomized? #f)
 
-(define-c-library libc '("stdlib.h" "stdio.h" "time.h") libc-name '((additional-versions ("6"))))
+(define-c-library libc '("stdlib.h" "stdio.h" "time.h") #f '())
 (define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
 (define-c-procedure c-fclose libc 'fclose 'int '(pointer))
 (define-c-procedure c-time libc 'time 'int '(pointer))
@@ -49,7 +49,7 @@
 
 (define (random-to max)
   (when (not randomized?)
-    (c-srand (c-time (make-c-null)))
+    (c-srand (c-time (c-bytevector-null)))
     (set! randomized? #t))
   (modulo (c-rand) max))
 
@@ -80,7 +80,7 @@
 (define handle-errors
   (lambda (result)
     (when (not (= result 0))
-      (error (c-utf8->string (curl-easy-strerror result))))
+      (error (c-bytevector->string (curl-easy-strerror result))))
     result))
 
 (define handle (curl-easy-init))
@@ -114,21 +114,21 @@
          (pointer (make-c-bytevector (c-type-size 'long))))
     (curl-easy-getinfo handle CURLINFO-RESPONSE-CODE pointer)
     (let ((code (c-bytevector-ref pointer 'int 0)))
-      (c-free pointer)
+      (c-bytevector-free pointer)
       code)))
 
 (define (set-body handle body)
-  (curl-easy-setopt-pointer handle CURLOPT-POSTFIELDS (string->c-utf8 body))
+  (curl-easy-setopt-pointer handle CURLOPT-POSTFIELDS (string->c-bytevector body))
   (curl-easy-setopt-int handle CURLOPT-POSTFIELDSIZE (string-length body)))
 
 (define (set-headers handle headers)
-  (let ((headers-slist (make-c-null)))
+  (let ((headers-slist (c-bytevector-null)))
     (for-each
       (lambda (header)
         (set! headers-slist
           (curl-slist-append
             headers-slist
-            (string->c-utf8 (string-append (if (symbol? (car header))
+            (string->c-bytevector (string-append (if (symbol? (car header))
                                              (symbol->string (car header))
                                              (car header))
                                            ":"
@@ -143,14 +143,14 @@
                                               CURLHE-HEADER
                                               0
                                               previous-header-struct)))
-    (if (c-null? header-struct)
+    (if (c-bytevector-null? header-struct)
       result
       (let* ((name
                (string->symbol
                  (string-downcase
-                   (c-utf8->string
+                   (c-bytevector->string
                      (c-bytevector-ref header-struct 'pointer 0)))))
-             (value (c-utf8->string (c-bytevector-ref header-struct
+             (value (c-bytevector->string (c-bytevector-ref header-struct
                                                       'pointer
                                                       (c-type-size 'pointer)))))
         (get-headers handle header-struct (append result
@@ -183,7 +183,7 @@
                            (cdr header))
                          "; ")))
       cookies)
-    (curl-easy-setopt-pointer handle CURLOPT-COOKIE (string->c-utf8 cookies-string))))
+    (curl-easy-setopt-pointer handle CURLOPT-COOKIE (string->c-bytevector cookies-string))))
 
 (define request
   (lambda (method url . options)
@@ -194,20 +194,20 @@
            (tmp-file-path (if download-path
                             (cdr download-path)
                             (random-temp-file)))
-           (tmp-file (c-fopen (string->c-utf8 tmp-file-path)
-                              (string->c-utf8 "w"))))
+           (tmp-file (c-fopen (string->c-bytevector tmp-file-path)
+                              (string->c-bytevector "w"))))
       (curl-easy-setopt-pointer handle
                                 CURLOPT-CUSTOMREQUEST
-                                (string->c-utf8
+                                (string->c-bytevector
                                   (string-upcase (symbol->string method))))
       (curl-easy-setopt-pointer handle CURLOPT-WRITEDATA tmp-file)
-      (curl-easy-setopt-pointer handle CURLOPT-URL (string->c-utf8 url))
+      (curl-easy-setopt-pointer handle CURLOPT-URL (string->c-bytevector url))
       (when headers (set-headers handle (cdr headers)))
       (when cookies (set-cookies handle (cdr cookies)))
       (when body (set-body handle (cdr body)))
       (handle-errors (curl-easy-perform handle))
       (c-fclose tmp-file)
-      (let* ((headers (get-headers handle (make-c-null) (list)))
+      (let* ((headers (get-headers handle (c-bytevector-null) (list)))
              (response (make-response (slurp-bytes tmp-file-path)
                                       ;(get-cookies handle)
                                       headers

retropikzel/shell.scm

@@ -1,17 +1,13 @@
-(define-c-library libc
-                  '("stdlib.h" "stdio.h" "unistd.h")
-                  libc-name
-                  '((additional-versions ("0" "6"))))
-
+(define-c-library libc '("stdlib.h" "stdio.h" "unistd.h") #f '())
 (define-c-procedure c-tempnam libc 'tempnam 'pointer '(pointer pointer))
-(define-c-procedure c-system libc 'system 'int '(pointer))
 
 (define previous-exit-code #f)
 
 (define (shell cmd)
-  (let* ((temp-prefix (string->c-utf8 "npcmd"))
+  (when (not (string? cmd)) (error "shell: cmd must be string" cmd))
+  (let* ((temp-prefix (string->c-bytevector "npcmd"))
          (temp-name (lambda ()
-                      (c-utf8->string (c-tempnam (make-c-null)
+                      (c-bytevector->string (c-tempnam (c-bytevector-null)
                                                  temp-prefix))))
          (input-path (temp-name))
          (shell-command (string-append cmd
@@ -21,7 +17,7 @@
                                        input-path
                                        " & ")))
     (create-pipe input-path 0777)
-    (set! previous-exit-code (c-system (string->c-utf8 shell-command)))
+    (set! previous-exit-code (system shell-command))
     (pipe-read-string 64000 (open-input-pipe input-path #t))))
 
 (define (lines->list port result)

retropikzel/shell.sld

@@ -5,6 +5,7 @@
           (scheme read)
           (scheme file)
           (foreign c)
+          (retropikzel system)
           (retropikzel named-pipes))
   (export shell
           shell->list

retropikzel/shell/test.scm

@@ -1,9 +1,3 @@
-(import (scheme base)
-        (scheme write)
-        (scheme file)
-        (scheme process-context)
-        (retropikzel shell)
-        (srfi 64))
 
 (test-begin "shell")
 

retropikzel/stdio.scm

@@ -1,29 +0,0 @@
-(define-c-library libc '("stdio.h") libc-name '((additional-versions ("0" "6"))))
-(define-c-procedure internal-fopen libc 'fopen 'pointer '(pointer poiner))
-(define-c-procedure internal-fclose libc 'fclose 'int '(pointer))
-
-(define-record-type <stdio-file>
-  (make-stdio-file file)
-  stdio-file?
-  (file stdio-file))
-
-(define modes `("r" "w" "a" "r+" "w+" "a+" "rb" "wb" "ab" "rb+" "wb+" "ab+"))
-
-(define (fopen filename mode)
-  (when (not (string? filename)) (error "fopen: Filename must be string"))
-  (when (not (string? mode)) (error "fopen: Mode must be string"))
-  (when (not (member mode modes))
-    (error (string-append "fopen: Mode not in allowed modes of "
-                          (apply (lambda (item) (string-append mode " "))
-                                 modes))))
-  (let* ((filename-pointer (string->c-utf8 filename))
-         (mode-pointer (string->c-utf8 mode))
-         (file (make-stdio-file (fopen filename mode))))
-    (c-free filename-pointer)
-    (c-free mode-pointer)
-    file))
-
-(define (fclose file)
-  (when (not (stdio-file? file)) (error "fclose: File must be stdio-file"))
-  (internal-fclose (stdio-file file)))
-

retropikzel/stdio.sld

@@ -1,35 +0,0 @@
-(define-library
-  (retropikzel stdio)
-  (import (scheme base)
-          (scheme write)
-          (foreign c))
-  (export fopen
-          fclose
-          ;feof
-          ;ferror
-          ;fgetc
-          ;fgets
-          ;fprintf
-          ;fputc
-          ;fputs
-          ;fread
-          ;fscanf
-          ;fseek
-          ;ftell
-          ;fwrite
-          ;getc
-          ;getchar
-          ;printf
-          ;putc
-          ;putchar
-          ;puts
-          ;remove
-          ;rename
-          ;rewind
-          ;scanf
-          ;snprintf
-          ;sprintf
-          ;sscanf
-          )
-  (include "stiod.scm"))
-

retropikzel/stdio/test.scm

@@ -1,3 +0,0 @@
-
-(test-begin "stdio")
-(test-end "stdio")

retropikzel/system/VERSION

@@ -1 +1 @@
-1.1.4
+1.1.5