# 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 ):
# 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 })
# 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',
+++ /dev/null
-(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))
+++ /dev/null
-(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)))
-
+++ /dev/null
-(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."))
-
+++ /dev/null
-(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<? typ var))))
-
-(define (deref env var)
- (if (and (type-var? var) (env-bound? env var))
- (deref env (env-value env var))
- var))
-
-(define (substitute env x)
- (cond [(type-var? x) (let [(y (deref env x))]
- (if (type-var? y) y (substitute env y)))]
- [(pair? x) (cons (substitute env (car x))
- (substitute env (cdr x)))]
- [else x]))
-
-(define (instance prefix x) ; generate an instance of x with new variables
- (define (new x env success) ; in place of the generic variables in prefix
- (cond [(and (type-var? x) (generic? x prefix))
- (if (env-bound? x env)
- (success (env-value x env) env)
- (let ((var (new-type-var)))
- (success var (env-set env x var))))]
- [(pair? x)
- (new (car x) env
- (lambda (a env)
- (new (cdr x) env
- (lambda (b env)
- (success (cons a b) env)))))]
- [else
- (success x env)]))
- (new x (env-empty) (lambda (a env) a)))
-
-(define (generic? var prefix)
- (cond [(null? prefix) #t]
- [(eq? (cadar prefix) var) #f]
- [else (generic? var (cdr prefix))]))
-
-; Environment Manipulation
-;------------------------------------------------------------------------------
-; This section defines a default environment and a variety of environment
-; manipulation functions that will be used by the type inference algorithm.
-
-(define global-env
- '(
- (+ . (-> 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-var<? x y)
- (string<? (symbol->string 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))
-
--- /dev/null
+; 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)))
+
+
projects / proto / sclpl.git / commitdiff