PasteRack.org
Paste # 63016
2016-01-19 14:08:05

Fork as a new paste.

Paste viewed 174 times.


Embed:

  1. #lang racket/base
  2.  
  3. (provide compile-c-module
  4.          from-c)
  5.  
  6. (require racket/file
  7.          dynext/file
  8.          dynext/compile
  9.          dynext/link
  10.          (for-syntax racket/base
  11.                      syntax/parse
  12.                      racket/require-transform
  13.                      racket/file
  14.                      dynext/file
  15.                      dynext/compile
  16.                      dynext/link))
  17.  
  18. (define-syntax-rule (define-for-syntax-and-runtime f ...)
  19.   (begin (define f ...)
  20.          (define-for-syntax f ...)))
  21.  
  22. (define-for-syntax-and-runtime object-target-path
  23.   (build-path "compiled" "native" (system-library-subpath)))
  24.  
  25. (define-for-syntax-and-runtime (compile-c-module c-source #:output-file [output-file #f])
  26.   (define extensionless-source (path-replace-suffix c-source ""))
  27.   (define object-target
  28.     (if output-file
  29.         (append-object-suffix output-file)
  30.         (build-path object-target-path (append-object-suffix extensionless-source))))
  31.   (define shared-object-target
  32.     (if output-file
  33.         (append-extension-suffix output-file)
  34.         (build-path object-target-path (append-extension-suffix extensionless-source))))
  35.   (make-directory* object-target-path)
  36.   (compile-extension #t c-source object-target '())
  37.   (link-extension #t (list object-target) shared-object-target))
  38.  
  39. (define-syntax from-c
  40.   (make-require-transformer
  41.    (lambda (stx)
  42.      (syntax-parse stx
  43.        [(_ c-source:str)
  44.         (define in (syntax-e #'c-source))
  45.         (define out (make-fresh-filename (path-replace-suffix in "")))
  46.         (define cle (current-load-extension))
  47.         (compile-c-module in #:output-file (build-path object-target-path out))
  48.         (parameterize ([current-load-extension (lambda (p s)
  49.                                                  (define-values (base name dir?)
  50.                                                    (split-path (path-replace-suffix in "")))
  51.                                                  (cle p (string->symbol (path->string name))))])
  52.           (expand-import (datum->syntax stx out)))]))))
  53.  
  54. (define-for-syntax-and-runtime (make-fresh-filename file-base [version 0])
  55.   (define filename (format "~a-~a" file-base version))
  56.   (if (file-exists? (append-object-suffix filename))
  57.       (make-fresh-filename file-base (add1 version))
  58.       filename))

=>