From 8ca9911e4c651de695cf83216c783761a1635fa8 Mon Sep 17 00:00:00 2001 From: "Michael D. Lowis" Date: Wed, 29 Jan 2014 16:09:36 -0500 Subject: [PATCH] Incorporated experimental code from dropbox --- SConstruct | 16 +- source/compiler/core-forms.scm | 175 ------------ source/compiler/desugar.scm | 24 -- source/compiler/main.scm | 52 ---- source/compiler/type-inference.scm | 236 ----------------- source/slc/main.scm | 412 +++++++++++++++++++++++++++++ 6 files changed, 420 insertions(+), 495 deletions(-) delete mode 100644 source/compiler/core-forms.scm delete mode 100644 source/compiler/desugar.scm delete mode 100644 source/compiler/main.scm delete mode 100644 source/compiler/type-inference.scm create mode 100644 source/slc/main.scm diff --git a/SConstruct b/SConstruct index 0a3245b..edb8440 100644 --- a/SConstruct +++ b/SConstruct @@ -16,13 +16,13 @@ def find_files(path,pattern): # Helper function to build scheme programs and test runners def SchemeBuildAndTest(target,sources,tests): # Figure out the target names - test_runner = target + '_tests' - test_output = target + '_results' - test_sources = [e for e in sources if not e.endswith('main.scm')] + tests + #test_runner = target + '_tests' + #test_output = target + '_results' + #test_sources = [e for e in sources if not e.endswith('main.scm')] + tests # Create the targets scheme.Program( target, sources ) - scheme.Program( test_runner, test_sources ) - RunTest( test_output, test_runner ) + #scheme.Program( test_runner, test_sources ) + #RunTest( test_output, test_runner ) # Helper function to run a test suite and generate a log file def RunTest( output, runner ): @@ -61,7 +61,7 @@ scheme_linker = Builder( # Create the Environment for this project scheme = Environment( ENV = os.environ, - CCFLAGS = [ '-explicit-use', '-I', 'inc'], + CCFLAGS = [ '-I', 'inc'], LDFLAGS = [], TOOLS = [ 'mingw' ], BUILDERS = { 'Program': scheme_linker }) @@ -87,8 +87,8 @@ readsof.Depends('readsof', 'sof') # SCLPL Compiler SchemeBuildAndTest( 'build/slc', - find_files('source/compiler/','*.scm'), - find_files('tests/compiler/','*.scm') ) + find_files('source/slc/','*.scm'), + find_files('tests/slc/','*.scm') ) # SCLPL Package Manager SchemeBuildAndTest( 'build/slpkg', diff --git a/source/compiler/core-forms.scm b/source/compiler/core-forms.scm deleted file mode 100644 index f4d560a..0000000 --- a/source/compiler/core-forms.scm +++ /dev/null @@ -1,175 +0,0 @@ -(declare (unit core-forms) (uses srfi-1)) - -; Formal Syntax -;------------------------------------------------------------------------------ -; -; Program ::= Form* -; -; Form ::= Definition | Expression -; -; Definition ::= '(def' Variable Expression ')' -; | TypeAnnotation -; | TypeDefinition -; | '(begin' Definition* ')' -; -; TypeAnnotation ::= '(def:' Variable TypeConstructor ')' -; -; TypeConstructor ::= Variable -; | '(' Variable+ ')' -; -; TypeDefinition ::= '(data' Variable TypeConstructor+ TypeClassList? ')' -; | '(type' Variable Variable ')' -; | '(class' Variable OpAnnotation+ ')' -; | '(instance' Variable OpDefinition+ ')' -; -; TypeClassList ::= '(deriving' Variable+ ')' -; -; OpAnnotation ::= '(' Variable TypeConstructor ')' -; -; OpDefinition ::= '(' TypeConstructor Expression+ ')' -; -; Expression ::= Constant -; | Variable -; | '(quote' Datum ')' -; | '(func' ArgList Expression+ ')' -; | '(if' Expression Expression Expression ')' -; | '(set!' Variable Expression ')' -; | '(' Expression+ ')' -; -; Constant ::= Boolean | Number | Character | String -; -; ArgList ::= '(' Variable ')' -; | '(' Variable Variable '.' Variable ')' -; - -(define (core-syntax-errors frm) - (if (definition? frm) - (definition-errors frm) - (expr-errors frm))) - -(define (definition-errors frm) - (case (if (pair? frm) (car frm) '()) - [(def) (def-errors frm)] - [(def:) (annotation-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 (annotation-errors frm) - (cond [(not (pair? frm)) (list (cons frm 'not-a-form))] - [(not (eq? (car frm) 'def:)) (list (cons frm 'not-an-anno))] - [(< (length frm) 2) (list (cons frm 'missing-name))] - [(< (length frm) 3) (list (cons frm 'missing-type))] - [else (if (not (symbol? (cadr frm))) - (list (cons frm 'def-needs-symbol)) - (type-errors (caddr 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) (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) (lst-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 (type-errors typ) - (if (or (symbol? typ) (lst-of? typ symbol?)) - '() - (list (cons typ 'not-a-type)))) - -;------------------------------------------------------------------------------ - -(define (lst-of? lst prdfn) - (if (and (pair? lst) - (prdfn (car lst)) - (if (null? (cdr lst)) #t (lst-of? (cdr lst) prdfn))) - #t #f)) - -(define (form-of-type? frm type) - (and (pair? frm) (eq? (car frm) type))) - -(define (definition? frm) - (or (form-of-type? frm 'def) - (form-of-type? frm 'def:) - (form-of-type? frm 'begin))) - -;------------------------------------------------------------------------------ - -(define error-msgs - '((not-a-def . "Not a recognized definition form") - (not-a-def . "Not a recognized definition form") - ) -) - -;(define (repl port) -; (display ":> ") -; (pretty-print (core-syntax-errors (read port))) -; (repl port)) -; -;(repl (current-input-port)) diff --git a/source/compiler/desugar.scm b/source/compiler/desugar.scm deleted file mode 100644 index e5df8fb..0000000 --- a/source/compiler/desugar.scm +++ /dev/null @@ -1,24 +0,0 @@ -(declare (unit desugar) (uses core-forms)) - -(define (desugar frm) - (if (not (pair? frm)) frm - (case (car frm) - [(def) (desugar-def frm)] - [(begin) (desugar-begin frm)] - [else (map desugar frm)]))) - -(define (desugar-def frm) - (if (and (>= (length frm) 3) (pair? (cadr frm))) - (let* [(args* (cadr frm)) - (name (car args*)) - (args (cdr args*))] - (list 'def name - (append (list 'func args) (cddr frm)))) - (map desugar frm))) - -(define (desugar-begin frm) - (define defs (map desugar (cdr frm))) - (if (not (list-of? defs definition?)) - (list (append (list 'lambda '()) defs)) - (cons 'begin defs))) - diff --git a/source/compiler/main.scm b/source/compiler/main.scm deleted file mode 100644 index d98bba3..0000000 --- a/source/compiler/main.scm +++ /dev/null @@ -1,52 +0,0 @@ -(declare (uses library eval core-forms desugar srfi-13 extras type-inference)) - -;(define compiler-phases -; '(expand-macros ; Expand any user-defined or built-in macros -; desugar ; Desugar to get the core-forms -; validate-syntax ; Validate the syntax of the core-forms -; type-check ; Verify the forms are well-typed -; core->scheme ; Convert to the equivalent scheme output -;)) - -(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 (desugar (read port))) - (if (eof-object? form) - '() - (let [(errs (core-syntax-errors form))] - (if (pair? errs) (begin (pprint-errors errs) (exit 1))) - (print (infer-type form)) - (cons form (read-forms port))))) - -(define (core-form->scheme frm) - (if (and (list? frm) (not (null? frm))) - (case (car frm) - [(def) (cons 'define (map core-form->scheme (cdr frm)))] - [(func) (cons 'lambda (map core-form->scheme (cdr frm)))] - [else (map core-form->scheme frm)]) - frm)) - -(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.")) - diff --git a/source/compiler/type-inference.scm b/source/compiler/type-inference.scm deleted file mode 100644 index d5b72d7..0000000 --- a/source/compiler/type-inference.scm +++ /dev/null @@ -1,236 +0,0 @@ -(declare (unit type-inference) (uses srfi-1)) - -; Type Inference Algorithm -;------------------------------------------------------------------------------ -; This section implements algorithm W from the Luis Damas and Robin Milner -; "Principal type-schemes for functional program". -; The type inference rules have been extended to support more scheme-like -; semantics and uses. - -(define type-env '()) - -(define (infer-type form) - (set! type-env (env-empty)) - (call/cc - (lambda (error-fn) - (set! infer-error error-fn) - (let [(type (algorithm-w (env-empty) form))] - (substitute type-env type))))) - -(define (algorithm-w env form) - (cond [(symbol? form) (get-var-type env form)] - [(not (pair? form)) (get-const-type form)] - [(eq? (car form) 'quote) (get-quoted-const-type form)] - [(eq? (car form) 'if) (infer-cond-type env form)] - [(eq? (car form) 'func) (infer-func-type env form)] - [(eq? (car form) 'def) (infer-def-type env form)] - [else (infer-app-type env form)])) - -(define (get-var-type env form) - (define loc-val (env-value env form)) - (if loc-val - (cadr loc-val) - (instance (env-empty) (env-value global-env form)))) - -(define (get-const-type form) - (cond [(boolean? form) 'Bool] - [(number? form) 'Num] - [(char? form) 'Char] - [(string? form) 'String] - [(pair? form) (get-list-type form)] - [(vector? form) (get-vector-type form)] - [else (type-error form)])) - -(define (get-quoted-const-type form) - (if (equal? form ''()) - '(List ?a) - (get-const-type (cadr form)))) - -(define (get-list-type form) - (let [(type (get-const-type (car form)))] - (for-each (lambda (y) - (if (not (equal? (get-const-type y) type)) - (type-error "list is not homogenous"))) - (cdr form)) - (list 'List type))) - -(define (get-vector-type form) - (set! form (vector->list form)) - (if (null? form) - (list 'Vector '?a) - (let [(type (get-const-type (car form)))] - (for-each (lambda (y) - (if (not (equal? (get-const-type y) type)) - (type-error "vector is not homogenous"))) - (cdr form)) - (list 'Vector type)))) - -(define (infer-cond-type env form) - (let [(cnd (algorithm-w env (cadr form))) - (brt (algorithm-w env (caddr form))) - (brf (algorithm-w env (cadddr form)))] - (set! type-env (unify (unify type-env cnd 'Bool) brt brf)) - brt)) - -(define (infer-func-type env form) - (let* [(parms (map (lambda (x) (new-type-var)) (cadr form))) - (new-env (env-join (map (lambda (x y) (list x 'func y)) (cadr form) parms) env)) - (ext-env (env-join new-env (get-local-var-env new-env (cddr form)))) - (body (map (lambda (expr) (algorithm-w ext-env expr)) - (get-func-body (cddr form))))] - (cons '-> (append parms (list (car (reverse body))))))) - -(define (get-local-var-env env body) - (define defs (filter (lambda (a) (and (pair? a) (eq? (car a) 'def))) - body)) - (map (lambda (a) (list (cadr a) 'func (algorithm-w env (caddr a)))) - defs)) - -(define (get-func-body lst) - (filter (lambda (a) - (or (not (pair? a)) (not (eq? (car a) 'def)))) - lst)) - -(define (infer-def-type env form) - (let* [(name (cadr form)) - (tenv (env-set env name - (if (env-bound? global-env name) - (env-value global-env name) - (list 'def (new-type-var))))) - (type (algorithm-w tenv (caddr form)))] - (if type - (set! global-env (cons (cons name (substitute type-env type)) global-env))) - type)) - -(define (infer-app-type env form) - (let [(result (new-type-var)) - (oper (algorithm-w env (car form))) - (args (map (lambda (x) (algorithm-w env x)) (cdr form)))] - (set! type-env (unify type-env oper (cons '-> (append args (list result))))) - result)) - -; Type Unification Algorithm -;------------------------------------------------------------------------------ -; This section implements a type unification algorithm as described in -; J. A. Robinson's paper "A machine-oriented logic based on the resolution -; principle" - -(define (unify env x y) - (let [(x* (deref env x)) - (y* (deref env y))] - (cond [(eq? x* y*) env] - [(var-and-type? x* y*) (env-set env x* y*)] - [(var-and-type? y* x*) (env-set env y* x*)] - [(and (pair? x*) (pair? y*)) - (unify (unify env (car x*) (car y*)) (cdr x*) (cdr y*))] - [else (type-error x)]))) - -(define (var-and-type? var typ) - (and (type-var? var) - (or (not (type-var? typ)) - (type-var Num Num Num)) - (- . (-> Num Num Num)) - (* . (-> Num Num Num)) - (/ . (-> Num Num Num)) - (> . (-> Num Num Bool)) - (< . (-> Num Num Bool)) - (>= . (-> Num Num Bool)) - (<= . (-> Num Num Bool)) - (= . (-> Num Num Bool)) - ) -) - -(define (env-empty) '()) - -(define (env-set env name type) - (cons (cons name type) env)) - -(define (env-join env1 env2) - (append env1 env2)) - -(define (env-bound? env name) - (let [(type (assq name env))] - (if type #t #f))) - -(define (env-value env name) - (let [(type (assq name env))] - (if type (cdr type) #f))) - -; Type Variable Creation and Usage -;------------------------------------------------------------------------------ -; This section defines a series of functions for creating and comparing type -; variables to be used by the type inference algorithm. - -(define (new-type-var) - (set! type-var-count (+ type-var-count 1)) - (string->symbol (string-append "?" (number->string type-var-count)))) - -(define type-var-count 0) - -(define (type-var? x) - (and (symbol? x) (char=? (string-ref (symbol->string x) 0) #\?))) - -(define (type-varstring x) (symbol->string y))) - -; Error Reporting -;------------------------------------------------------------------------------ -; This section defines a series of functions for reporting specific type errors -; that occur during type inference. - -(define infer-error (lambda (e) e)) - -(define (type-error form) - (print "Type Error: Unable to determine type of expression") - (infer-error #f)) - -;(require 'srfi-1) -;(define (repl port) -; (display ":> ") -; (print (infer-type (read port))) -; (repl port)) -;(repl (current-input-port)) - diff --git a/source/slc/main.scm b/source/slc/main.scm new file mode 100644 index 0000000..5ce0777 --- /dev/null +++ b/source/slc/main.scm @@ -0,0 +1,412 @@ +; Regex Matching Macro +;------------------------------------------------------------------------------ +(use regex ports extras) + +(define-syntax regex-case + (syntax-rules (else) + ((_ item (else result1 result2 ...)) + (begin result1 result2 ...)) + + ((_ item (regex result1 result2 ...)) + (if (string-match regex item) (begin result1 result2 ...))) + + ((_ item (regex result1 result2 ...) clause1 clause2 ...) + (if (string-match regex item) + (begin result1 result2 ...) + (regex-case item clause1 clause2 ...))))) + +; Reader Phase +;------------------------------------------------------------------------------ +; This phase is responsible reading input from a port and constructing the +; expression that the input represents. + +(define (sclpl-read port) + (let [(tok (read-token port))] + (if (eof-object? tok) + tok + (cond [(list-op? tok) (read-sexp port (get-sexp-term tok))] + [(equal? "'" tok) `(quote ,(sclpl-read port))] + [(equal? "`" tok) `(quasiquote ,(sclpl-read port))] + [else (classify-atom tok)])))) + +(define (read-sexp port term) + (define expr (sclpl-read port)) + (cond [(equal? expr term) '()] + [(wrong-term? expr term) (error "Incorrectly matched list terminator")] + [(equal? '|.| expr) (read-and-term port term)] + [else (cons expr (read-sexp port term))])) + + +(define (read-and-term port term) + (define val (sclpl-read port)) + (define tval (sclpl-read port)) + (cond [(member val '(#\) #\] #\})) (error "")] + [(equal? tval term) val] + [(wrong-term? tval term) (error "")] + [else (error "")])) + +(define (classify-atom atom) + (regex-case atom + ["nil" '()] + ["true" #t] + ["false" #f] + ["^\".*\"$" (dequote atom)] + ["^\\\\.+" (atom->char atom)] + ["[{[()\\]}]" (string-ref atom 0)] + ["#[dbox](#[ie])?.+" (or (string->number atom) (string->symbol atom))] + ["[+-]?[0-9].*" (or (string->number atom) (string->symbol atom))] + [else (if (string-literal? atom) + (dequote atom) + (string->symbol atom))])) + +(define (list-op? tok) + (member (string-ref tok 0) '(#\( #\[ #\{))) + +(define (get-sexp-term tok) + (define pairs '((#\( . #\)) (#\[ . #\]) (#\{ . #\}))) + (define term (assv (string-ref tok 0) pairs)) + (if term (cdr term) (error "Not a valid s-expression delimiter"))) + +(define (wrong-term? expr term) + (define terms '(#\) #\] #\})) + (and (not (equal? expr term)) + (member expr terms))) + +(define (string-literal? atom) + (and (char=? #\" (string-ref atom 0)) + (char=? #\" (string-ref atom (- (string-length atom) 1))))) + +(define (dequote str) + (substring str 1 (- (string-length str) 1))) + +(define (atom->char atom) + (define ch-name (substring atom 1)) + (define ch (if (= 1 (string-length ch-name)) + (string-ref ch-name 0) + (char-name (string->symbol ch-name)))) + (or ch (error (string-append "Invalid character name: " ch-name)))) + +;------------------------------------------------------------------------------ + +(define whitespace (string->list " \t\r\n")) +(define punctuation (string->list "()[]{}'`:,")) +(define delimiters (string->list "()[]{}'`:,; \t\r\n")) +(define doublequote '(#\")) + +(define (read-token port) + (define ch (peek-char port)) + (define tok + (cond [(eof-object? ch) ch] + [(member ch whitespace) (consume-whitespace port)] + [(char=? ch #\;) (consume-comment port)] + [(char=? ch #\") (read-till-next #t port doublequote)] + [(member ch punctuation) (string (read-char port))] + [else (read-till-next #f port delimiters)])) + (if (list? tok) (list->string tok) tok)) + +(define (consume-whitespace port) + (if (member (peek-char port) whitespace) + (read-char port)) + (read-token port)) + +(define (consume-comment port) + (if (not (char=? #\newline (peek-char port))) + (begin (read-char port) + (consume-comment port)) + (begin (read-char port) + (read-token port)))) + +(define (read-till-next inc port delims) + (cons (read-char port) + (if (or (member (peek-char port) delims) + (eof-object? (peek-char port))) + (if inc (cons (read-char port) '()) '()) + (read-till-next inc port delims)))) + +; Macro Expansion Phase +;------------------------------------------------------------------------------ +; This phase is responsible for taking the expressions read from the input port +; and performing macro expansion on them to get the resulting expression. + +(define (expand-macros expr) + expr) + +; Desugaring Phase +;------------------------------------------------------------------------------ +; The desugaring phase is responsible for taking user friendly extensions to +; the core SCLPL syntax and deconstructing them into the low-level counterparts +; defined by the "core" SCLPL syntax. This allows the code generator to work on +; a small and well-defined subset of the SCLPL language. + +(define (desugar expr) + (cond [(not (pair? expr)) expr] + [(eqv? 'def (car expr)) (desugar-def expr)] + [(eqv? 'if (car expr)) (desugar-if expr)] + [(eqv? 'fn (car expr)) (append (list 'fn (cadr expr)) + (map desugar (cddr expr)))] + [else (map desugar expr)])) + +(define (desugar-def expr) + (cond [(annotated-def? expr) (desugar-annotated-def expr)] + [(sugared-def? expr) (desugar-sugared-def expr)] + [else (map desugar expr)])) + +(define (annotated-def? expr) + (and (form-structure-valid? 'def >= 4 expr) + (eqv? ': (caddr expr)))) + +(define (sugared-def? expr) + (and (form-structure-valid? 'def >= 2 expr) + (arg-list-valid? (cadr expr)))) + +(define (desugar-annotated-def expr) + (let [(proto (cadr expr)) + (type (cadddr expr)) + (body (cddddr expr))] + (if (pair? proto) + (append `(def (,(car proto) ,type)) + (list (append `(fn ,(cdr proto)) (map desugar body)))) + (append `(def (,proto ,type)) + (map desugar body))))) + +(define (desugar-sugared-def expr) + (if (pair? (cadr expr)) + (append `(def (,(caadr expr) ())) + (list (append `(fn ,(cdadr expr)) (map desugar (cddr expr))))) + (append `(def (,(cadr expr) ())) (map desugar (cddr expr))))) + +(define (desugar-if expr) + (if (form-structure-valid? 'if = 3 expr) + (map desugar (append expr '('()))) + (map desugar expr))) + +; Analysis Phase +;------------------------------------------------------------------------------ +; The analysis phase is responsible for verifying that the provided expression +; conforms to the requirements of the "core" SCLPL syntax. This phase will throw +; an error for any invalid expression or simply return the provided expression +; if it is valid. + +(define (analyze expr) + (if (list? expr) + (analyze-form expr) + expr)) + +(define (analyze-form expr) + (if (null? expr) + (error-msg 'non-atomic expr) + (case (car expr) + [(def) (analyze-def expr)] + [(fn) (analyze-fn expr)] + [(if) (validate-and-analyze 'if = 4 expr)] + [(do) (validate-and-analyze 'do >= 1 expr)] + [(quote) (validate-and-analyze 'quote = 2 expr)] + [else (map analyze expr)]))) + +(define (analyze-def expr) + (validate-form 'def = 3 expr) + (validate-signature (cadr expr)) + expr) + +(define (analyze-fn expr) + (if (and (form-structure-valid? 'fn >= 3 expr) + (arg-list-valid? (cadr expr))) + (append (list 'fn (cadr expr)) + (map analyze (cddr expr))) + (error-msg 'invalid-fn expr))) + +(define (validate-and-analyze type cmpop nargs expr) + (validate-form type cmpop nargs expr) + (map analyze expr)) + +(define (validate-form type cmpop nargs expr) + (cond [(not (pair? expr)) (error-msg 'not-an-sexp expr)] + [(not (eqv? type (car expr))) (error-msg 'wrong-form-type expr)] + [(not (cmpop (length expr) nargs)) (error-msg 'num-args expr)])) + +(define (validate-signature sig) + (cond [(not (list? sig)) (error-msg 'sig-not-list sig)] + [(not (= 2 (length sig))) (error-msg 'sig-num-entries sig)] + [(not (variable? (car sig))) (error-msg 'sig-variable sig)] + ;[(not (type? (cadr sig))) (error-msg 'expect-type sig)])) + )) + +; Type Checking Phase +;------------------------------------------------------------------------------ +; This phase is responsible for performing type reconstruction and verifying +; that the expression is well-typed before being passed to the optimization and +; compilation phases + +(define (check-type expr env) + expr) + +; CPS-Conversion Phase +;------------------------------------------------------------------------------ +; This phase translates the fully macro-expanded, desugared, and analyzed +; program into continuation-passing style so various optimizations can be +; performed before code is generated. + +(define (cps-convert expr) + expr) + +; SCLPL to Scheme Phase +;------------------------------------------------------------------------------ + +(define (sclpl->scheme expr) + expr) + +; Error Messages +;------------------------------------------------------------------------------ +(define (error-msg type expr . args) + (let [(handler (assoc type error-handlers))] + (if handler (apply (cdr handler) args) (apply unknown-error args)) + (log-msg (with-output-to-string (lambda () (pretty-print expr)))) + (fail expr))) + +(define (non-atomic-expr) + (log-msg "Error: Illegal non-atomic object")) + +(define (invalid-fn) + (log-msg "Error: Invalid function form")) + +(define (not-an-sexpr) + (log-msg "Error: Not an s-expression")) + +(define (wrong-form-type) + (log-msg "Error: Incorrect form type")) + +(define (wrong-num-args) + (log-msg "Error: Incorrect number of args for form")) + +(define (sig-is-not-a-list) + (log-msg "Error: Function signature is not a list")) + +(define (wrong-num-sig-parts) + (log-msg "Error: Function signature has incorrect number of parts")) + +(define (sig-name-not-var) + (log-msg "Error: Name part of function signature is not a variable")) + +(define (expected-:) + (log-msg "Error: Expected a :")) + +(define (unknown-error . args) + (log-msg "Error: Unknown error occurred in the following expression")) + +(define error-handlers + `((non-atomic . ,non-atomic-expr) + (invalid-fn . ,invalid-fn) + (not-an-sexp . ,not-an-sexpr) + (wrong-form-type . ,wrong-form-type) + (num-args . ,wrong-num-args) + (sig-not-list . ,sig-is-not-a-list) + (sig-num-entries . ,wrong-num-sig-parts) + (sig-variable . ,sig-name-not-var) + (expect-: . ,expected-:))) + +; Helper Predicates +;------------------------------------------------------------------------------ +; This collection of predicate functions is used to assist the earlier phases +; when dealing with similar data-structures. + +(define (form-structure-valid? type cmpop nargs expr) + (and (pair? expr) + (eqv? type (car expr)) + (cmpop (length expr) nargs))) + +(define (arg-list-valid? arglst) + (or (variable? arglst) + (and (or (list? arglst) (pair? arglst)) + (list-of? variable? arglst)))) + +(define (list-of? type lst) + (if (null? lst) #t + (if (type (car lst)) + (if (type (cdr lst)) #t (list-of? type (cdr lst))) + #f))) + +(define (variable? sym) + (and (symbol? sym) + (not (type-name? sym)) + (not (type-var? sym)))) + +(define (atomic-base-type? type) + (if (member type '(Any Number Symbol String Char Bool)) #t #f)) + +(define (type? expr) + (cond [(null? expr) #f] + [(member '-> expr) (fn-type? expr)] + [(list? expr) (and (> (length expr) 1) + (apply list-and? (map type? expr)))] + [else (or (type-name? expr) (type-var? expr))])) + +(define (type-name? sym) + (and (symbol? sym) + (let [(ch (string-ref (symbol->string sym) 0))] + (and (char>=? ch #\A) (char<=? ch #\Z))))) + +(define (type-var? sym) + (and (symbol? sym) + (let [(ch (string-ref (symbol->string sym) 0))] + (char=? ch #\?)))) + +(define (fn-type? expr) + (define (is-fn-type? prev expr) + (if (null? expr) #t + (case (car expr) + [(...) (and (type? prev) + (>= (length (cdr expr)) 1) + (equal? '-> (cadr expr)) + (is-fn-type? #f (cdr expr)))] + [(->) (and (= 2 (length expr)) + (is-fn-type? (car expr) (cdr expr)))] + [else (and (type? (car expr)) + (is-fn-type? (car expr) (cdr expr)))]))) + (is-fn-type? #f expr)) + +(define (list-and? . args) + (if (null? args) #t (and (car args) (apply list-and? (cdr args))))) + +; Main +;------------------------------------------------------------------------------ + +(define fail error) + +(define log-msg (lambda args '())) + +;(define (print-data . args) +; (apply print +; (map (lambda (e) +; (if (string? e) +; e +; (with-output-to-string (lambda () (pretty-print e))))) +; args))) + +;(define (interpret port) +; (call/cc (lambda (k) +; (set! fail k) +; (set! log-msg print) +; (display (string-append ":" (sexp-count) "> ")) +; ; Read and type and analyze all expressions from input +; (define expr (sclpl-read port)) +; (print-data "Read Phase: \n" expr) +; (set! expr (expand-macros expr)) +; (print-data "Macro Expansion Phase: \n" expr) +; (set! expr (desugar expr)) +; (print-data "Desugar Phase: \n" expr) +; (set! expr (analyze expr)) +; (print-data "Analysis Phase: \n" expr))) +; (interpret port)) +;(interpret (current-input-port)) +;(exit) + +(define (read-program port) + (define expr (sclpl-read port)) + (if (eof-object? expr) + '() + (cons (analyze (desugar (expand-macros expr))) + (read-program port)))) + +(print (read-program (current-input-port))) + + -- 2.49.0