From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 runtime/runtime-utils.scm | 384 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 384 insertions(+)
 create mode 100644 runtime/runtime-utils.scm

(limited to 'runtime/runtime-utils.scm')

diff --git a/runtime/runtime-utils.scm b/runtime/runtime-utils.scm
new file mode 100644
index 0000000..f43c930
--- /dev/null
+++ b/runtime/runtime-utils.scm
@@ -0,0 +1,384 @@
+;;; runtime-utils.scm -- basic runtime support
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  9 Jun 1992
+;;;
+;;; This file contains definitions (beyond the normal mumble stuff)
+;;; that is referenced directly in code built by the code generator.
+;;; See backend/codegen.scm.
+;;;
+
+
+
+;;; (delay form)
+;;;   returns a delay object with unevaluated "form".
+
+(define-syntax (delay form)
+  `(cons '#f (lambda () ,form)))
+
+
+;;; (box form)
+;;;   returns a delay object with evaluated "form".
+
+(define-syntax (box form)
+  (cond ((number? form)
+	 `(quote ,(cons '#t form)))
+	((and (pair? form) (eq? (car form) 'quote))
+	 `(quote ,(cons '#t (cadr form))))
+	(else
+	 `(cons '#t ,form))))
+
+(define-syntax (unbox form)
+  `(cdr ,form))
+
+(define-syntax (forced? form)
+  `(car ,form))
+
+
+;;; (force delay)
+;;;   return the value of the delay object.
+
+(define (force delay-object)
+  (declare (type pair delay-object))
+  (if (car delay-object)
+      (cdr delay-object)
+      (begin
+        (let ((result  (funcall (cdr delay-object))))
+	  (setf (car delay-object) '#t)
+	  (setf (cdr delay-object) result)))))
+
+;;; Inline version of the above.  Not good to use everywhere because
+;;; of code bloat problems, but handy for helper functions.
+
+(define-syntax (force-inline delay-object)
+  (let ((temp1  (gensym))
+	(temp2  (gensym)))
+    `(let ((,temp1  ,delay-object))
+       (declare (type pair ,temp1))
+       (if (car ,temp1)
+	   (cdr ,temp1)
+	   (let ((,temp2  (funcall (cdr ,temp1))))
+	     (setf (car ,temp1) '#t)
+	     (setf (cdr ,temp1) ,temp2))))))
+
+
+;;; (make-curried-fn opt-fn strictness)
+;;; The basic idea is to compare the number of arguments received against
+;;; the number expected.
+;;; If the same, call the optimized entry point opt-fn.
+;;; If more, apply the result of calling the optimized entry to the
+;;;   leftover arguments.
+;;; If less, make a closure that accepts the additional arguments.
+
+(define (make-curried-fn opt-fn strictness)
+  (lambda args
+    (curried-fn-body '() args opt-fn strictness)))
+
+(define (curried-fn-body previous-args args opt-fn strictness)
+  (multiple-value-bind
+      (saturated? actual-args leftover-args leftover-strictness)
+      (process-curried-fn-args strictness args '())
+    (setf actual-args (append previous-args actual-args))
+    (if saturated?
+	(if (null? leftover-args)
+	    (apply opt-fn actual-args)
+	    (apply (apply opt-fn actual-args) leftover-args))
+	(lambda more-args
+	  (curried-fn-body actual-args more-args opt-fn leftover-strictness)))
+    ))
+
+(define (process-curried-fn-args strictness args actual-args)
+  (cond ((null? strictness)
+	 ;; At least as many arguments as expected.
+	 (values '#t (nreverse actual-args) args strictness))
+	((null? args)
+	 ;; Not enough arguments supplied.
+  	 (values '#f (nreverse actual-args) args strictness))
+	(else
+	 ;; Process the next argument.
+	 (if (car strictness)
+	     (push (force-inline (car args)) actual-args)
+	     (push (car args) actual-args))
+ 	 (process-curried-fn-args (cdr strictness) (cdr args) actual-args))
+	))
+
+
+;;; Special cases of the above.
+
+(define (make-curried-fn-1-strict opt-fn)
+  (lambda (arg1 . moreargs)
+    (setf arg1 (force-inline arg1))
+    (if (null? moreargs)
+	(funcall opt-fn arg1)
+	(apply (funcall opt-fn arg1) moreargs))))
+
+(define (make-curried-fn-1-nonstrict opt-fn)
+  (lambda (arg1 . moreargs)
+    (if (null? moreargs)
+	(funcall opt-fn arg1)
+	(apply (funcall opt-fn arg1) moreargs))))
+
+
+;;; Here's a similar helper function used for making data constructors.
+
+(define (constructor-body previous-args args arity fn)
+  (declare (type fixnum arity))
+  (let ((n  (length args)))
+    (declare (type fixnum n))
+    (setf args (append previous-args args))
+    (cond ((eqv? n arity)
+	   (apply fn args))
+	  ((< n arity)
+	   (lambda more-args
+	     (constructor-body args more-args (- arity n) fn)))
+	  (else
+	   (error "Too many arguments supplied to constructor.")))))
+
+
+;;; Special case for cons constructor
+
+(define (make-cons-constructor . args)
+  (constructor-body '() args 2 (function cons)))
+
+
+;;; (make-tuple-constructor arity)
+;;;   return a function that makes an untagged data structure with "arity" 
+;;;   slots.  "arity" is a constant.
+
+(define-integrable *max-predefined-tuple-arity* 10)
+
+(define (make-tuple-constructor-aux arity)
+  (cond ((eqv? arity 0)
+	 ;; Actually, should never happen -- this is the unit constructor
+	 0)
+	((eqv? arity 1)
+	 (lambda args
+	   (constructor-body '() args 2 (lambda (x) x))))
+	((eqv? arity 2)
+	 (lambda args
+	   (constructor-body '() args 2 (function cons))))
+	(else
+	 (lambda args
+	   (constructor-body '() args arity (function vector))))))
+
+(define *predefined-tuple-constructors*
+  (let ((result  '()))
+    (dotimes (i *max-predefined-tuple-arity*)
+      (push (make-tuple-constructor-aux i) result))
+    (list->vector (nreverse result))))
+
+(define-syntax (make-tuple-constructor arity)
+  (declare (type fixnum arity))
+  (if (< arity *max-predefined-tuple-arity*)
+      `(vector-ref *predefined-tuple-constructors* ,arity)
+      `(make-tuple-constructor-aux ,arity)))
+
+
+;;; (make-tuple . args)
+;;;   uncurried version of the above
+
+(define-syntax (make-tuple . args)
+  (let ((arity  (length args)))
+    (cond ((eqv? arity 0)
+	   ;; Actually, should never happen -- this is the unit constructor
+	   0)
+	  ((eqv? arity 1)
+	   (car args))
+	  ((eqv? arity 2)
+	   `(cons ,@args))
+	  (else
+	   `(vector ,@args)))))
+
+
+;;; (make-tagged-data-constructor n arity)
+;;;   return a function that makes a data structure with tag "n" and
+;;;   "arity" slots.
+
+(define-integrable *max-predefined-tagged-data-tag* 10)
+(define-integrable *max-predefined-tagged-data-arity* 10)
+
+(define (make-tagged-data-constructor-aux n arity)
+  (if (eqv? arity 0)
+      (vector n)
+      (lambda args
+	(constructor-body (list n) args arity (function vector)))))
+
+(define *predefined-tagged-data-constructors*
+  (let ((result  '()))
+    (dotimes (i *max-predefined-tagged-data-arity*)
+      (let ((inner-result  '()))
+	(dotimes (j *max-predefined-tagged-data-tag*)
+	  (push (make-tagged-data-constructor-aux j i) inner-result))
+	(push (list->vector (nreverse inner-result)) result)))
+    (list->vector (nreverse result))))
+
+(define-syntax (make-tagged-data-constructor n arity)
+  (declare (type fixnum arity n))
+  (if (and (< arity *max-predefined-tagged-data-arity*)
+	   (< n *max-predefined-tagged-data-tag*))
+      `(vector-ref (vector-ref *predefined-tagged-data-constructors* ,arity)
+		   ,n)
+      `(make-tagged-data-constructor-aux ,n ,arity)))
+
+
+;;; (make-tagged-data n . args)
+;;;   uncurried version of the above
+
+(define-syntax (make-tagged-data n . args)
+  `(vector ,n ,@args))
+
+
+;;; (tuple-select arity i object)
+;;;   extract component "i" from untagged "object"
+
+(define-syntax (tuple-select arity i object)
+  (cond ((eqv? arity 1)
+	 object)
+	((eqv? arity 2)
+	 (if (eqv? i 0)
+	     `(car ,object)
+	     `(cdr ,object)))
+	(else
+	 `(vector-ref (the vector ,object) (the fixnum ,i)))))
+
+
+;;; (tagged-data-select arity i object)
+;;;   extract component "i" from tagged "object"
+
+(define-syntax (tagged-data-select arity i object)
+  (declare (ignore arity))
+  `(vector-ref (the vector ,object) (the fixnum ,(1+ i))))
+
+
+;;; (constructor-number object)
+;;;   return the tag from "object"
+
+(define-syntax (constructor-number object)
+  `(vector-ref (the vector ,object) 0))
+
+(define-syntax (funcall-force fn . args)
+  (let* ((n    (length args))
+	 (junk (assv n '((1 . funcall-force-1)
+			 (2 . funcall-force-2)
+			 (3 . funcall-force-3)
+			 (4 . funcall-force-4)))))
+    `(,(if junk (cdr junk) 'funcall-force-n) ,fn ,@args)))
+
+(define (funcall-force-1 fn a1)
+  (funcall (force-inline fn) a1))
+(define (funcall-force-2 fn a1 a2)
+  (funcall (force-inline fn) a1 a2))
+(define (funcall-force-3 fn a1 a2 a3)
+  (funcall (force-inline fn) a1 a2 a3))
+(define (funcall-force-4 fn a1 a2 a3 a4)
+  (funcall (force-inline fn) a1 a2 a3 a4))
+(define-syntax (funcall-force-n fn . args)
+  `(funcall (force ,fn) ,@args))
+
+
+;;; (make-haskell-string string)
+;;;   Converts a Lisp string lazily to a boxed haskell string (makes
+;;;   a delay with a magic function).  Returns an unboxed result.
+
+(define (make-haskell-string string)
+  (declare (type string string))
+  (let ((index   1)
+	(size    (string-length string)))
+    (declare (type fixnum index size))
+    (cond ((eqv? size 0)
+	   '())
+	  ((eqv? size 1)
+	   (cons (box (char->integer (string-ref string 0)))
+		 (box '())))
+	  (else
+	   (letrec ((next-fn
+		      (lambda ()
+			(let ((ch  (char->integer (string-ref string index))))
+			  (incf index)
+			  (cons (box ch)
+				(if (eqv? index size)
+				    (box '())
+				    (cons '#f next-fn)))))))
+	     (cons (box (char->integer (string-ref string 0)))
+		   (cons '#f next-fn))))
+	  )))
+
+
+;;; Similar, but accepts an arbitrary tail (which must be a delay object)
+
+(define (make-haskell-string-tail string tail-delay)
+  (declare (type string string))
+  (let ((index   1)
+	(size    (string-length string)))
+    (declare (type fixnum index size))
+    (cond ((eqv? size 0)
+	   (force-inline tail-delay))
+	  ((eqv? size 1)
+	   (cons (box (char->integer (string-ref string 0)))
+		 tail-delay))
+	  (else
+	   (letrec ((next-fn
+		      (lambda ()
+			(let ((ch  (char->integer (string-ref string index))))
+			  (incf index)
+			  (cons (box ch)
+				(if (eqv? index size)
+				    tail-delay
+				    (cons '#f next-fn)))))))
+	     (cons (box (char->integer (string-ref string 0)))
+		   (cons '#f next-fn))))
+	  )))
+
+
+(define (haskell-string->string s)
+  (let ((length  0))
+    (declare (type fixnum length))
+    (do ((s s (force (cdr s))))
+	((null? s))
+	(setf length (+ length 1)))
+    (let ((result  (make-string length)))
+      (declare (type string result))
+      (do ((s s (unbox (cdr s)))
+	   (i 0 (+ i 1)))
+	  ((null? s))
+	  (declare (type fixnum i))
+	  (setf (string-ref result i) (integer->char (force (car s)))))
+      result)))
+
+
+(define (print-haskell-string s port)
+   (do ((s1 s (force (cdr s1))))
+       ((null? s1))
+     (write-char (integer->char (force (car s1))) port)))
+
+;;; This explicates the value returned by a proc (the IO () type).
+
+(define (insert-unit-value x)
+  (declare (ignore x))
+  0)
+
+;;; These handle list conversions
+
+(define (haskell-list->list fn l)
+  (if (null? l)
+      '()
+      (cons (funcall fn (force (car l))) 
+	    (haskell-list->list fn (force (cdr l))))))
+
+(define (list->haskell-list fn l)
+  (if (null? l)
+      '()
+      (cons (box (funcall fn (car l)))
+	    (box (list->haskell-list fn (cdr l))))))
+
+(define (haskell-list->list/identity l)
+  (if (null? l)
+      '()
+      (cons (force (car l))
+	    (haskell-list->list/identity (force (cdr l))))))
+
+(define (list->haskell-list/identity l)
+  (if (null? l)
+      '()
+      (cons (box (car l))
+	    (box (list->haskell-list/identity (cdr l))))))
-- 
cgit v1.2.3