;;; Code:
-(define-module (language vdc compile-tree-il)
+(define-module (language vouivre compile-tree-il)
#:use-module (language tree-il)
#:use-module (srfi srfi-71)
- #:use-module (vdc curry)
+ #:use-module (vouivre curry)
#:export (compile-tree-il))
;;; environment := MODULE
(save-module-excursion
(lambda ()
(set-current-module e)
- ;; TODO: Why do we need to use `(@@ (vdc curry) symtab)' here instead of
+ ;; TODO: Why do we need to use `(@@ (vouivre curry) symtab)' here instead of
;; simply `symtab'? If we don't it always return an empty symtab.
- (let ((t expr (expand (@@ (vdc curry) symtab) (syntax->datum x))))
+ (let ((t expr (expand (@@ (vouivre curry) symtab) (syntax->datum x))))
(let* ((x (macroexpand expr 'c '(compile load eval)))
(cenv (current-module)))
(values x cenv cenv))))))
-(define-module (vdc curry)
+(define-module (vouivre curry)
#:use-module ((ice-9 curried-definitions) :prefix c)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-64)
#:use-module (srfi srfi-71)
- #:use-module (vdc misc)
+ #:use-module (vouivre misc)
#:export
(curried-untyped-define
equal-types?
(apply error "type error" (assoc-ref errors n) args)))
(define (zo? x)
+ "Predicate for the zero type."
(and (number? x) (zero? x)))
(define (tv? x)
+ "Predicate for type variables."
(and (number? x) (positive? x) #t))
+;; Return a unique type variable.
(define next
(let ((count 1))
(lambda ()
(1- count))))
(define (copy-tree node)
+ "Return a copy of the tree rooted in `node'."
(let ((x (node-content node)))
(if (pair? x)
(make-node (cons (copy-tree (car x))
(make-node x))))
(define (map-tree! proc nx)
+ "Map `proc' in-place over the content of the leaves of `nx'."
(let ((x (node-content nx)))
(if (pair? x)
(begin
nx))
(define (compare nx ny)
+ ""
(define (create-reduxtab m)
;; Each `x' point (through `mx') to a list `ys' of elements `y' who
;; themselves point (through `my') to lists of things equal to `x'.
(type-error 2 nx ny)))))
(define (var-list? lst)
+ "Predicate for valid macro variable lists."
(and (every symbol? lst)
(equal? lst (delete-duplicates lst))))
(define (sym-set! symtab name value)
+ "Associate a type to a symbol in a symtab."
(let ((m (module-name (current-module))))
(assoc-set! symtab m
(assoc-set! (or (assoc-ref symtab m) '())
name value))))
(define (sym-set symtab sym value)
+ "Like `sym-set!' but returns a copy of the symtab."
(sym-set! (alist-copy symtab) sym value))
(define (sym-ref symtab name)
+ "Reference a symbol in a symtab returning its type."
(let ((m (module-name (current-module))))
(assoc-ref (or (assoc-ref symtab m) '()) name)))
(define (populate-tvs! node)
+ "Add (in-place) new type variables to empty nodes of a tree."
(map-tree!
(lambda (x)
(if (not x)
node))
(define (expand symtab expr)
+ "Type check an expression returning two values: its resulting type and an
+expansion where all applications of symbols present in the symtab are curried.
+Raise a type error if the expression is invalid."
(match expr
(('quote x)
(values
`(lambda (,var) ,bodye)))))
(('letrecc1 ((? symbol? name) expr) body)
(type-error 0 'letrecc1 name expr body))
+ (('cudefine name-vars body ..1)
+ (values
+ #f
+ `(cudefine ,name-vars ,@body)))
(('definec (? (lambda (x)
(and
(pair? x)
(values
#f
`(begin
- ((@@ (vdc curry) ∷%)
+ ((@@ (vouivre curry) ∷%)
',name
- ((@ (vdc curry) parse)
+ ((@ (vouivre curry) parse)
',(bare-type t)))
(define ,name ,e)))))))
((f)
x))))
(define (bare-type x)
+ "Return a type as tree s-expression without nodes."
(and=>
x
(lambda (node)
(cons (bare-type (car x)) (bare-type (cdr x))))
(else x))))))
-(define (pt node)
+(define* (pt node #:optional (port current-output-port))
+ "Print a tree to the given port in a cons cell format with '?' for empty
+nodes."
(format
- #t "~a~%"
+ port "~a~%"
(let pt% ((nx node))
(let ((x (node-content nx)))
(cond
((pair? x)
(format #f "(~a . ~a)"
(pt% (car x))
- (pt% (cdr x))))))))
- (values))
+ (pt% (cdr x)))))))))
(define (parse x)
+ "Parse a type from its cons cells representation to a tree."
(if (not x)
#f
(second
(list (first b) (make-node (cons (second a) (second b)))))))))))
(define (equal-types? ta tb)
+ "Check the equality of two types."
(define (equal-types?% ta tb correspondances)
(let ((a (node-content ta))
(b (node-content tb)))
(define-syntax-rule (∷ name type)
(∷% 'name (parse 'type)))
-(define (type-of x)
- (pt (sym-ref symtab x)))
+(define* (type-of x #:optional port)
+ "Print the type of a declared symbol to the given port."
+ (if-let (x (expand symtab x))
+ (pt x port)
+ (format port "#f~%")))
;;; Code:
-(define-module (language vdc spec)
+(define-module (language vouivre spec)
#:use-module (system base compile)
#:use-module (system base language)
- #:use-module (language vdc compile-tree-il)
- #:use-module (language vdc decompile-tree-il)
- #:use-module (vdc curry)
- #:export (vdc))
+ #:use-module (language vouivre compile-tree-il)
+ #:use-module (language vouivre decompile-tree-il)
+ #:use-module (vouivre curry)
+ #:export (vouivre))
;;;
;;; Language definition
;;;
-(define-language vdc
- #:title "VDC"
+(define-language vouivre
+ #:title "Vouivre"
#:reader (lambda (port env)
;; Use the binding of current-reader from the environment.
;; FIXME: Handle `read-options' as well?
projects / vouivre.git / commitdiff