From 51c8687a1d96f356b97267bf28f69e3beab03ada Mon Sep 17 00:00:00 2001 From: "Michael D. Lowis" Date: Wed, 7 May 2014 20:59:31 -0400 Subject: [PATCH] make words externally accessible --- .gitignore | 1 + source/slbuild/main.scm | 241 ++++++++++++++++++++++++++++++++ source/slvm/kernel/parser.c | 2 +- source/slvm/kernel/parser.h | 4 +- source/slvm/kernel/slvm.c | 72 +++------- source/slvm/kernel/slvm.h | 24 ++-- source/slvm/platforms/C99/pal.c | 25 +++- 7 files changed, 296 insertions(+), 73 deletions(-) create mode 100644 source/slbuild/main.scm diff --git a/.gitignore b/.gitignore index 2a3ff3d..4af146e 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ cscope.out Makefile .sconsign.dblite +.DS_Store diff --git a/source/slbuild/main.scm b/source/slbuild/main.scm new file mode 100644 index 0000000..faa7e5e --- /dev/null +++ b/source/slbuild/main.scm @@ -0,0 +1,241 @@ +(declare (uses posix)) +(use posix) + +; Task Definition and Interaction +;------------------------------------------------------------------------------ +(define-record task name desc active? deps actions) + +(define top-level-tasks '()) + +(define current-namespace + (make-parameter '())) + +(define current-desc + (make-parameter #f)) + +(define (task-register! task) + (define name (task-name task)) + (define entry (assoc name top-level-tasks)) + (if (not entry) + (set! top-level-tasks (cons (cons name task) top-level-tasks)) + (set-cdr! entry (task-merge (cdr entry) task)))) + +(define (task-merge task1 task2) + (make-task (task-name task1) (task-desc task1) #t + (append (task-deps task1) + (task-deps task2)) + (append (task-actions task1) + (task-actions task2)))) + +(define (task-lookup name) + (define entry (assoc name top-level-tasks)) + (if (not entry) + (error (string-append "No such task: " name)) + (cdr entry))) + +(define (task-invoke! name) + (define task (task-lookup name)) + (if (task-active? task) + (begin (task-active?-set! task #f) + (map task-invoke! (task-deps task)) + (map (lambda (fn) (fn)) (task-actions task))))) + +(define (gen-task-name name) + (define namespace (current-namespace)) + (if (not (null? namespace)) + (string-append namespace ":" name) + name)) + +; Environment Functions +;------------------------------------------------------------------------------ +(define-record builder defaults action) + +(define (get-sys-env) + (get-environment-variables)) + +(define (set-sys-env! newenv) + (clear-sys-env!) + (map (lambda (p) (setenv (car p) (cdr p))) + newenv)) + +(define (clear-sys-env!) + (map (lambda (p) (unsetenv (car p))) + (get-environment-variables))) + +(define current-env + (let [(curr-env (get-sys-env))] + (lambda args + (if (> (length args) 0) + (begin (set-sys-env! (car args)) + (set! curr-env (car args))) + curr-env)))) + +(define (env-clone env . vars) + (define newenv (map (lambda (p) (cons (car p) (cdr p))) env)) + (define newvals '()) + (map (lambda (e) + (define entry (assoc (car e) newenv)) + (if entry + (set-cdr! entry (cdr e)) + (set! newvals (cons e newvals)))) + vars) + (append newvals newenv)) + +(define (env-get env key) + (define entry (assoc key env)) + (if entry (cdr entry) #f)) + +(define (env-set env key value) + (cons (cons key value) + (env-unset env key))) + +(define (env-unset env key) + (cond [(null? env) '()] + [(string=? (caar env) key) (env-unset (cdr env) key)] + [else (cons (car env) (env-unset (cdr env) key))])) + +(define (env-extend env . vars) + (foldl (lambda (env p) + (env-set env (car p) (cdr p))) + env + vars)) + +(define (env-substitute env str) + (list->string (sub-vars (string->list str) env))) + +(define (env-prepend-path env path) + '()) + +(define (env-append-path env path) + '()) + +(define (env-add-builders env . builders) + '()) + +; Builders +;------------------------------------------------------------------------------ + + +; System Utility Functions +;------------------------------------------------------------------------------ +(define verbose #f) + +(define (build type . args) + (define bldr (assoc type (assoc "builders" (current-env)))) + (define bldr-env (env-merge (builder-defaults bldr) (current-env))) + (apply (builder-action bldr) (cons bldr-env args))) + +(define (run . args) + (define cmd (env-substitute (current-env) (string-join args " "))) + (if verbose (print cmd)) + (if (not (= 0 (system cmd))) + (fail-build cmd))) + +(define (fail-build cmd) + (print "Error: Command returned a non-zero status") + (exit 1)) + +; Directories +(define cd change-directory) +(define curdir current-directory) +(define mkdir create-directory) +(define rmdir delete-directory) +(define lsdir directory) +(define dir? directory?) +; glob + +; Files +(define cp '()) +(define mv '()) +(define rm delete-file) + +; String Templating +;------------------------------------------------------------------------------ +(define (sub-vars chlst env) + (cond [(null? chlst) '()] + [(char=? #\$ (car chlst)) (let [(pair (replace-var (cdr chlst) env))] + (append (string->list (car pair)) + (sub-vars (cdr pair) env)))] + [else (cons (car chlst) (sub-vars (cdr chlst) env))])) + +(define (replace-var chlst env) + (define tok '()) + (define (collect-var-chars chlst) + (if (or (null? chlst) (char=? (car chlst) #\space)) + (set! tok (cons (list->string (reverse tok)) chlst)) + (begin (set! tok (cons (car chlst) tok)) + (collect-var-chars (cdr chlst))))) + (collect-var-chars chlst) + (let [(var (env-get env (car tok)))] + (if var + (cons var (cdr tok)) + (cons "" (cdr tok))))) + +;(define (scan-tok chlst tok) +; (cond [(or (null? chlst) (char=? #\space (car chlst))) +; (list->string (reverse tok))] + +; System Utility Functions +;------------------------------------------------------------------------------ +(define (string-join strlst jstr) + (foldl (lambda (a b) (string-append a b jstr)) "" strlst)) + +; DSL Definition +;------------------------------------------------------------------------------ +(define-syntax task + (syntax-rules (=>) + [(_ name => (deps ...)) + (task-register! (make-task (gen-task-name name) (current-desc) #t '(deps ...) '()))] + [(_ name => (deps ...) exp1 expn ...) + (task-register! + (make-task (gen-task-name name) (current-desc) #t '(deps ...) + (list (lambda () exp1 expn ...))))] + [(_ name exp1 expn ...) + (task-register! + (make-task (gen-task-name name) (current-desc) #t '() + (list (lambda () exp1 expn ...))))])) + +(define-syntax namespace + (syntax-rules () + [(_ name body ...) + (let [(prev-ns (current-namespace))] + (current-namespace (gen-task-name name)) + body ... + (current-namespace prev-ns))])) + +(define (desc str) + (current-desc str)) + +(define-syntax environment + (syntax-rules (<=) + [(_ name <= parent vars ...) + (define name (env-extend parent vars ...))] + [(_ name vars ...) + (define name (env-extend (current-env) vars ...))])) + +(define-syntax builder + (syntax-rules (defaults action) + [(_ (defaults vars ...) (action args body ...)) + (make-builder '(vars ...) (lambda args body ...))])) + +; Core Tasks +;------------------------------------------------------------------------------ +(task "verbose" + (set! verbose #t)) + +(task "help" + (map (lambda (t) + (if (task-desc (cdr t)) + (print (string-append (task-name (cdr t)) " - " (task-desc (cdr t)))))) + top-level-tasks)) +; Main +;------------------------------------------------------------------------------ +(define (run-top-level-tasks!) + (map task-invoke! + (if (= 0 (length (command-line-arguments))) + '("default") + (command-line-arguments)))) + +(load "Spadefile") +(run-top-level-tasks!) + diff --git a/source/slvm/kernel/parser.c b/source/slvm/kernel/parser.c index 019dc75..94d1eac 100644 --- a/source/slvm/kernel/parser.c +++ b/source/slvm/kernel/parser.c @@ -128,7 +128,7 @@ static bool is_float(char* p_str, val_t* p_val); static bool is_string(char* p_str, val_t* p_val); static bool is_char(char* p_str, val_t* p_val); -TokenType_T parse(char* str, val_t* p_val) +TokenType_T parse_token(char* str, val_t* p_val) { TokenType_T type = ERROR; if(str != NULL) diff --git a/source/slvm/kernel/parser.h b/source/slvm/kernel/parser.h index b618be5..42a32bd 100644 --- a/source/slvm/kernel/parser.h +++ b/source/slvm/kernel/parser.h @@ -22,8 +22,6 @@ typedef enum { char* fetch_token(void); -TokenType_T parse(char* str, val_t* p_val); - -bool line_read(void); +TokenType_T parse_token(char* str, val_t* p_val); #endif /* PARSER_H */ diff --git a/source/slvm/kernel/slvm.c b/source/slvm/kernel/slvm.c index 3e24213..5640ef6 100644 --- a/source/slvm/kernel/slvm.c +++ b/source/slvm/kernel/slvm.c @@ -20,6 +20,7 @@ * Add ability to compile to standalone executable * Add support for multi-tasking * Add support for multi-tasking with multiple cores/threads + */ /* Inner Interpreter @@ -104,15 +105,15 @@ defcode("find", find, 0, &exec){ *(ArgStack) = (val_t)curr; } -defcode("fetch", _fetch, 0, &find){ +defcode("fetchtok", fetchtok, 0, &find){ ArgStack++; *(ArgStack) = (val_t)fetch_token(); } -defcode("parse", _parse, 0, &_fetch){ +defcode("parsetok", parsetok, 0, &fetchtok){ char* p_str = (char*)*(ArgStack); ArgStack++; - *(ArgStack) = (val_t)parse( p_str, ArgStack-1 ); + *(ArgStack) = (val_t)parse_token( p_str, ArgStack-1 ); /* If the parsed token no longer needs the original string */ if (*(ArgStack) > STRING) { @@ -123,17 +124,17 @@ defcode("parse", _parse, 0, &_fetch){ /* Branching and Literal Words *****************************************************************************/ -defcode("lit", literal, 0, &_parse){ +defcode("lit", lit, 0, &parsetok){ ArgStack++; *(ArgStack) = *CodePtr; CodePtr++; } -defcode("br", branch, 0, &literal){ +defcode("br", br, 0, &lit){ CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t))); } -defcode("0br", zbranch, 0, &branch){ +defcode("0br", zbr, 0, &br){ if (*ArgStack == 0) { CodePtr = (val_t*)(((val_t)CodePtr) + (*(CodePtr) * sizeof(val_t))); @@ -147,7 +148,7 @@ defcode("0br", zbranch, 0, &branch){ /* Compiler Words *****************************************************************************/ -defcode("ret", ret, 0, &zbranch){ +defcode("ret", ret, 0, &zbr){ CodePtr = 0; } @@ -208,8 +209,8 @@ defcode("immediate", immediate, 1, &hidden){ } defcode(":", colon, 0, &immediate){ - EXEC(_fetch); - EXEC(_parse); + EXEC(fetchtok); + EXEC(parsetok); ArgStack--; EXEC(create); EXEC(rbrack); @@ -222,16 +223,16 @@ defcode(";", semicolon, 1, &colon){ } defcode("'", tick, 1, &semicolon){ - EXEC(_fetch); - EXEC(_parse); + EXEC(fetchtok); + EXEC(parsetok); ArgStack--; EXEC(find); } -defcode("interp", interp, 0, &_parse){ +defcode("interp", interp, 0, &parsetok){ char* p_str = NULL; - EXEC(_fetch); - EXEC(_parse); + EXEC(fetchtok); + EXEC(parsetok); /* If what we parsed was a word */ if(*ArgStack == WORD) { @@ -267,7 +268,7 @@ defcode("interp", interp, 0, &_parse){ /* What we parsed is a literal and we're in compile mode */ else if (state_val == 1) { - *(ArgStack) = (val_t)&literal; + *(ArgStack) = (val_t)&lit; EXEC(comma); EXEC(comma); } @@ -341,12 +342,12 @@ defcode("*", mul, 0, &sub){ ArgStack--; } -defcode("/", divide, 0, &mul){ +defcode("/", div, 0, &mul){ *(ArgStack-1) /= *(ArgStack); ArgStack--; } -defcode("%", mod, 0, ÷){ +defcode("%", mod, 0, &div){ *(ArgStack-1) %= *(ArgStack); ArgStack--; } @@ -470,43 +471,6 @@ int main(int argc, char** argv) return 0; } -/* Main - *****************************************************************************/ -//int main(int argc, char** argv) -//{ -// /* Compile-time Assertions */ -// CT_ASSERT(sizeof(val_t) == sizeof(val_t*)); -// CT_ASSERT(sizeof(val_t) == sizeof(flags_t)); -// -// /* Platform specific initialization */ -// latest_val = (val_t)&bytemove; -// -// /* Start the interpreter */ -// EXEC(quit); -// return 0; -//} - -/* Control Flow Words - *****************************************************************************/ - -/* Memory Management Words - *****************************************************************************/ -#if 0 -defcode("malloc", mem_alloc, 1, &_else){ - *(ArgStack) = (val_t)malloc((size_t)*(ArgStack)); -} - -defcode("mrealloc", mem_realloc, 1, &mem_alloc){ - *(ArgStack-1) = (val_t)realloc((void*)*(ArgStack-1),*(ArgStack)); - ArgStack--; -} - -defcode("mfree", mem_free, 1, &mem_realloc){ - free((void*)*(ArgStack)); - ArgStack--; -} -#endif - /* Debugging Words *****************************************************************************/ #if 0 diff --git a/source/slvm/kernel/slvm.h b/source/slvm/kernel/slvm.h index 4da3715..dab6db1 100644 --- a/source/slvm/kernel/slvm.h +++ b/source/slvm/kernel/slvm.h @@ -97,21 +97,21 @@ typedef struct dict_t { /** * Define a built-in word that executes native code */ -#define defcode(name_str,c_name,immed,prev) \ - static void c_name##_code(val_t* code); \ - static word_t const c_name = { \ - prev, \ - {.attr = { 0, immed, 0, 0 }}, \ - name_str, \ - &c_name##_code, \ - 0 \ - }; \ - static void c_name##_code(val_t* inst_ptr) \ +#define defcode(name_str,c_name,immed,prev) \ + void c_name##_code(val_t* code); \ + word_t const c_name = { \ + prev, \ + {.attr = { 0, immed, 0, 0 }}, \ + name_str, \ + &c_name##_code, \ + 0 \ + }; \ + void c_name##_code(val_t* inst_ptr) \ /** * Define a built-in word representing a variable with the provided initial value */ #define defvar(name_str,c_name,immed,prev,initial) \ - static val_t c_name##_val = initial; \ + val_t c_name##_val = initial; \ defcode(name_str,c_name,immed,prev) { \ ArgStack++; \ *(ArgStack) = (val_t)&(c_name##_val); \ @@ -120,7 +120,7 @@ typedef struct dict_t { /** * Define a built-in word representing a constant with the provided value */ #define defconst(name_str,c_name,immed,prev,value) \ - static val_t const c_name##_val = value; \ + val_t const c_name##_val = value; \ defcode(name_str,c_name,immed,prev) { \ ArgStack++; \ *(ArgStack) = c_name##_val; \ diff --git a/source/slvm/platforms/C99/pal.c b/source/slvm/platforms/C99/pal.c index 40bc0cf..b6f76d2 100644 --- a/source/slvm/platforms/C99/pal.c +++ b/source/slvm/platforms/C99/pal.c @@ -13,13 +13,32 @@ static bool Line_Read = true; val_t* ArgStack = Stack - 1; val_t* CodePtr = 0; -dict_t* pal_init(dict_t* p_prev_dict) +defcode("allocate", mem_alloc, 1, NULL){ + *(ArgStack) = (val_t)pal_allocate((size_t)*(ArgStack)); +} + +defcode("reallocate", mem_realloc, 1, &mem_alloc){ + *(ArgStack-1) = (val_t)pal_reallocate((void*)*(ArgStack-1),*(ArgStack)); + ArgStack--; +} + +defcode("free", mem_free, 1, &mem_realloc){ + pal_free((void*)*(ArgStack)); + ArgStack--; +} + +dict_t* pal_init(dict_t* p_prev) { - return p_prev_dict; + dict_t* p_dict = (dict_t*)pal_allocate(sizeof(dict_t)); + p_dict->name = "pal"; + p_dict->p_prev = p_prev; + p_dict->p_words = (word_t*)&mem_realloc; + return p_dict; } void pal_prompt(void) { + extern val_t state_val; int i; if(Line_Read) { @@ -33,7 +52,7 @@ void pal_prompt(void) { printf("%ld ", *(ArgStack-i)); } - printf(")\n%s ", "=>"); //(state_val == 0) ? "=>" : ".."); + printf(")\n%s ", (state_val == 0) ? "=>" : ".."); Line_Read = false; } } -- 2.52.0