Scheme-based syntax compiler now functional (With limited error detection and reporting)

diff --git a/SConstruct b/SConstruct
index bd5a2a6147d1447259b1e6b252a2ea69d8d662e5..f11523ee940b6c0102bd85c6e5da5df247a19934 100644 (file)
--- 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 f43269aa2d9cb5c8f88ef20c3c39b91b20626f5a..6f8f0dfd7259b38b856aa6428a43f3e711ea4a8d 100644 (file)
--- 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 0b0b43ca9361285200cda26a666cf87ea966917e..964babb9bc311d971652d2d2c5cac6a579f80a6c 100644 (file)
--- 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."))