From 60332e6689a4ffa107fe5a46b79d6a14b33c6330 Mon Sep 17 00:00:00 2001 From: "Mike D. Lowis" Date: Thu, 11 Jul 2013 12:47:19 -0400 Subject: [PATCH] Scheme-based syntax compiler now functional (With limited error detection and reporting) --- SConstruct | 19 ++- source/compiler/core-forms.scm | 223 +++++++++++++++------------------ source/compiler/main.scm | 41 ++++-- 3 files changed, 149 insertions(+), 134 deletions(-) diff --git a/SConstruct b/SConstruct index bd5a2a6..f11523e 100644 --- a/SConstruct +++ b/SConstruct @@ -30,12 +30,21 @@ scheme_linker = Builder( src_builder = [ scheme_compiler ] ) +# Scheme Test Linker +scheme_tester = Builder( + action = 'csc $LDFLAGS -o $TARGET $SOURCES && $TARGET', + suffix = "$PROGSUFFIX", + src_suffix = '.o', + src_builder = [ scheme_compiler ] +) + # Create the Environment for this project env = Environment( ENV = os.environ, CCFLAGS = [ '-explicit-use' ], LDFLAGS = [], - BUILDERS = { 'SchemeProgram': scheme_linker } + BUILDERS = { 'SchemeProgram': scheme_linker, + 'SchemeTestRunner': scheme_tester } ) #------------------------------------------------------------------------------ @@ -48,3 +57,11 @@ env.SchemeProgram( source = find_files('source/compiler/','*.scm') ) +env.Command('tests.log', find_files('tests/compiler/','*.scm'), "csi -q $SOURCES >> $TARGET") + +#env.SchemeTestRunner( +# target = 'sclpl-cc-tests', +# source = find_files('source/compiler/','*.scm') + +# find_files('tests/compiler/','*.scm') +#) + diff --git a/source/compiler/core-forms.scm b/source/compiler/core-forms.scm index f43269a..6f8f0df 100644 --- a/source/compiler/core-forms.scm +++ b/source/compiler/core-forms.scm @@ -27,138 +27,113 @@ ; | '(' Variable Variable '.' Variable ')' ; -(define (validate-form frm) +(define (core-syntax-errors frm) (if (definition? frm) - (validate-definition frm) - (validate-expression frm))) - -(define (validate-definition frm) - (if (and (list? frm) (not (null? frm))) - (case (car frm) - [(begin) (map validate-definition (cdr frm))] - [(def) (if (not (def? frm)) - (syntx-err frm "Not a valid def expression"))] - [else (syntx-err frm "Not a valid definition")]) - (syntx-err frm "Not a valid definition"))) - -(define (validate-expression frm) - (if (and (list? frm) (not (null? frm))) + (definition-errors frm) + (expr-errors frm))) + +(define (definition-errors frm) + (case (if (pair? frm) (car frm) '()) + [(def) (def-errors frm)] + [(begin) (begin-errors frm)] + [else (list (cons frm 'not-a-def-or-begin))])) + +(define (def-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'def)) (list (cons frm 'not-a-def))] + [(< (length frm) 2) (list (cons frm 'missing-name))] + [(< (length frm) 3) (list (cons frm 'missing-value))] + [(> (length frm) 3) (list (cons frm 'too-many-items))] + [else (if (not (symbol? (cadr frm))) + (list (cons frm 'def-needs-symbol)) + (expr-errors (cddr frm)))])) + +(define (begin-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'begin)) (list (cons frm 'not-a-begin))] + [(< (length frm) 2) (list (cons frm 'no-defs))] + [else (def-list-errors (cdr frm))])) + +(define (expr-errors frm) + (if (pair? frm) (case (car frm) - [(quote) (validate-quotation frm)] - [(func) (validate-func frm)] - [(if) (validate-if frm)] - [(set!) (validate-set frm)] - [else (validate-apply frm)]) - (validate-constant frm))) - -(define (validate-quotation frm) - (if (not (quote? frm)) - (syntx-err frm "Invalid quotation"))) - -(define (validate-func frm) - (if (not (func? frm)) - (syntx-err frm "Invalid function definition"))) - -(define (validate-if frm) - (if (not (if? frm)) - (syntx-err frm "Invalid if statement"))) - -(define (validate-set frm) - (if (not (set? frm)) - (syntx-err frm "Invalid assignment expression"))) - -(define (validate-apply frm) - (if (not (apply? frm)) - (syntx-err frm "Invalid application expression"))) - -(define (validate-constant frm) - (if (not (constant? frm)) - (syntx-err frm "Not a valid constant"))) + [(quote) (quote-errors frm)] + [(func) (func-errors frm)] + [(if) (if-errors frm)] + [(set!) (set!-errors frm)] + [else (app-errors frm)]) + (const-errors frm))) + +(define (quote-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'quote)) (list (cons frm 'not-a-quote))] + [(< (length frm) 2) (list (cons frm 'no-datum))] + [(> (length frm) 2) (list (cons frm 'too-many-items))] + [else '()])) + +(define (func-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'func)) (list (cons frm 'not-a-func))] + [(< (length frm) 2) (list (cons frm 'no-args-list))] + [(< (length frm) 3) (list (cons frm 'no-body))] + [else (append (args-errors (cadr frm)) + (exp-list-errors (cddr frm)))])) + +(define (if-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'if)) (list (cons frm 'not-an-if))] + [(< (length frm) 2) (list (cons frm 'missing-cond))] + [(< (length frm) 3) (list (cons frm 'too-few-branches))] + [(> (length frm) 4) (list (cons frm 'too-many-branches))] + [else (exp-list-errors (cdr frm))])) + +(define (set!-errors frm) + (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] + [(not (eq? (car frm) 'set!)) (list (cons frm 'not-a-set!))] + [(< (length frm) 2) (list (cons frm 'missing-name))] + [(< (length frm) 3) (list (cons frm 'missing-value))] + [(> (length frm) 3) (list (cons frm 'too-many-items))] + [else (exp-list-errors (cdr frm))])) + +(define (app-errors frm) + (exp-list-errors frm)) + +(define (const-errors frm) + (if (or (boolean? frm) (number? frm) (char? frm) (string? frm) (symbol? frm)) + '() + (list (cons frm 'not-a-const )))) + +(define (args-errors frm) + (if (or (null? frm) (list-of? frm symbol?)) + '() + (list (cons frm 'malformed-args)))) + +(define (def-list-errors dlst) + (apply append (map definition-errors dlst))) + +(define (exp-list-errors elst) + (apply append (map core-syntax-errors elst))) ;------------------------------------------------------------------------------ -(define (form? frm) - (or (definition? frm) (expression? frm))) - -(define (definition? frm) - (or (def? frm) (begin? frm))) - -(define (def? frm) - (and (list-of-length? frm 3) - (equal? 'def (car frm)) - (symbol? (cadr frm)) - (expression? (caddr frm)))) - -(define (begin? frm) - (and (list-of->=-length? frm 2) - (equal? 'begin (car frm)) - (list-of? (cdr frm) definition?))) - -(define (expression? expr) - (if (constant? expr) #t - (and (list? expr) - (not (null? expr)) - (case (car expr) [(begin def) #f] - [else #t])))) - -(define (quote? frm) - (and (list-of-length? frm 2) - (equal? 'quote (car frm)))) - -(define (func? frm) - (and (list-of->=-length? frm 3) - (equal? 'func (car frm)) - (list-of? (cadr frm) symbol?) - (list-of? (cddr frm) expression?))) - -(define (if? frm) - (and (list-of-length? frm 4) - (equal? 'if (car frm)) - (list-of? (cdr frm) expression?))) - -(define (set? frm) - (and (list-of-length? frm 3) - (equal? 'set! (car frm)) - (symbol? (cadr frm)) - (expression? (caddr frm)))) - -(define (apply? frm) - (and (not (null? frm)) - (list-of? frm expression?))) - -(define (constant? frm) - (or (number? frm) (string? frm) (symbol? frm) (char? frm) (boolean? frm))) - -; Utility Predicate Procedures -;------------------------------------------------------------------------------ (define (list-of? lst prdfn) - (if (not (list? lst)) #f - (if (null? lst) #t - (and (prdfn (car lst)) - (list-of? (cdr lst) prdfn))))) - -(define (list-of->=-length? lst len) - (and (list? lst) (>= (length lst) len))) + (if (and (pair? lst) + (prdfn (car lst)) + (if (null? (cdr lst)) #t (list-of? (cdr lst) prdfn))) + #t #f)) -(define (list-of-length? lst len) - (and (list? lst) (= (length lst) len))) +(define (form-of-type? frm type) + (and (pair? frm) (eq? (car frm) type))) -(define (get-free-vars expr) - (if (symbol? expr) expr - (case (if (list? expr) (car expr) '()) - [(def set!) (list (cadr expr) (get-free-vars (caddr expr)))] - [(begin if) (map get-free-vars (cdr expr))] - [(func) (filter-vars (cadr expr) (map get-free-vars (cddr expr)))] - [else (map get-free-vars expr)]))) - -(define (filter-vars defd lst) - (filter (lambda (item) (not (member item defd))) lst)) +(define (definition? frm) + (or (form-of-type? frm 'def) + (form-of-type? frm 'begin))) -; Utility Procedures ;------------------------------------------------------------------------------ -(define (syntx-err frm msg) - (print "Error: " msg "\n") - (pretty-print frm) - (display "\n") - (exit 1)) + +(define error-msgs + '((not-a-def . "Not a recognized definition form") + (not-a-def . "Not a recognized definition form") + ) +) diff --git a/source/compiler/main.scm b/source/compiler/main.scm index 0b0b43c..964babb 100644 --- a/source/compiler/main.scm +++ b/source/compiler/main.scm @@ -1,12 +1,26 @@ -(declare (uses library eval core-forms)) +(declare (uses library eval core-forms srfi-13 extras)) -(define (start-repl prt) - (display ":> ") - (let [(form (read prt))] - (validate-form form) - (print (eval (core-form->scheme form) - (interaction-environment)))) - (start-repl prt)) +(define (compile-file fname) + (define ofname (get-output-file-name fname)) + (define program (parse-file fname)) + (with-output-to-file ofname + (lambda () (map pretty-print program))) + (system (string-append "csc " ofname)) + (delete-file ofname)) + +(define (get-output-file-name ifname) + (string-append (substring ifname 0 (string-index-right ifname #\.)) ".scm")) + +(define (parse-file fname) + (map core-form->scheme (read-forms (open-input-file fname)))) + +(define (read-forms port) + (define form (read port)) + (if (eof-object? form) + '() + (let [(errs (core-syntax-errors form))] + (if (pair? errs) (begin (pprint-errors errs) (exit 1))) + (cons form (read-forms port))))) (define (core-form->scheme frm) (if (and (list? frm) (not (null? frm))) @@ -16,5 +30,14 @@ [else (map core-form->scheme frm)]) frm)) -(start-repl (current-input-port)) +(define (pprint-errors elst) + (if (pair? elst) + (begin (print "Error: " (cdar elst)) + (pretty-print (caar elst)) + (pprint-errors (cdr elst))))) + +; If we have a file, then parse it +(if (= 1 (length (command-line-arguments))) + (compile-file (car (command-line-arguments))) + (print "No input file provided.")) -- 2.52.0