Create new a6hk and ta6hk machine types for haiku

README.md

@@ -16,6 +16,7 @@ Supported platforms (bytecode interpreter may work for others):
  * NetBSD: x86, x86_64, ARMv6, AArch64, PowerPC32
  * Solaris: x86, x86_64
  * GNU/Hurd: x86, x86_64
+ * Haiku: x86_64
  * Android: ARMv7, AArch64
  * iOS: AArch64
  * WebAssembly via Emscripten (bytecode interpreter only)

c/expeditor.c

@@ -762,7 +762,7 @@ static void s_ee_set_color(int color_id, IBOOL background) {
 # include <unistd.h>
 # include <time.h>
 #endif
-#if !defined(__GLIBC__) && !defined(__COSMOPOLITAN__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__linux__) && !defined(__EMSCRIPTEN__) && !defined(NO_USELOCALE)
+#if !defined(__GLIBC__) && !defined(__COSMOPOLITAN__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__linux__) && !defined(__HAIKU__) && !defined(__EMSCRIPTEN__) && !defined(NO_USELOCALE)
 # include <xlocale.h>
 #endif
 

c/version.h

@@ -141,6 +141,36 @@ typedef int tputsputcchar;
 #endif
 #endif
 
+#if  defined(__HAIKU__)
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define SECATIME(sb) (sb).st_atime
+#define SECCTIME(sb) (sb).st_ctime
+#define SECMTIME(sb) (sb).st_mtime
+#define NSECATIME(sb) 0
+#define NSECCTIME(sb) 0
+#define NSECMTIME(sb) 0
+#define ICONV_INBUF_TYPE char **
+#define USE_OSSP_UUID
+#endif
+
+
+
 #if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__DragonFly__)
 #define NOBLOCK O_NONBLOCK
 #define LOAD_SHARED_OBJECT

configure

@@ -143,6 +143,11 @@ case "${CONFIG_UNAME}" in
     installprefix=/usr
     installmansuffix=share/man
     ;;
+  Haiku)
+    unixsuffix=hk
+    installprefix=/system
+    installmansuffix=documentation/man
+    ;;
   QNX)
     if uname -m | egrep 'x86' > /dev/null 2>&1 ; then
       m32=i3qnx
@@ -777,7 +782,7 @@ fi
 
 # Infer flags needed for threads:
 case "${flagsm}" in
-  t*le|t*gnu|t*fb|t*ob|t*nb)
+  t*le|t*gnu|t*fb|t*ob|t*nb|t*hk)
       threadFlags="-D_REENTRANT -pthread"
       threadLibs="-lpthread"
       ;;
@@ -887,7 +892,7 @@ fi
 # Add automatic linking flags, unless suppressed by --disable-auto-flags
 if [ "$addflags" = "yes" ] ; then
   case "${flagsm}" in
-    *le|*gnu)
+    *le|*gnu|*hk)
         LDFLAGS="${LDFLAGS} -rdynamic"
         ;;
     *fb|*nb)
@@ -904,7 +909,7 @@ if [ "$addflags" = "yes" ] ; then
     *le|*gnu)
         LIBS="${LIBS} -lm -ldl ${ncursesLib} -lrt"
         ;;
-    *fb|*ob)
+    *fb|*ob|*hk)
         LIBS="${LIBS} ${iconvLib} -lm ${ncursesLib}"
         ;;
     *nb)
@@ -997,7 +1002,7 @@ exeSuffix=
 
 # compile flags for c/Mf-unix and mats/Mf-unix
 case "${flagsmuni}" in
-    *le|*gnu)
+    *le|*gnu|*hk)
         mdcflags="-fPIC -shared"
         ;;
     *fb|*ob)
@@ -1031,7 +1036,7 @@ case "${flagsmuni}" in
     i3le)
         mdldflags="-melf_i386"
         ;;
-    *le|*gnu)
+    *le|*gnu|*hk)
         ;;
     i3nb)
         mdldflags="-m elf_i386"

csug/foreign.stex

@@ -2968,6 +2968,11 @@ On Windows:
 (load-shared-object "msvcrt.dll")
 \endschemedisplay
 
+On Haiku:
+\schemedisplay
+(load-shared-object "libroot.so")
+\endschemedisplay
+
 Once the C library has been loaded, \scheme{getenv} should be available
 as a foreign entry.
 
@@ -3009,7 +3014,7 @@ The files must be compiled and linked into a shared object before
 they can be loaded.
 How this is done depends upon the host system.
 \noindent
-On Linux, FreeBSD, OpenBSD, and OpenSolaris systems:
+On Linux, FreeBSD, Haiku, OpenBSD, and OpenSolaris systems:
 
 \schemedisplay
 (system "cc -fPIC -shared -o evenodd.so even.c odd.c")

makefiles/install.zuo

@@ -179,8 +179,12 @@
     (shell/wait* "rm" "-f" f))
   (define (rm-rf d)
     (shell/wait* "rm" "-rf" d))
+  (define haiku? (glob-match? "*hk" m))
   (define (ln-f from to)
-    (shell/wait* "ln" "-f" from to))
+    (if haiku?
+        ;; no hard links on BeFS
+        (shell/wait* "ln" "-s" from to)
+        (shell/wait* "ln" "-f" from to)))
   (define (ln-s from to)
     (shell/wait* "ln" "-s" from to))
 

mats/bytevector.ms

@@ -36,7 +36,7 @@
                 i3osx ti3osx a6le ta6le a6nb ta6nb
                 a6osx ta6osx a6ios ta6ios a6fb ta6fb a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx
                 arm32le tarm32le arm64le tarm64le arm64osx tarm64osx arm64ios tarm64ios rv64le trv64le
-                la64le tla64le)
+                la64le tla64le a6hk ta6hk)
           'little]
          [(ppc32le tppc32le ppc32osx tppc32osx) 'big]
          [(pb tpb) (native-endianness)]

mats/foreign.ms

@@ -209,6 +209,14 @@
       (error? (load-shared-object 3))
     )
    ]
+  [(a6hk ta6hk)
+  (mat load-shared-object
+	(file-exists? foreign1.so)
+      (begin (load-shared-object foreign1.so) #t)
+      (begin (load-shared-object "libroot.so") #t)
+      (error? (load-shared-object 3))
+    )
+   ]
   [(i3fb ti3fb a6fb ta6fb)
    (mat load-shared-object
       (file-exists? foreign1.so)
@@ -3372,6 +3380,8 @@
          '(load-shared-object "libc.so")]
         [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le rv64le trv64le la64le tla64le)
          '(load-shared-object "libc.so.6")]
+	[(a6hk ta6hk)
+	 '(load-shared-object "libroot.so")]
         [(i3fb ti3fb a6fb ta6fb)
          '(load-shared-object "libc.so.7")]
         [(i3nt ti3nt a6nt ta6nt arm64nt tarm64nt)

mats/mat.ss

@@ -121,24 +121,39 @@
           [else c])))
     (define (condition-message c)
       (define prefix?
-        (lambda (x y)
+        (lambda (x y y-start)
           (let ([n (string-length x)])
-            (and (fx<= n (string-length y))
+            (and (fx<= n (- (string-length y) y-start))
               (let prefix? ([i 0])
                 (or (fx= i n)
-                    (and (char=? (string-ref x i) (string-ref y i))
+                    (and (char=? (string-ref x i) (string-ref y (+ i y-start)))
                          (prefix? (fx+ i 1)))))))))
       (define prune-prefix
         (lambda (x y)
-          (and (prefix? x y)
+          (and (prefix? x y 0)
                (substring y (string-length x) (string-length y)))))
-      (let ([s (call-with-string-output-port
-                 (lambda (p) (display-condition c p)))])
-        (or (prune-prefix "Exception: " s)
-            (prune-prefix "Exception in " s)
-            (prune-prefix "Warning: " s)
-            (prune-prefix "Warning in " s)
-            s)))
+      (define rewrite-message
+        (lambda (s from to)
+          (let rewrite ([i 0])
+            (cond
+              [(= i (string-length s))
+               s]
+              [(prefix? from s i)
+               (string-append (substring s 0 i)
+                              to
+                              (substring s (+ i (string-length from)) (string-length s)))]
+              [else (rewrite (add1 i))]))))
+      (let* ([s (call-with-string-output-port
+                 (lambda (p) (display-condition c p)))]
+             [s (or (prune-prefix "Exception: " s)
+                    (prune-prefix "Exception in " s)
+                    (prune-prefix "Warning: " s)
+                    (prune-prefix "Warning in " s)
+                    s)]
+             [s (rewrite-message s
+                                 "file or directory already exists"
+                                 "file exists")])
+        s))
     (define (condition-type c)
       (case (fxior (if (warning? c) 1 0) (if (error? c) 2 0) (if (violation? c) 4 0))
         [(1) 'warning]
@@ -518,6 +533,11 @@
       (lambda () #t)
       (lambda () #f)))
 
+(define haiku?
+  (if (memq (machine-type) '(a6hk ta6hk))
+      (lambda () #t)
+      (lambda () #f)))
+
 (define embedded?
   (lambda () #f))
 

mats/primvars.ms

@@ -18,7 +18,7 @@
     (define (mat-id? x)
       (memq x
         '(equivalent-expansion? mat-run mat mat/cf
-           mat-file mat-output enable-cp0 windows? embedded? pb?
+           mat-file mat-output enable-cp0 windows? embedded? pb? haiku?
            *scheme* *mats-dir*
            *fuzz* ~= fl~= cfl~= == nan pi +pi +pi/2 +pi/4 -pi -pi/2 -pi/4 +e -e
            separate-eval-tools separate-compile separate-eval run-script patch-exec-path $record->vector

mats/unix.ms

@@ -13,7 +13,7 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
-(if (or (windows?) (equal? (getenv "USER") "root") (embedded?))
+(if (or (windows?) (haiku?) (equal? (getenv "USER") "root") (embedded?))
     (mat unix-file-io
       (error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
       (error? (errorf 'open-output-file "failed for testfile.ss: file exists"))
@@ -177,7 +177,7 @@
     )
 )
 
-(if (or (windows?) (equal? (getenv "USER") "root") (embedded?))
+(if (or (windows?) (haiku?) (equal? (getenv "USER") "root") (embedded?))
     (mat file-operations
       (error? (errorf 'delete-directory "failed for ~a: ~a" "testlink1" "not a directory"))
       (error? (errorf 'delete-directory "failed for ~a: ~a" "testlink2" "not a directory"))

release_notes/release_notes.stex

@@ -89,6 +89,10 @@ procedure) is given in parentheses.
      \item x86, nonthreaded (i3s2) and threaded (ti3s2)
      \item x86\_64, nonthreaded (a6s2) and threaded (ta6s2)
      \end{itemizeC}
+\item Haiku
+     \begin{itemizeC}
+     \item x86\_64, nonthreaded (a6hk) and threaded (ta6hk)
+     \end{itemizeC}
 \item Other platforms
      \begin{itemizeC}
      \item bytecode interpretation (pb, tpb, pb32l, tpb32l, pb32b, tpb32b, pb64l, tpb64l, pb64b, tpb64b)

s/cmacros.ss

@@ -419,6 +419,7 @@
   rv64ob    trv64ob
   rv64nb    trv64nb
   la64le    tla64le
+  a6hk      ta6hk
 )
 
 (include "machine.def")