From 55cbb5600f6a3ee78201e78813c56bdabeef710b Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Tue, 28 May 2024 00:09:51 -0500 Subject: Initial commit --- scramble.scm | 152 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 152 insertions(+) create mode 100644 scramble.scm diff --git a/scramble.scm b/scramble.scm new file mode 100644 index 0000000..e79fbe0 --- /dev/null +++ b/scramble.scm @@ -0,0 +1,152 @@ +(declare (module scramble)) + +(import scheme (chicken base) + (chicken file) + (chicken format) + (chicken pathname) + (chicken process) + (chicken process-context) + (chicken string) + (srfi 1)) + +;; dependencies should be like +;; (((output jimmy.util) (source jimmy.util)) +;; ((output jimmy.read) (source jimmy.read) (source jimmy.util)) +;; ((output jimmy.emit) (source jimmy.emit) (source jimmy.util))) + +(define egg (make-parameter #f)) +(define build-dir (make-parameter "build")) + +(define csc-options '("-setup-mode" + "-host" + "-D compiling-extension" + "-emit-all-import-libraries" + "-dynamic" + "-regenerate-import-libraries" + "-I $(PWD)" + "-C -I$(PWD)")) + +(define source-extensions + ;; The possible extensions source files can take. + (make-parameter '("scm" "sld" "ss"))) + +(define (read-egg #!optional egg-file) + ;; Read EGG-FILE and return the structure inside. + (unless egg-file + (set! egg-file + (receive (_ _ dirs) (decompose-directory (current-directory)) + (make-pathname (current-directory) (car (reverse dirs)) "egg")))) + (assert (file-exists? egg-file) "Can't find egg file" egg-file) + (assert (file-readable? egg-file) "Can't read egg file" egg-file) + (cons* `(egg-directory ,(pathname-directory egg-file)) + `(egg-name ,(string->symbol (pathname-file egg-file))) + (with-input-from-file egg-file read))) + +(define (egg-directory) (alist-ref 'egg-directory (egg))) +(define (egg-name) (car (alist-ref 'egg-name (egg)))) +(define (egg-components) (alist-ref 'components (egg))) +(define (egg-csc-options) + (let ((opts (alist-walk (egg) 'component-options 'csc-options))) + (if opts (map ->string opts) '()))) + +(define (source-of c) + ;; Find the source file of C and return it. If not found, error. + (cond + ((alist-ref 'source (cddr (find-component c))) + => (lambda (s) + (receive (dirs file ext) (decompose-pathname (->string (car s))) + (make-pathname (append (egg-directory) + (if (list? dirs) dirs (list dirs))) + file ext)))) + (else + (let loop ((ext (source-extensions))) + (if (null? ext) #f + (let ((cand (make-pathname (egg-directory) c ext))) + (if (file-exists? cand) cand + (loop (cdr ext))))))))) + +(define (output-of c) + ;; Return the output file of C. It's okay if it doesn't exist. + (make-pathname (append (egg-directory) (list (build-dir))) + (->string c) + (case (car (find-component c)) + ((extension) "so") + ((program))))) + +(define (find-component name) + (find (lambda (c) (eq? name (cadr c))) + (alist-ref 'components (egg)))) + +(define (dependency-graph) + ;; Build a dependency graph from the egg. + (define (component->deps c) + (let* ((c-name (cadr c)) + (c-info (cddr c)) + (c-deps (or (alist-ref 'component-dependencies c-info) '())) + (s-deps (or (alist-ref 'source-dependencies c-info) '()))) + (if (null? (append c-deps s-deps)) + `(,c-name ,c-name) + `(,c-name . ,(cons c-name + (append c-deps + (map ->string s-deps))))))) + (filter-map component->deps (egg-components))) + +(define (alist-walk lis . keys) + (if (null? keys) + lis + (let ((kv (assoc (car keys) lis))) + (cond + ((not kv) #f) + ((atom? (cdr kv)) + (and (null? (cdr keys)) ; this shouldn't error... + (cdr kv))) + ((list? (cdr kv)) + (apply alist-walk (cdr kv) (cdr keys))))))) + +(define (string-join ss) + (string-intersperse ss " ")) + +(define (find-executable name) + (let loop ((path (string-split (get-environment-variable "PATH") ":"))) + (cond + ;; If no executable is found, return just the name. Another option would + ;; be to error out if there isn't an executable here ... + ((null? path) name) + ((and (directory-exists? (car path)) + (member name (directory (car path) 'with-dotfiles))) + (make-pathname (car path) name)) + (else (loop (cdr path)))))) + +(define (rule c) + (let ((deps (alist-ref c (dependency-graph)))) + (sprintf "~a: ~a $(BUILD)\n\t~a\n\t-mv ~a.import.scm $(BUILD)/" + (output-of c) + (string-join (cons (source-of (car deps)) + (map output-of (cdr deps)))) + "$(CSC) $(CSC_OPTIONS) $(CSC_OPTIONS_EXTRA) $< -o $@" + c))) + +(define (emit-makefile egg-file) + (parameterize ((egg (read-egg egg-file))) + (print "# Automatically generated by scramble") (newline) + (print "NAME = " (egg-name)) + (print "CSC = " (find-executable "csc")) + (print "CSC_OPTIONS = " (string-join csc-options)) + (print "CSC_OPTIONS_EXTRA = " (string-join (egg-csc-options))) + (print "CSI = " (find-executable "csi")) + (print "BUILD = $(PWD)/" (build-dir)) + (print "TESTS = $(PWD)/tests") + (print "TEST_ENV = env BUILD=$(BUILD) TESTS=$(TESTS)") + (newline) + (print ".PHONY: all test clean install uninstall") + (print "all: " (string-join (map (o source-of car) (dependency-graph)))) + (print "test: build" + "\n\t" "cd $(BUILD) && " + "$(TEST_ENV) $(CSI) -setup-mode -s $(TESTS)/run.scm $(NAME)") + (print "clean:\n\t-rm -rf $(BUILD)") + (print "install:\n\tchicken-install -s") + (print "uninstall:\n\tchicken-uninstall -s") + (newline) (print "# " (egg-name)) (newline) + (print "$(BUILD):\n\t-mkdir $(BUILD)") + (for-each (o print rule cadr) (egg-components)) + )) -- cgit 1.4.1-21-gabe81