Changeset 41 in CGBLisp

Timestamp:

Feb 1, 2009, 4:22:24 PM (15 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• trunk/src/infix-printer.lisp (modified) (3 diffs)

trunk/src/infix-printer.lisp

@@ -18 +18 @@
 (in-package "INFIX-PRINTER")
 
+(proclaim '(optimize (speed 0) (debug 3)))
+
 (defun infix-print-separated-list (lst sep stream op print-level
                                    &optional (alt-op nil) (alt-sep alt-op)
@@ -26 +28 @@
   (cond
    ((endp lst) nil)
-   ((and (numberp *print-level*) (> print-level *print-level*))
+
+   ;; Handle *print-level* 
+   ((and (numberp *print-level*)
+         (> print-level *print-level*))
     (format stream "#"))
+
    (t
-    (dolist (arg lst (infix-print arg stream op print-level))
+    (dolist (arg lst)
       (setf true-sep sep)
       (incf count)
-      (when (and alt-op (> count 1) (consp arg) (eq alt-op (car arg)))
-          (setf arg (cadr arg)
-                true-sep alt-sep))
+
+      (when (and alt-op
+                 (> count 1)
+                 (consp arg)
+                 (eq alt-op (car arg)))
+        (setf arg (cadr arg)
+              true-sep alt-sep))
       (if beg
           (setf beg nil)
-        (format stream "~a" true-sep))
+          (format stream "~a" true-sep))
+      
+      ;; If *print-length* exceeded, print ellipsis
       (when (and (numberp *print-length*) (> count *print-length*))
         (format stream "...")
-        (return-from infix-print-separated-list))))))
+        (return-from infix-print-separated-list (values)))
+      
+      (infix-print arg stream op print-level))))
+  (values))
 
+
+(defun infix-print-arg-list (lst stream print-level
+                             &aux (count 0))
+  "Print a comma-separated list"
+
+  ;; Arguments never need to be parenthesized?
+  (dolist (e (butlast lst))
+    (infix-print e stream (1+ print-level))
+    (when (and (numberp *print-length*)
+               (> count *print-length*))
+      (format stream "...")
+      (return-from infix-print-arg-list (values)))
+    (format stream ","))
+  (infix-print (car (last lst)) stream (1+ print-level)))
+    
 
 (defun infix-print (expr &optional (stream t) (op nil) (print-level 0))
@@ -48 +78 @@
 has lower precedence than OP."
   (cond 
-   ((and (numberp *print-level*) (> print-level *print-level*))
+    ;; Handle *print-level*
+   ((and (numberp *print-level*)
+         (> print-level *print-level*))
     (format stream "#"))
-   ((null expr) (error "Null expression."))
-   ((atom expr) (format stream "~a" expr))
+
+   ;; Null expression is an error
+   ((null expr)
+    (error "Null expression."))
+
+   ;; Atoms are printed using ~A format directive
+   ((atom expr)
+    (format stream "~a" expr))
+   
+   ;; Check if the operator of this expression has lower precedence
+   ;; than the surrounding operator, and parenthesize if necessary
    ((and op (operator-lessp (car expr) op))
     (format stream "(")
     (infix-print expr stream nil (1+ print-level))
     (format stream ")"))
-   ((and (eq (car expr) '-)
-         (endp (cddr expr)))            ;unary minus
+
+   ;; Unary minus needs special handling
+   ((and (eq (car expr) '-) (endp (cddr expr)))
     (format stream "-")
+    ;; Print the second element in product context
     (infix-print (cadr expr) stream '* (1+ print-level)))
+
+   ;; All other operators
    (t 
     (case (car expr)
+
+      ;; Arithmetic operators
       ((+ - * /)
-       (infix-print-separated-list (cdr expr) (car expr) stream (car expr) (1+ print-level)
-                                   (cond ((eq (car expr) '+) '-)
-                                         ((eq (car expr) '-) '-)
-                                         (t nil))))
-      (wedge
-       (infix-print-separated-list (cdr expr) '|/\\| stream '* (1+ print-level)))
+       (infix-print-separated-list
+        (cdr expr)
+        (car expr)
+        stream
+        (car expr)
+        (1+ print-level)
+        (cond ((eq (car expr) '+) '-)
+              ((eq (car expr) '-) '-)
+              (t nil))))
+
+      ;; Exponentials
       (expt
        (unless (= (length (cdr expr)) 2)
          (error "expt must take 2 arguments."))
-       (infix-print-separated-list (cdr expr) '^ stream '^ (1+ print-level)))
-      (otherwise                        ;assumed function call
+       (infix-print-separated-list
+        (cdr expr)
+        '^
+        stream
+        '^
+        (1+ print-level)))
+
+      ;; Assuming function call
+      (otherwise                
        (cond
-        ((and (eq (car expr) 'd)
-              (consp (cdr expr))
-              (symbolp (cadr expr)))
-         ;; Special syntax for differential forms
-         (format stream "d~a" (cadr expr)))
-        ((eq (car expr) 'aref)
-         ;; Special syntax for subscripted variables
-         ;; consistent with the infix package.
-         (format stream "~a[" (cadr expr))
-         (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
-         (format stream "]"))
-        ((and (symbolp (car expr))
-              (string= (symbol-name (car expr)) "["))
-         (format stream "[")
-         (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
-         (format stream "]"))
-        (t
-         ;; Generic function call syntax
-         (format stream "~a(" (car expr))
-         (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
-         (format stream ")"))))))))
+         ;; Handle array references
+         ((eq (car expr) 'aref)
+          ;; Special syntax for subscripted variables
+          ;; consistent with the infix package.
+          (format stream "~a[" (cadr expr))
+          (infix-print-separated-list (cddr expr) '\, stream '\, (1+ print-level))
+          (format stream "]"))
+
+         ;; Handle lists
+         ((and (symbolp (car expr))
+               (string= (symbol-name (car expr)) "["))
+          (format stream "[")
+          (infix-print-separated-list (cdr expr) '\, stream '\, (1+ print-level))
+          (format stream "]"))
+
+
+         ;; Handle generic function call syntax
+         (t
+
+          (format stream "~a(" (car expr))
+          (infix-print-arg-list (cdr expr) stream (1+ print-level))
+          (format stream ")")))))))
+  (values))