Merge branch 'ast3-dev'

CHANGELOG.md

@@ -2,6 +2,16 @@
 
 ## 0.9.3 - TBD 
 
+Features
+
+- Allow pretty printing of bytevectors.
+- Internal change to the compiler - preserve lambda AST forms throughout compilation process. This should make it easier to implement certain optimizations in future releases.
+
+Bug Fixes
+
+- Fix `input-port?`, `output-port?`, `input-port-open?`, and `output-port-open?` to return `#f` instead of raising an error when a non-port object is passed.
+- Fix overflow detection when performing fixnum multiplication to avoid undefined behavior in the C runtime.
+
 ## 0.9.2 - August 26, 2018
 
 Features

cyclone.scm

@@ -432,7 +432,7 @@
             (wrap-mutables expr globals))
           input-program))
       (trace:info "---------------- after wrap-mutables:")
-      (trace:info input-program) ;pretty-print
+      (trace:info (ast:ast->pp-sexp input-program))
     
       (set! input-program 
         (map
@@ -441,17 +441,15 @@
              ((define? expr)
               ;; Global
               `(define ,(define->var expr)
-                 ,@(caddr (closure-convert (define->exp expr) globals *optimization-level*))))
+                 ,@(car (ast:lambda-body (closure-convert (define->exp expr) globals *optimization-level*)))))
              ((define-c? expr)
               expr)
              (else
-              (caddr ;; Strip off superfluous lambda
+              (car (ast:lambda-body ;; Strip off superfluous lambda
-                (closure-convert expr globals *optimization-level*)))))
+                (closure-convert expr globals *optimization-level*))))))
           input-program))
-    ;    (caddr ;; Strip off superfluous lambda
-    ;      (closure-convert input-program)))
       (trace:info "---------------- after closure-convert:")
-      (trace:info input-program) ;pretty-print
+      (trace:info (ast:ast->pp-sexp input-program))
       
       (when (not *do-code-gen*)
         (trace:error "DEBUG, existing program")

scheme/base.sld

@@ -1360,7 +1360,9 @@
   (define-c input-port?
     "(void *data, int argc, closure _, object k, object port)"
     " port_type *p = (port_type *)port;
-      Cyc_check_port(data, port);
+      if (boolean_f == Cyc_is_port(port)) {
+        return_closcall1(data, k, boolean_f);
+      }
       return_closcall1(
         data, 
         k, 
@@ -1368,7 +1370,9 @@
   (define-c output-port?
     "(void *data, int argc, closure _, object k, object port)"
     " port_type *p = (port_type *)port;
-      Cyc_check_port(data, port);
+      if (boolean_f == Cyc_is_port(port)) {
+        return_closcall1(data, k, boolean_f);
+      }
       return_closcall1(
         data, 
         k, 
@@ -1376,7 +1380,9 @@
   (define-c input-port-open?
     "(void *data, int argc, closure _, object k, object port)"
     " port_type *p = (port_type *)port;
-      Cyc_check_port(data, port);
+      if (boolean_f == Cyc_is_port(port)) {
+        return_closcall1(data, k, boolean_f);
+      }
       return_closcall1(
         data, 
         k, 
@@ -1384,7 +1390,9 @@
   (define-c output-port-open?
     "(void *data, int argc, closure _, object k, object port)"
     " port_type *p = (port_type *)port;
-      Cyc_check_port(data, port);
+      if (boolean_f == Cyc_is_port(port)) {
+        return_closcall1(data, k, boolean_f);
+      }
       return_closcall1(
         data, 
         k, 

scheme/cyclone/cgen.sld

@@ -312,6 +312,11 @@
 ;;              require CPS, so this flag is not applicable to them.
 (define (c-compile-exp exp append-preamble cont trace cps?)
   (cond
+    ; Special case - global function w/out a closure. Create an empty closure
+    ((ast:lambda? exp)
+     (c-compile-exp
+      `(%closure ,exp)
+       append-preamble cont trace cps?))
     ; Core forms:
     ((const? exp)       (c-compile-const exp))
     ((prim?  exp)       
@@ -329,11 +334,6 @@
      (c-compile-global exp append-preamble cont trace))
     ((define-c? exp)
      (c-compile-raw-global-lambda exp append-preamble cont trace))
-    ; Special case - global function w/out a closure. Create an empty closure
-    ((tagged-list? 'lambda exp)
-     (c-compile-exp
-      `(%closure ,exp)
-       append-preamble cont trace cps?))
     
     ; Application:      
     ((app? exp)         (c-compile-app exp append-preamble cont trace cps?))
@@ -717,6 +717,28 @@
     (let* ((args     (app->args exp))
            (fun      (app->fun exp)))
       (cond
+        ((ast:lambda? fun)
+         (let* ((lid (allocate-lambda (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures
+                                                               ;; properly, wait until this comes up in an example
+                (this-cont (string-append "__lambda_" (number->string lid)))
+                (cgen 
+                  (c-compile-args
+                     args 
+                     append-preamble 
+                     ""
+                     this-cont
+                     trace
+                     cps?))
+                (num-cargs (c:num-args cgen)))
+           (set-c-call-arity! num-cargs)
+           (c-code
+             (string-append
+               (c:allocs->str (c:allocs cgen))
+               "return_direct" (number->string num-cargs) 
+               "(data," this-cont
+               (if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
+                  (c:body cgen) ");"))))
+
         ;; Direct recursive call of top-level function
         ((and (pair? trace)
               (not (null? (cdr trace)))
@@ -770,28 +792,6 @@
                "goto loop;")))
         )
          
-        ((lambda? fun)
-         (let* ((lid (allocate-lambda (c-compile-lambda fun trace #t))) ;; TODO: pass in free vars? may be needed to track closures
-                                                               ;; properly, wait until this comes up in an example
-                (this-cont (string-append "__lambda_" (number->string lid)))
-                (cgen 
-                  (c-compile-args
-                     args 
-                     append-preamble 
-                     ""
-                     this-cont
-                     trace
-                     cps?))
-                (num-cargs (c:num-args cgen)))
-           (set-c-call-arity! num-cargs)
-           (c-code
-             (string-append
-               (c:allocs->str (c:allocs cgen))
-               "return_direct" (number->string num-cargs) 
-               "(data," this-cont
-               (if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " "
-                  (c:body cgen) ");"))))
-
         ((prim? fun)
          (let* ((c-fun 
                  (c-compile-prim fun cont))
@@ -967,7 +967,7 @@
                  (car (define->exp exp)))))
    (add-global 
      var 
-     (lambda? body) 
+     (ast:lambda? body) 
      (c-compile-exp 
       body append-preamble cont
       (st:add-function! trace var) #t))
@@ -978,7 +978,7 @@
 ;           ,(define-c->inline-var exp)
 ;           ,(prim:udf? (define-c->inline-var exp))
 ;           ))
-   (when (and (lambda? body)
+   (when (and (ast:lambda? body)
               (prim:udf? (define-c->inline-var exp)))
        (add-global-inline 
          var
@@ -1075,6 +1075,10 @@
 (define lambdas '())
 (define inline-lambdas '())
 
+;; TODO: may need to pass in AST lambda ID and store a mapping
+;;       of cgen lambda ID to it, in order to use data from the 
+;;       analysis DB later on during code generation.
+;;
 ; allocate-lambda : (string -> string) -> lambda-id
 (define (allocate-lambda lam . cps?)
   (let ((id num-lambdas))
@@ -1089,7 +1093,7 @@
 ;  (cdr (assv id lambdas)))
 
 (define (lambda->env exp)
-    (let ((formals (lambda-formals->list exp)))
+    (let ((formals (ast:lambda-formals->list exp)))
         (if (pair? formals)
             (car formals)
             'unused)))
@@ -1108,15 +1112,27 @@
 ;; Note this must be the count before additional closure/CPS arguments
 ;; are added, so we need to detect those and not include them.
 (define (compute-num-args lam)
-  (let ((count (lambda-num-args lam))) ;; Current arg count, may be too high
+  (let ((count (ast:lambda-num-args lam))) ;; Current arg count, may be too high
     (cond
       ((< count 0) -1) ;; Unlimited
       (else
-        (let ((formals (lambda-formals->list lam)))
+        (let ((formals (ast:lambda-formals->list lam)))
           (- count
              (if (fl/closure? formals) 1 0)
              (if (fl/cont? formals) 1 0)))))))
 
+;; Minimum number of required arguments for a lambda
+(define (ast:lambda-num-args exp)
+  (let ((type (ast:lambda-formals-type exp))
+        (num (length (ast:lambda-formals->list exp))))
+    (cond
+      ((equal? type 'args:varargs)
+       -1) ;; Unlimited
+      ((equal? type 'args:fixed-with-varargs)
+       (- num 1)) ;; Last arg is optional
+      (else
+        num))))
+
 ;; Formal list with a closure?
 (define (fl/closure? lis)
   (cond
@@ -1254,13 +1270,13 @@
     (let* ((formals (c-compile-formals 
                       (if (not cps?)
                           ;; Ignore continuation (k) arg for non-CPS funcs
-                          (cdr (lambda->formals exp))
+                          (cdr (ast:lambda-args exp))
-                          (lambda->formals exp))
+                          (ast:lambda-args exp))
-                      (lambda-formals-type exp)))
+                      (ast:lambda-formals-type exp)))
-           (tmp-ident (if (> (length (lambda-formals->list exp)) 0) 
+           (tmp-ident (if (> (length (ast:lambda-formals->list exp)) 0) 
-                          (mangle (if (pair? (lambda->formals exp))
+                          (mangle (if (pair? (ast:lambda-args exp))
-                                      (car (lambda->formals exp))
+                                      (car (ast:lambda-args exp))
-                                      (lambda->formals exp)))
+                                      (ast:lambda-args exp)))
                           ""))
            (return-type
             (if cps? "void" "object"))
@@ -1288,7 +1304,7 @@
                 formals))
            (env-closure (lambda->env exp))
            (body    (c-compile-exp     
-                        (car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS
+                        (car (ast:lambda-body exp)) ;; car ==> assume single expr in lambda body after CPS
                         append-preamble
                         (mangle env-closure)
                         trace 
@@ -1300,18 +1316,18 @@
                         formals*
                        ") {\n"
                        preamble
-                       (if (lambda-varargs? exp)
+                       (if (ast:lambda-varargs? exp)
                          ;; Load varargs from C stack into Scheme list
                          (string-append 
                            ; DEBUGGING:
                            ;"printf(\"%d %d\\n\", argc, " 
-                           ;  (number->string (length (lambda-formals->list exp))) ");"
+                           ;  (number->string (length (ast:lambda-formals->list exp))) ");"
                            "load_varargs(" 
-                           (mangle (lambda-varargs-var exp))
+                           (mangle (ast:lambda-varargs-var exp))
                            ", "
-                           (mangle (lambda-varargs-var exp))
+                           (mangle (ast:lambda-varargs-var exp))
                            "_raw, argc - " (number->string 
-                                         (- (length (lambda-formals->list exp)) 
+                                         (- (length (ast:lambda-formals->list exp)) 
                                             1
                                             (if has-closure? 1 0)))
                            ");\n");
@@ -1337,6 +1353,18 @@
   
 (define cgen:mangle-global #f)
 
+(define (ast:lambda-varargs-var exp)
+  (if (ast:lambda-varargs? exp)
+    (if (equal? (ast:lambda-formals-type exp) 'args:varargs)
+        (ast:lambda-args exp) ; take symbol directly
+        (car (reverse (ast:lambda-formals->list exp)))) ; Last arg is varargs
+    #f))
+
+(define (ast:lambda-varargs? exp)
+  (let ((type (ast:lambda-formals-type exp)))
+    (or (equal? type 'args:varargs)
+        (equal? type 'args:fixed-with-varargs))))
+
 ;; Convert a library name to string, so it can be 
 ;; appended to the identifiers it exports.
 (define (import->string import)

scheme/cyclone/cps-optimizations.sld

@@ -1573,7 +1573,26 @@
 (define (_closure-convert exp globals optimization-level)
  (define (convert exp self-var free-var-lst)
   (define (cc exp)
+;(trace:error `(cc ,exp))
    (cond
+    ((ast:lambda? exp)
+     (let* ((new-self-var (gensym 'self))
+            (body  (ast:lambda-body exp))
+            (new-free-vars 
+              (difference 
+                (difference (free-vars body) (ast:lambda-formals->list exp))
+                globals)))
+       `(%closure
+          ,(ast:%make-lambda
+             (ast:lambda-id exp)
+             (list->lambda-formals
+               (cons new-self-var (ast:lambda-formals->list exp))
+               (ast:lambda-formals-type exp))
+             (list (convert (car body) new-self-var new-free-vars))
+             (ast:lambda-has-cont exp))
+          ,@(map (lambda (v) ;; TODO: splice here?
+                    (cc v))
+            new-free-vars))))
     ((const? exp)        exp)
     ((quote? exp)        exp)
     ((ref? exp)
@@ -1591,22 +1610,7 @@
           ,@(map cc (cdr exp)))) ;; TODO: need to splice?
     ((set!? exp)  `(set! ,(set!->var exp)
                          ,(cc (set!->exp exp))))
-    ((lambda? exp)
+    ((lambda? exp)   (error `(Unexpected lambda in closure-convert ,exp)))
-     (let* ((new-self-var (gensym 'self))
-            (body  (lambda->exp exp))
-            (new-free-vars 
-              (difference 
-                (difference (free-vars body) (lambda-formals->list exp))
-                globals)))
-       `(%closure
-          (lambda
-            ,(list->lambda-formals
-               (cons new-self-var (lambda-formals->list exp))
-               (lambda-formals-type exp))
-            ,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc.
-          ,@(map (lambda (v) ;; TODO: splice here?
-                    (cc v))
-            new-free-vars))))
     ((if? exp)  `(if ,@(map cc (cdr exp))))
     ((cell? exp)       `(cell ,(cc (cell->value exp))))
     ((cell-get? exp)   `(cell-get ,(cc (cell-get->cell exp))))
@@ -1616,16 +1620,16 @@
      (let ((fn (car exp))
            (args (map cc (cdr exp))))
        (cond
-         ((lambda? fn)
+         ((ast:lambda? fn)
           (cond
             ;; If the lambda argument is not used, flag so the C code is 
             ;; all generated within the same function
             ((and #f
                   (> optimization-level 0)
-                  (eq? (lambda-formals-type fn) 'args:fixed)
+                  (eq? (ast:lambda-formals-type fn) 'args:fixed)
-                  (pair? (lambda-formals->list fn))
+                  (pair? (ast:lambda-formals->list fn))
                   (with-var 
-                    (car (lambda-formals->list fn))
+                    (car (ast:lambda-formals->list fn))
                     (lambda (var)
                       (zero? (adbv:ref-count var))))
                   ;; Non-CPS args
@@ -1638,30 +1642,40 @@
                     args))
              `(Cyc-seq
                ,@args
-               ,@(map cc (lambda->exp fn))))
+               ,@(map cc (ast:lambda-body fn))))
             (else
-              (let* ((body  (lambda->exp fn))
+              (let* ((body  (ast:lambda-body fn))
                      (new-free-vars 
                        (difference
-                         (difference (free-vars body) (lambda-formals->list fn))
+                         (difference (free-vars body) (ast:lambda-formals->list fn))
                          globals))
                      (new-free-vars? (> (length new-free-vars) 0)))
                   (if new-free-vars?
                     ; Free vars, create a closure for them
                     (let* ((new-self-var (gensym 'self)))
                       `((%closure 
-                           (lambda
+                          ,(ast:%make-lambda
-                             ,(list->lambda-formals
+                             (ast:lambda-id fn)
-                                (cons new-self-var (lambda-formals->list fn))
+                             (list->lambda-formals
-                                (lambda-formals-type fn))
+                                (cons new-self-var (ast:lambda-formals->list fn))
-                             ,(convert (car body) new-self-var new-free-vars))
+                                (ast:lambda-formals-type fn))
+                             (list (convert (car body) new-self-var new-free-vars))
+                             (ast:lambda-has-cont fn)
+                           )
                            ,@(map (lambda (v) (cc v))
                                   new-free-vars))
                         ,@args))
                     ; No free vars, just create simple lambda
-                    `((lambda ,(lambda->formals fn)
+                    `(,(ast:%make-lambda 
-                              ,@(map cc body))
+                         (ast:lambda-id fn)
-                      ,@args))))))
+                         (ast:lambda-args fn)
+                         (map cc body)
+                         (ast:lambda-has-cont fn)
+                       )
+                      ,@args)
+                    
+                    )))))
+         ((lambda? fn)   (error `(Unexpected lambda in closure-convert ,exp)))
          (else
            (let ((f (cc fn)))
             `((%closure-ref ,f 0)
@@ -1671,8 +1685,10 @@
       (error "unhandled exp: " exp))))
   (cc exp))
 
- `(lambda ()
+ (ast:make-lambda
-    ,(convert exp #f '())))
+   (list)
+   (list (convert exp #f '()))
+   #f))
 
 (define (analyze:find-named-lets exp)
   (define (scan exp lp)

scheme/cyclone/pretty-print.sld

@@ -84,6 +84,9 @@
           (cond ((pair? obj)        (wr-expr obj col))
                 ((null? obj)        (wr-lst obj col))
                 ((vector? obj)      (wr-lst (vector->list obj) (out "#" col)))
+                ((bytevector? obj)  (wr-lst 
+                                      (map char->integer (string->list (utf8->string obj)))
+                                      (out "#u8" col)))
                 ((boolean? obj)     (out (if obj "#t" "#f") col))
                 ((number? obj)      (out (number->string obj) col))
                 ((symbol? obj)      (out (symbol->string obj) col))

scheme/cyclone/transforms.sld

@@ -630,6 +630,9 @@
   (define (search exp)
     (cond
       ; Core forms:
+      ((ast:lambda? exp)
+        (difference (reduce union (map search (ast:lambda-body exp)) '())
+                    (ast:lambda-formals->list exp)))
       ((const? exp)    '())
       ((prim? exp)     '())    
       ((quote? exp)    '())    
@@ -726,22 +729,34 @@
 ; wrap-mutables : exp -> exp
 (define (wrap-mutables exp globals)
   
-  (define (wrap-mutable-formals formals body-exp)
+  (define (wrap-mutable-formals id formals body-exp has-cont)
     (if (not (pair? formals))
         body-exp
+        ;(list body-exp)
         (if (is-mutable? (car formals))
-            `((lambda (,(car formals))
+            (list
-                ,(wrap-mutable-formals (cdr formals) body-exp))
+              (list ;(ast:%make-lambda
-              (cell ,(car formals)))
+                    ;  id
-            (wrap-mutable-formals (cdr formals) body-exp))))
+                    (ast:make-lambda
+                      (list (car formals))
+                      (wrap-mutable-formals id (cdr formals) body-exp has-cont)
+                      has-cont)
+                    `(cell ,(car formals))))
+            (wrap-mutable-formals id (cdr formals) body-exp has-cont))))
   
   (cond
     ; Core forms:
     ((ast:lambda? exp)
-     `(lambda ,(ast:lambda-args exp)
+     (ast:%make-lambda
-       ,(wrap-mutable-formals 
+       (ast:lambda-id exp)
+       (ast:lambda-args exp)
+       (wrap-mutable-formals 
+         (ast:lambda-id exp)
          (ast:lambda-formals->list exp)
-         (wrap-mutables (car (ast:lambda-body exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase
+         (list (wrap-mutables (car (ast:lambda-body exp)) globals))
+         (ast:lambda-has-cont exp))
+       (ast:lambda-has-cont exp)
+       )) ;; Assume single expr in lambda body, since after CPS phase
     ((const? exp)    exp)
     ((ref? exp)      (if (and (not (member exp globals))
                               (is-mutable? exp))
@@ -749,9 +764,7 @@
                          exp))
     ((prim? exp)     exp)
     ((quote? exp)    exp)
-    ((lambda? exp)   `(lambda ,(lambda->formals exp)
+    ((lambda? exp)   (error `(Unexpected lambda in wrap-mutables ,exp)))
-                        ,(wrap-mutable-formals (lambda-formals->list exp)
-                                               (wrap-mutables (car (lambda->exp exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase
     ((set!? exp)     `(,(if (member (set!->var exp) globals)
                             'set-global!
                             'set-cell!)