Makefile
.sconsign.dblite
+.DS_Store
--- /dev/null
+(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!)
+
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)
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 */
* Add ability to compile to standalone executable
* Add support for multi-tasking
* Add support for multi-tasking with multiple cores/threads
+
*/
/* Inner Interpreter
*(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)
{
/* 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)));
/* Compiler Words
*****************************************************************************/
-defcode("ret", ret, 0, &zbranch){
+defcode("ret", ret, 0, &zbr){
CodePtr = 0;
}
}
defcode(":", colon, 0, &immediate){
- EXEC(_fetch);
- EXEC(_parse);
+ EXEC(fetchtok);
+ EXEC(parsetok);
ArgStack--;
EXEC(create);
EXEC(rbrack);
}
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)
{
/* 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);
}
ArgStack--;
}
-defcode("/", divide, 0, &mul){
+defcode("/", div, 0, &mul){
*(ArgStack-1) /= *(ArgStack);
ArgStack--;
}
-defcode("%", mod, 0, ÷){
+defcode("%", mod, 0, &div){
*(ArgStack-1) %= *(ArgStack);
ArgStack--;
}
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
/**
* 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); \
/**
* 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; \
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)
{
{
printf("%ld ", *(ArgStack-i));
}
- printf(")\n%s ", "=>"); //(state_val == 0) ? "=>" : "..");
+ printf(")\n%s ", (state_val == 0) ? "=>" : "..");
Line_Read = false;
}
}
projects / proto / sclpl.git / commitdiff