makexo

#!/bin/bash
# -*- scheme -*-
#|
# makexo
#
# Copyright (C) 2025 Matthew Wette
#
#   $ makexos pathsetfile
# -t TOPDIR  set topdir to find go files

exec guile $0 "$@"
|#
!#

(use-modules (ice-9 rdelim))
(use-modules (srfi srfi-37))

(use-modules (ice-9 pretty-print))
(define (pp exp) (pretty-print exp))
(define (sf fmt . args) (apply simple-format #t fmt args))

;; a bit kludgy, for now
(define (genxo gopath xofile)
  (let ((wd (getcwd))
        (gofile (string-append (basename xofile ".xo") ".go")))
    (chdir "xo.d")
    (when (access? gofile R_OK) (delete-file gofile))
    (symlink gopath gofile)
    (system 
     (string-append
      "objcopy -I binary -B i386 -O elf64-x86-64" 
      " --add-section .note.GNU-stack=/dev/null "
      gofile " " xofile))
    (delete-file gofile)
    (chdir wd)))

(define (hash-path path)
  ;; 5 base16 chars based on 24 bit hash
  (define (C16 ix) (string-ref "ABCDEFGHJKMNPRST" ix))
  (define (finish hv)
    (list->string
     (let lp ((l '()) (v hv) (i 5)) ;; i <= 6
       (if (zero? i) l
           (lp (cons (C16 (remainder v 16)) l) (quotient v 16) (1- i))))))
  (define (lnot24 x)
    (let ((v (lognot x)))
      (if (negative? v) (+ v 16777216) v)))
  (let loop ((hv 0) (ix 0))
    (if (= ix (string-length path)) (finish hv)
        (let* ((cv (char->integer (string-ref path ix)))
               (hv (logand (+ (ash hv 3) cv) #xffffff))
               (hi (ash hv -21)))
          (loop (if (zero? hi) hv (lnot24 (logxor hv (ash hi -18)))) (1+ ix))))))

(define (sanitize-name path)
  (string-map (lambda (ch) (if (memq ch '(#\- #\.)) #\_ ch)) path))

(define (canize-path path)
  (catch #t
    (lambda () (canonicalize-path path))
    (lambda (key . args) (sf "path=~s\n" path) (quit))))

(define (gen-xos go-files)
  (unless (access? "xo.d" 7) (system "mkdir xo.d"))
  (unless (access? "go.d" 7) (system "mkdir go.d"))
  (let ((go-paths (map canize-path go-files)))
    (map
     (lambda (gopath)
       (let* ((rfil (basename gopath ".go"))
              (rdir (dirname gopath))
              (rhead (string-append rdir "/" rfil))
              (rhash (hash-path rdir))
              (cfil (sanitize-name rfil))
              (xbase (string-append rhash "_" cfil))
              (xofile (string-append xbase ".xo")))
         (genxo gopath xofile)
         xbase))
     go-paths)))

(define code-part1
  "
SCM scm_load_thunk_from_memory(SCM);

SCM zcm_c_pointer_to_bytevector(void *pointer, size_t size) {
  SCM ptr, len, mem;

  ptr = scm_from_pointer(pointer, NULL);
  len = scm_from_size_t(size);
  mem = scm_pointer_to_bytevector(ptr, len, SCM_UNDEFINED, SCM_UNDEFINED); 
  return mem;
}

static void loadem() {
  char *ptr, *end;
  size_t siz;
  SCM mem, res, mod_init;\n\n")

(define (code-part2a term)
  (string-append
   (simple-format #f "  ptr = _binary_~a_go_start;\n" term)
   (simple-format #f "  end = _binary_~a_go_end;\n" term)))

(define code-part2b
  "  siz = end - ptr;
  mem = zcm_c_pointer_to_bytevector (ptr, siz);
  mod_init = scm_load_thunk_from_memory(mem);
  res = scm_call_0(mod_init);\n\n")

(define code-part3
  "  return;\n}\n")

(define (gen-ci xbases)
  (let ((sport (open-output-file "xo.d/xoload.ci")))
    (for-each
     (lambda (xbase)
       (let ((ebase (string-append xbase "_go")))
         (simple-format sport "extern char _binary_~a_start[];\n" ebase)
         (simple-format sport "extern char _binary_~a_end[];\n" ebase)))
     xbases)
    (display code-part1 sport)
    (for-each
     (lambda (xbase)
       (display (code-part2a xbase) sport)
       (display code-part2b sport))
     xbases)
    (display code-part3 sport)
    (close-port sport)))

;;(search-path (list (assq-ref %guile-build-info 'ccachedir)) "ice-9/boot-9.go")


(define options
 (list
 ))

(define (parse-args args)
 (args-fold args
            options
            (lambda (opt name arg opts)
              (error "unrecognized option: ~S" name)
              (exit 1))
            (lambda (file opts)
              (acons 'file file opts))
            '()))

(define (main args)
  (let* ((opts (parse-args args))
         (file (or (assq-ref opts 'file) (error "no file")))
         (port (open-input-file file))
         (lines (let lp ((l (read-line port)))
                  (if (eof-object? l) '() (cons l (lp (read-line port))))))
         (xbases (gen-xos lines))
         (x (gen-ci xbases))
         )
    #f))

(main (cdr (program-arguments)))

;; --- last line ---