adds more primus lisp stubs and fixes some existing (#1337)

Author: ivg

plugins/api/api/c/posix.h

@@ -21,6 +21,7 @@ long          a64l(const char *)
 void          abort(void) __attribute__((noreturn));
 int           abs(int x) __attribute__((__const__, warn_unused_result));
 int           atexit(void (*callback)(void)) __attribute__((nonnull(1)));
+int           __cxa_atexit(void (*callback)(void)) __attribute__((nonnull(1)));
 double        atof(const char *)  __attribute__((pure, nonnull(1), warn_unused_result));
 int           atoi(const char *)  __attribute__((pure, nonnull(1), warn_unused_result));
 long          atol(const char *)  __attribute__((pure, nonnull(1), warn_unused_result));
@@ -117,25 +118,39 @@ int feof(FILE *stream) __attribute__((warn_unused_result));
 int ferror(FILE *stream) __attribute__((warn_unused_result));
 int fgetc(FILE *stream);
 int fgetc(FILE *stream);
+int fgetc_unlocked(FILE *stream);
+int fgetc_unlocked(FILE *stream);
 int fileno(FILE *stream) __attribute__((warn_unused_result));
 int fputc(int c, FILE *stream);
 int fputs(const char *s, FILE *stream);
+int fputc_unlocked(int c, FILE *stream);
+int fputs_unlocked(const char *s, FILE *stream);
 int getc(FILE *stream);
+int getc_unlocked(FILE *stream);
 int getchar(void);
 int putchar(int c);
+int getchar_unlocked(void);
+int putchar_unlocked(int c);
 int putc(int c, FILE *stream);
 int puts(const char *s);
+int putc_unlocked(int c, FILE *stream);
+int puts_unlocked(const char *s);
 int remove(const char *);
 int rename(const char *, const char *);
 int ungetc(int c, FILE *stream);
 
 size_t fread(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream)
     __attribute__((warn_unused_result, storage(1,2,3)));
+size_t fread_unlocked(void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream)
+    __attribute__((warn_unused_result, storage(1,2,3)));
 size_t fwrite(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream)
     __attribute__((warn_unused_result, storage(1,2,3)));
+size_t fwrite_unlocked(const void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream)
+    __attribute__((warn_unused_result, storage(1,2,3)));
 void clearerr(FILE *stream);
 
 int fflush(FILE *stream);
+int fflush_unlocked(FILE *stream);
 
 int __isoc99_fscanf (FILE *__restrict __stream, const char *__restrict __format, ...)  __attribute__((warn_unused_result));
 int __isoc99_scanf (const char *__restrict __format, ...)  __attribute__((warn_unused_result));
@@ -354,13 +369,22 @@ int          gethostname(char *buf, size_t len) __attribute__((nonnull(1), stora
 char        *getlogin(void) __attribute__((warn_unused_result));
 int          getlogin_r(char *buf, size_t size) __attribute__((warn_unused_result, nonnull(1), storage(1,2)));
 int          getopt(int argc, char * const *argv, const char *shortopts);
+int getopt_long(int argc, char * const argv[],
+                const char *optstring,
+                const struct option *longopts, int *longindex);
+
+int getopt_long_only(int argc, char * const argv[],
+                     const char *optstring,
+                     const struct option *longopts, int *longindex);
 pid_t        getpgid(pid_t pid) __attribute__((warn_unused_result));
 pid_t        getpgrp(void) __attribute__((warn_unused_result));
 pid_t        getpid(void) __attribute__((warn_unused_result));
 pid_t        getppid(void) __attribute__((warn_unused_result));
 pid_t        getsid(pid_t pid) __attribute__((warn_unused_result));
 uid_t        getuid(void) __attribute__((warn_unused_result));
 int          isatty(int fd);
+int          ioctl(int fd, unsigned long request, ...);
+int          getpagesize(void);
 int          lchown(const char *file, uid_t owner, gid_t group) __attribute__((warn_unused_result,nonnull(1)));
 int          link(const char *from, const char *to) __attribute__((warn_unused_result,nonnull(1,2)));
 int          linkat(int fromfd, const char *from, int tofd, const char *to, int flags) __attribute__((warn_unused_result,nonnull(2,4)));
@@ -448,3 +472,25 @@ int isblank(int c);
 
 int toupper(int c);
 int tolower(int c);
+
+
+// locale.h
+
+char *setlocale(int category, const char *locale);
+struct lconv *localeconv(void);
+
+// #include <libintl.h>
+char * bindtextdomain (const char * domainname, const char * dirname);
+char * textdomain (const char * domainname);
+
+// #include <setjmp.h>
+typedef void * jmp_buf;
+typedef void * sigjmp_buf;
+int setjmp(jmp_buf env);
+int sigsetjmp(sigjmp_buf env, int savesigs);
+void longjmp(jmp_buf env, int val);
+void siglongjmp(sigjmp_buf env, int val);
+int _setjmp(jmp_buf env);
+int _sigsetjmp(sigjmp_buf env, int savesigs);
+void _longjmp(jmp_buf env, int val);
+void _siglongjmp(sigjmp_buf env, int val);

plugins/primus_lisp/primus_lisp_io.ml

@@ -18,7 +18,7 @@ type state = {
 let default_channels = Int.Map.of_alist_exn [
     0, {
       input = Some In_channel.stdin;
-      output = None;
+      output = Some Out_channel.stdout;
     };
     1, {
       input = None;

plugins/primus_lisp/site-lisp/getopt.lisp

@@ -1,23 +1,21 @@
-(require type)
-(require array)
-(require strstr)
+(require types)
+(require pointers)
 
 (in-package posix)
 (declare (visibility :private))
 
-
-(declare (global (optind opterr optopt optarg)))
+(declare (global optind opterr optopt optarg last-ofs))
 
 (defun getopt-arg (argv)
   (array-get ptr_t argv optind))
 
 (defun getopt-arg-char (argv n)
-  (array-get byte (getopt-arg argv) n))
+  (array-get char (getopt-arg argv) n))
 
 (defun points-to-dash (p)
-  (points-to char_t p ?-))
+  (points-to char p ?-))
 (defun points-to-colon (p)
-  (points-to char_t p ?:))
+  (points-to char p ?:))
 
 (defun getopt-finished (argc argv)
   (or (> optind argc)
@@ -27,8 +25,8 @@
 
 (defun getopt-nearly-finished (argv)
   (let ((p (getopt-arg argv)))
-    (and (points-to-dash (ptr+ p 1))
-         (points-to-null (ptr+ p 2)))))
+    (and (points-to-dash (ptr+ char p 1))
+         (points-to-null (ptr+ char p 2)))))
 
 (defun getopt-update-optopt (argv last-ofs)
   (set optopt (getopt-arg-char argv (+1 last-ofs))))
@@ -37,15 +35,15 @@
   (set optarg (array-get ptr_t argv (+1 optind))))
 
 (defun getopt-found (argv p last-ofs)
-  (or (points-to-colon (ptr+ 2 p))
+  (or (points-to-colon (ptr+ char 2 p))
       (getopt-arg-char argv (+ 2 last-ofs))))
 
 (defun getopt-reset-optarg-if-needed (argv last-ofs)
   (when (points-to-null (getopt-arg-char argv (+ 2 last-ofs)))
     (set optarg 0)))
 
 (defun getopt-expects-argument (p)
-  (points-to-colon (ptr+ 1 p)))
+  (points-to-colon (ptr+ char 1 p)))
 
 (defun getopt-missing-argument ())
 
@@ -56,22 +54,21 @@
   ?:)
 
 (defun getopt-with-argument (argv opts p last-ofs)
-  (if (getopt-found argv p last-ofs)
+  (when (getopt-found argv p last-ofs)
     (getopt-reset-optarg-if-needed argv last-ofs))
-  (prog
-   (getopt-update-optarg argv)
-   (when (is-zero optarg)
-     (getopt-no-argument argv opts))
-   (incr optind)))
+  (getopt-update-optarg argv)
+  (when (is-zero optarg)
+    (getopt-no-argument argv opts))
+  (incr optind))
 
 (defun getopt (argc argv opts)
   (declare
    (visibility :public)
    (external "getopt"))
   (when (= 0 optind)
     (set optind 1)
-    (set lastidx 0))
-  (if (getopt-finished) -1
+    (set last-ofs 0))
+  (if (getopt-finished argc argv) -1
     (if (getopt-nearly-finished argv)
         (prog (incr optind) -1)
       (let ((p 0) )
@@ -84,7 +81,12 @@
              (if (getopt-expects-argument p)
                  (getopt-with-argument argv opts p last-ofs)
                (prog (incr last-ofs) optopt)))
-          (prog
-           (getopt-unknown-option)
-           (incr opting)
-           ??))))))
+           (incr optind)
+           ??)))))
+
+
+(defun getopt_long (argc argv opts _ _)
+  (declare
+   (visibility :public)
+   (external "getopt_long" "getopt_long_only"))
+  (getopt argc argv opts))

plugins/primus_lisp/site-lisp/libintl.lisp

@@ -0,0 +1,9 @@
+(in-package posix)
+
+(defun bindtextdomain (_ dir)
+  (declare (external "bindtextdomain"))
+  dir)
+
+(defun textdomain (dom)
+  (declare (external "textdomain"))
+  dom)

plugins/primus_lisp/site-lisp/locale.lisp

@@ -0,0 +1,19 @@
+(in-package posix)
+
+(require types)
+
+(defparameter *lconv-size* (* 20 (sizeof ptr_t)))
+
+(declare (static LCONV))
+
+(defmethod init ()
+  (set LCONV brk)
+  (+= brk *lconv-size*))
+
+(defun setlocale (_ locale)
+  (declare (external "setlocale"))
+  locale)
+
+(defun lconv ()
+  (declare (external "lconv"))
+  LCONV)

plugins/primus_lisp/site-lisp/posix.lisp

@@ -3,3 +3,8 @@
 (require string)
 (require errno)
 (require ascii)
+(require locale)
+(require libintl)
+(require unistd)
+(require setjmp)
+(require getopt)

plugins/primus_lisp/site-lisp/setjmp.lisp

@@ -0,0 +1,13 @@
+(in-package posix)
+
+(defun setjmp (_)
+  (declare (external "setjmp" "_setjmp"))
+  0)
+
+(defun sigsetjmp (_ _)
+  (declare (external "sigsetjmp" "_sigsetjmp"))
+  0)
+
+(defun longjmp (_ _)
+  (declare (external "longjmp" "_longjmp" "siglongjmp" "_siglongjmp"))
+  (exit 1))

plugins/primus_lisp/site-lisp/stdio.lisp

@@ -5,15 +5,15 @@
 (in-package posix)
 
 (defun fputc (char stream)
-  (declare (external "fputc" "putc"))
+  (declare (external "fputc" "putc" "fputs_unlocked putc_unlocked"))
   (if (= 0 (channel-output stream char)) char -1))
 
 (defun putchar (char)
-  (declare (external "putchar"))
+  (declare (external "putchar" "putchar_unlocked"))
   (fputc char *standard-output*))
 
 (defun fputs (p stream)
-  (declare (external "fputs"))
+  (declare (external "fputs" "fputs_unlocked"))
   (while (not (points-to-null p))
     (fputc (cast int (memory-read p)) stream)
     (incr p))
@@ -22,11 +22,11 @@
     r))
 
 (defun puts (p)
-  (declare (external "puts"))
+  (declare (external "puts" "puts_unlocked"))
   (fputs p *standard-output*))
 
 (defun fflush (s)
-  (declare (external "fflush"))
+  (declare (external "fflush" "fflush_unlocked"))
   (channel-flush s))
 
 
@@ -36,13 +36,13 @@
 ;; ignoring modes, we will add them later, of course.
 (defun fopen (path mode)
   (declare (external "fopen" "open" "fdopen"))
-  (channel-open path))
+  (let ((file (channel-open path)))
+    (if (< file 0) 0 file)))
 
 (defun fileno (stream)
   (declare (external "fileno"))
   stream)
 
-
 (defun open3 (path flags mode)
   (declare (external "open"))
   (fopen path mode))
@@ -61,7 +61,7 @@
     i))
 
 (defun fwrite (buf size n stream)
-  (declare (external "fwrite"))
+  (declare (external "fwrite" "fwrite_unlocked"))
   (let ((i 0))
     (while (and (< i n)
                 (= size (output-item buf size i stream)))
@@ -90,7 +90,7 @@
     i))
 
 (defun fread (ptr size n stream)
-  (declare (external "fread"))
+  (declare (external "fread" "fread_unlocked"))
   (let ((i 0))
     (while (and
             (< i n)
@@ -104,7 +104,7 @@
 
 
 (defun fgetc (stream)
-  (declare (external "fgetc" "getc"))
+  (declare (external "fgetc" "getc" "fgetc_unlocked" "getc_unlocked"))
   (channel-input stream))
 
 (defun terminate-string-and-return-null (ptr)
@@ -113,7 +113,7 @@
   0)
 
 (defun fgets (ptr len str)
-  (declare (external "fgets"))
+  (declare (external "fgets" "fgets_unlocked"))
   (if (= len 0) (terminate-string-and-return-null ptr)
     (let ((i 0)
           (n (-1 len))
@@ -132,7 +132,7 @@
 
 
 (defun getchar ()
-  (declare (external "getchar"))
+  (declare (external "getchar" "getchar_unlocked"))
   (fgetc *standard-input*))
 
 (defmethod primus:machine-kill ()

plugins/primus_lisp/site-lisp/stdlib.lisp

@@ -32,7 +32,7 @@
 
 
 (defun atexit (cb)
-  (declare (external "atexit"))
+  (declare (external "atexit" "__cxa_atexit"))
   0)
 
 (defun abs (x)

plugins/primus_lisp/site-lisp/unistd.lisp

@@ -0,0 +1,15 @@
+(in-package posix)
+
+(defun isatty (fd)
+  (declare (external "isatty"))
+  (< fd 3))
+
+(defun ioctl (_ _) (declare (external "ioctl")) 0)
+(defun ioctl (_ _ _) (declare (external "ioctl")) 0)
+(defun ioctl (_ _ _ _) (declare (external "ioctl")) 0)
+(defun ioctl (_ _ _ _ _) (declare (external "ioctl")) 0)
+(defun ioctl (_ _ _ _ _ _) (declare (external "ioctl")) 0)
+
+(defun getpagesize ()
+  (declare (external "getpagesize"))
+  (* 64 1024))