From dc592c03cd56a8d93b28580c35503e311657388f Mon Sep 17 00:00:00 2001 From: admin Date: Fri, 29 Sep 2023 20:58:01 +0900 Subject: [PATCH] Cleanup and add some docstrings --- compile-tree-il.scm | 8 ++++---- curry-tests.scm | 6 +++--- curry.scm | 45 +++++++++++++++++++++++++++++++++---------- decompile-tree-il.scm | 2 +- misc.scm | 2 +- spec.scm | 14 +++++++------- 6 files changed, 51 insertions(+), 26 deletions(-) diff --git a/compile-tree-il.scm b/compile-tree-il.scm index 2884d9c..9b1dfc6 100644 --- a/compile-tree-il.scm +++ b/compile-tree-il.scm @@ -22,10 +22,10 @@ ;;; 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 @@ -34,9 +34,9 @@ (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)))))) diff --git a/curry-tests.scm b/curry-tests.scm index b51ca02..87c4144 100644 --- a/curry-tests.scm +++ b/curry-tests.scm @@ -1,5 +1,5 @@ -(define-module (vdc curry tests) - #:use-module (vdc curry) +(define-module (vouivre curry tests) + #:use-module (vouivre curry) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (srfi srfi-71)) @@ -19,7 +19,7 @@ (define (sym-sets symtab alist) (fold (lambda (x prev) - ((@@ (vdc curry) sym-set) prev (car x) (cdr x))) + ((@@ (vouivre curry) sym-set) prev (car x) (cdr x))) symtab alist)) (let ((t e (expand '() '(λc x x)))) diff --git a/curry.scm b/curry.scm index 117e9f5..f5659fb 100644 --- a/curry.scm +++ b/curry.scm @@ -1,4 +1,4 @@ -(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) @@ -6,7 +6,7 @@ #: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? @@ -33,11 +33,14 @@ (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 () @@ -45,6 +48,7 @@ (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)) @@ -52,6 +56,7 @@ (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 @@ -61,6 +66,7 @@ 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'. @@ -216,23 +222,28 @@ (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) @@ -241,6 +252,9 @@ 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 @@ -259,6 +273,10 @@ `(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) @@ -284,9 +302,9 @@ (values #f `(begin - ((@@ (vdc curry) ∷%) + ((@@ (vouivre curry) ∷%) ',name - ((@ (vdc curry) parse) + ((@ (vouivre curry) parse) ',(bare-type t))) (define ,name ,e))))))) ((f) @@ -322,6 +340,7 @@ x)))) (define (bare-type x) + "Return a type as tree s-expression without nodes." (and=> x (lambda (node) @@ -331,9 +350,11 @@ (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 @@ -344,10 +365,10 @@ ((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 @@ -370,6 +391,7 @@ (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))) @@ -419,5 +441,8 @@ (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~%"))) diff --git a/decompile-tree-il.scm b/decompile-tree-il.scm index b9a177d..153bcd2 100644 --- a/decompile-tree-il.scm +++ b/decompile-tree-il.scm @@ -22,7 +22,7 @@ ;;; Code: -(define-module (language vdc decompile-tree-il) +(define-module (language vouivre decompile-tree-il) #:use-module (language tree-il) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/misc.scm b/misc.scm index efbaa78..aee2fed 100644 --- a/misc.scm +++ b/misc.scm @@ -1,4 +1,4 @@ -(define-module (vdc misc) +(define-module (vouivre misc) #:export (if-let)) diff --git a/spec.scm b/spec.scm index abf2777..a07f7c1 100644 --- a/spec.scm +++ b/spec.scm @@ -22,20 +22,20 @@ ;;; 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? -- 2.39.2