comment: -*- Module: expression -*-
module: expression
language: prefix-dylan

;;;
;;; **********************************************************************
;;; Copyright (c) 1993 Carnegie Mellon University, all rights reserved.
;;; 
(begin
  "$Header$")
;;;
;;; **********************************************************************
;;;
;;; This file contains the support for expressions and macros.
;;;


;;;; Lexical environment stuff.


(define-class <binding> ()
  ;;
  ;; The variable-name this is a binding of.
  (getter: binding-name required-init-keyword: name:))


(define-class <lexenv> ()
  ;;
  ;; The module this lexenv is contained in.
  (lexenv-module required-init-keyword: module:)
  ;;
  ;; List of bindings.
  (lexenv-bindings init-value: '() init-keyword: bindings:))

(define-method make ((c (singleton <lexenv>))
		     #key module (bindings '()) inside)
  (if module
      (if inside
	  (error "Can only supply one of module: or inside:")
	  (next-method c module: module bindings: bindings))
      (if inside
	  (bind-methods ((append (new old)
			   (if (id? new '())
			       old
			       (pair (head new) (append (tail new) old)))))
	    (next-method c module: (lexenv-module inside)
		  bindings: (append bindings (lexenv-bindings inside))))
	  (error "Must supply either module: or inside:"))))

(define-method make-load-form ((lexenv <lexenv>))
  (unless (empty? (lexenv-bindings lexenv))
    (error "Can't dump non-null lexical environments as constants"))
  (bind ((?module-name
	  (make <literal-constant>
		object: (module-name (lexenv-module lexenv)))))
    (expression
     (make <lexenv> module: (find-module ?module-name)))))


(define-class <lexical-context> ()
  ;;
  ;; The lexical environment this context is part of, or #f if none.
  (lexical-context-lexenv init-value: #f init-keyword: lexenv:))

(define-method make-load-form ((context <lexical-context>))
  (bind ((?lexenv (make <literal-constant>
			object: (lexical-context-lexenv context))))
    (expression
     (make <lexical-context> lexenv: ?lexenv))))



;;;; Expression classes.

(define-class <expression> ()
  ;;
  ;; No slots.
  )

(define-class <literal-constant> (<expression>)
  (literal-constant-object required-init-keyword: object:))

(define-method similar? (thing1 thing2)
  (id? thing1 thing2))

(define-method similar? ((list1 <list>) (list2 <list>))
  (and (similar? (head list1) (head list2))
       (similar? (tail list1) (tail list2))))

(define-method similar? ((v1 <simple-object-vector>)
			 (v2 <simple-object-vector>))
  (and (= (size v1) (size v2))
       (every similar? v1 v2)))

(define-method similar? ((s1 <string>) (s2 <string>))
  (and (= (size s1) (size s2))
       (every similar? s1 s2)))

(define-method binary= ((lc1 <literal-constant>) (lc2 <literal-constant>))
  (similar? (literal-constant-object lc1) (literal-constant-object lc2)))


(define-class <pattern-ellipsis> ()
  ;;
  ;; No slots.
  )

(define $pattern-ellipsis
  (make <literal-constant> object: (make <pattern-ellipsis>)))



(define-class <variable-name> (<expression>)
  (vn-name init-value: 'temp init-keyword: name:)
  (vn-context init-function: (method () (make <lexical-context>))
	      init-keyword: context:)
  (vn-originally-was init-value: #f init-keyword: was:))

(define-method make ((c (singleton <variable-name>))
		     #key (name 'temp) context was)
  (if (instance? context <variable-name>)
      (bind-methods
	  ((repeat (context)
	     (if context
		 (next-method c name: name
			      context: (vn-context context)
			      was: (repeat (vn-originally-was context)))
		 #f)))
	(repeat context))
      (next-method)))

(define-method make-load-form ((vn <variable-name>))
  (bind ((?name vn)
	 (?context (make <literal-constant> object: (vn-context vn)))
	 (?was (make <literal-constant> object: (vn-originally-was vn))))
    (expression
     (make <variable-name>
	   name: '?name
	   context: ?context
	   was: ?was))))


(define-method as ((c (singleton <symbol>)) (vn <variable-name>))
  (vn-name vn))

(define-method as ((c (singleton <string>)) (vn <variable-name))
  (as <string> (vn-name vn)))

(define-method binary= ((vn1 <variable-name>) (vn2 <variable-name>))
  (and (id? (vn-name vn1) (vn-name vn2))
       (id? (vn-context vn1) (vn-context vn2))))

(define find-binding
  (method ((name <variable-name>) (lexenv <lexenv>))
    (or (any? (method (binding)
		(= (binding-name binding) name))
	      (lexenv-bindings lexenv))
	(bind ((was (vn-originally-was name)))
	  (if was
	      (lexenv-lookup was (lexical-context-lexenv (vn-context name)))
	      #f)))))

(define variable-name-module ((name <variable-name>) (lexenv <lexenv>))
  (bind ((was (vn-originally-was name)))
    (if was
	(variable-name-module was (lexical-context-lexenv (vn-context name)))
	(lexenv-module lexenv))))


(define-class <combination> (<expression>)
  (combination-pieces required-init-keyword: pieces:))


(define-class <bogus-expression> (<expression>)
  ;;
  ;; No slots.
  )


;;;; Macros

(define-class <macro> ()
  macro-expander)

(define-variable *macro-lexenv*
  #f)

(define expand-macro
  (method ((macro <macro>) (expr <expression>) (lexenv <lexenv>))
    (bind ((old-macro-lexenv *macro-lexenv*))
      (unwind-protect
	  (begin
	    (set! *macro-lexenv* lexenv)
	    ((macro-expander macro) expr))
	(set! *macro-lexenv* old-macro-lexenv)))))

(define-class <macro-binding> (<binding>)
  macro)


;;;;

(define compile-time-eval-also
  (macro
   ((? ?form ...)
    (expression
     (begin
      (compile-stage
       ?form ...)
      ?form ...)))))


;;;; Utilities used by the expansion of EXPRESSION

(define expr-map
  (method (proc #rest args)
    (bind ((length #f))
      (for-each ((arg args))
		()
	(select arg instance?
	  (<sequence>
	   (bind ((this-length (size arg)))
	     (if length
		 (unless (= length this-length)
		   (error "sequences of different length."))
		 (set! length this-length))))
	  (<expression>)))
      (unless length
	(error "ellipsis after template with no sequence variables."))
      (bind ((result (make <list> length: length)))
	(do ((result-state (initial-state result)
			   (next-state result result-state))
	     (states (map (method (arg)
			    (and (instance? arg <sequence>)
				 (initial-state arg)))
			  args)
		     (map (method (arg state)
			    (and (instance? arg <sequence>)
				 (next-state arg state)))
			  args states)))
	    ((not result-state) result)
	  (set! (current-element result result-state)
		(apply proc (map (method (arg state)
				   (if (instance? arg <sequence>)
				       (current-element arg state)
				       arg))
				 args states))))))))


;;;; EXPRESSION macro.

(compile-time-eval-also

(define-method gen-pair ((car-form <literal-constant>)
			 (cdr-form <literal-constant>))
  (make <literal-constant> 
	object: (pair (literal-constant-object car-form)
		      (literal-constant-object cdr-form))))

(define-method gen-pair ((?car-form <expression>)
			 (?cdr-form <expression>))
  (expression (pair ?car-form ?cdr-form)))

(define-method gen-append (?list1 ?list2)
  (expression (concatenate ?list1 ?list2)))

(define-method gen-map (?form map-env)
  (bind ((?var (map tail map-env))
	 (?val (map head map-env)))
    (expression (expr-map (method (?var ...) ?form) ?val ..))))

(define gen-ref (var maps emit)
  (if maps
      (gen-ref var (tail maps)
	       (method (outer-var outer-maps)
		 (bind ((mapping (any? (method (m)
					 (id? (head m) outer-var))
				       (car maps))))
		   (if mapping
		       (emit (tail mapping) maps)
		       (bind ((inner-var (expression temp)))
			 (emit inner-var
			       (pair (pair (pair outer-var inner-var)
					   (head maps))
				     outer-maps)))))))
      (emit var maps)))

); compile-time-eval-also

(define expression
  (macro
   ((? ?template)
    (bind ((?context-var #f)
	   (bindings '())
	   (bound-names '()))
      (bind-methods
	  ((grovel (template maps emit)
	     (select template instance?
	       (<literal-constant>
		(bind ((?object (literal-constant-object template)))
		  (emit (expression
			 (make <literal-constant> object: '?object))
			maps)))
	       (<combination>
		(grovel-list (combination-pieces template) maps
		  (method (?form maps)
		    (emit (expression
			   (make <combination>
				 pieces: ?form))
			  maps))))
	       (<variable-name>
		(bind ((name (as <string> template)))
		  (cond
		   ((= (first name default: #\x) #\?)
		    (gen-ref template maps
			     (method (?form maps)
			       (emit (expression
				      (check-type ?form <expression>))
				     maps))))
		   ((member? template bound-names)
		    (emit template maps))
		   (t
		    (set! bound-names (add! bound-names template))
		    (unless ?context-var
		      (set! ?context-var
			    (expression context))
		      (set! bindings
			    (pair (bind ((?lower-lexenv
					  (make <literal-constant>
						object: *lower-lexenv*)))
				    (expression
				     (?context-var
				      (make <lexical-context>
					    lexenv: ?lower-lexenv))))
				  bindings)))
		    (set! bindings
			  (pair (bind ((?name template)
				       (?var
					(make-literal-constant template)))
				  (expression
				   (?name
				    (make <variable-name>
					  name: '?name
					  context: ?context-var
					  originally-was: ?var))))
				bindings))
		    (emit template maps)))))))
	   (grovel-list (list maps emit)
	     (cond ((id? list '())
		    (emit (make <literal-constant> object: '()) maps))
		   ((and (not (id? (tail list) '()))
			 (= (head (tail list)) $pattern-ellipsis))
		    (grovel-list (tail (tail list)) maps
		      (method (cddr-form maps)
			(grovel (head list) (pair '() maps)
			  (method (car-form maps)
			    (if (id? (head maps) '())
				(error "....")
				(emit (gen-append (gen-map car-form
							   (car maps))
						  cddr-form)
				      (cdr maps))))))))
		   (t
		    (grovel (head list) maps
		      (method (car-form maps)
			(grovel-list (tail list) maps
			  (method (cdr-form maps)
			    (emit (gen-cons car-form cdr-form) maps)))))))))
	(bind ((?guts (grovel ?template '() (method (form maps) form)))
	       (?binding (reverse! bindings)))
	  (expression
	   (bind (?binding ...)
	     ?guts))))))))


;;;; Expression-case

(compile-time-eval-also

(define-class <pattern> ()
  ;;
  ;; No slots.
  )

(define-class <literal-pattern> (<pattern>)
  ;;
  ;; The object we are matching against.
  (literal-pattern-literal required-init-keyword: literal:))

(define-method make-load-form ((lit <literal-pattern>))
  (bind ((?lit (make <literal-constant>
		     object: (literal-pattern-literal lit))))
    (expression
     (make <literal-pattern> literal: ?lit))))


(define-class <name-pattern> (<pattern>)
  ;;
  ;; The variable name this pattern element is supposed to match.
  (name-pattern-name required-init-keyword: name:)
  ;;
  ;; The lexenv from the program stage one layer down.
  (name-pattern-lexenv required-init-keyword: lexenv:))

(define-method make-load-form ((pat <name-pattern>))
  (bind ((?name (make <literal-constant> object: (name-pattern-name pat)))
	 (?lexenv (make <literal-constant> object: (name-pattern-lexenv pat))))
    (expression
     (make <name-pattern> name: ?name lexenv: ?lexenv))))


(define-class <variable-pattern> (<pattern>)
  ;;
  ;; No slots.
  )

(define-method make-load-form ((vp <variable-pattern>))
  (expression (make <variable-pattern>)))



(define-class combination-pattern (<pattern>)
  ;;
  ;; List of the sub-patterns that make up this combination.
  (combination-pattern-pieces required-init-keyword: pieces:))

(define-method make-load-form ((pattern <combination-pattern>))
  (bind ((?pieces (make <literal-constant>
			object: (combination-pattern-pieces pattern))))
    (expression
     (make <combination-pattern> pieces: ?pieces))))


(define-class ellipsis-pattern (<combination-pattern>)
  ;;
  ;; The sub-pattern that is repeated at the end of this combination.
  (ellipsis-pattern-repeated required-init-keyword: repeated:))

(define-method make-load-form ((pattern <ellipsis-pattern>))
  (bind ((?pieces (make <literal-constant>
			object: (combination-pattern-pieces pattern)))
	 (?repeated (make <literal-constant>
			  object: (ellipsis-pattern-repeated pattern))))
    (expression
     (make <ellipsis-pattern> pieces: ?pieces repeated: ?repeated))))


(define-class keyword-combination-pattern (<combination-pattern>)
  ;;
  ;; A list of keywords accepted by this pattern.
  (keyword-pattern-keywords required-init-keyword: keywords:))

(define-method make-load-form ((pattern <keyword-pattern>))
  (bind ((?pieces (make <literal-constant>
			object: (combination-pattern-pieces pattern)))
	 (?keywords (make <literal-constant>
			  object: (keyword-pattern-keywords pattern))))
    (expression
     (make <keyword-pattern> pieces: ?pieces keyword: ?keywords))))



(define parse-pattern
  (method ((pattern <expression>))
    (bind ((variables '()))
      (bind-methods
	  ((parse (pattern depth)
	     (select pattern instance?
	       (<literal-constant>
		(when (= pattern $pattern-ellipsis)
		  (error "Invalid use of ..."))
		(make-literal-pattern (literal-constant-object pattern)))
	       (<variable-name>
		(bind ((name (as <string> pattern)))
		  (cond ((= (first name default: #\x) #\?)
			 (set! variables (add! variables pattern))
			 (make <variable-pattern>))
			(t
			 (make <name-pattern>
			       name: pattern
			       lexenv: *lower-lexenv*)))))
	       (<combination>
		(let ((pieces (combination-pieces pattern)))
		  (parse-seq pieces (initial-state pieces) '() depth)))))
	   (parse-seq (seq state pieces depth)
	     (if (null state)
		 (make <combination-pattern>
		       pieces: (reverse! pieces))
		 (bind ((next (current-element seq state))
			(nstate (next-state seq state)))
		   (cond ((= next (expression #key))
			  (make <keyword-pattern>
				pieces: (reverse! pieces)
				keywords: (parse-keywords seq nstate '())))
			 ((and nstate
			       (= (current-element seq nstate)
				  $pattern-ellipsis)
			       (not (next-state seq (copy-state seq nstate))))
			  (make <ellipsis-pattern>
				pieces: (reverse! peices)
				repeated: (parse next (+ depth 1))))
			 (t
			  (parse-seq seq nstate
				     (add! pieces (parse next depth))
				     depth))))))
	   (parse-keywords (seq state keywords)
	     (if state
		 (bind ((keyword (parse-keyword (current-element seq state))))
		   (parse-keywords seq (next-state seq state)
				   (add! keyword keywords)))
		 (reverse! keywords)))
	   (parse-keyword (keyword)
	     (bind-exit (return)
	       (expression-case keyword
		 (?name
		  (when (instance? ?name <variable-name>)
		    (set! variables (add! variables ?name))
		    (as <keyword> (as <symbol> ?name))))
		 ((?name ?default)
		  (when (instance? ?name <variable-name>)
		    (set! variables
			  (add! variables (list ?name depth ?default)))
		    (return (as <keyword> (as <symbol> ?name)))))
		 ((?keyword ?name)
		  (when (and (instance? ?keyword <literal-constant>)
			     (instance? ?name <variable-name>))
		    (bind ((keyword (literal-constant-object ?keyword)))
		      (when (instance? keyword <keyword>)
			(set! variables (add! variables ?name))
			(return keyword)))))
		 ((?keyword ?name ?default)
		  (when (and (instance? ?keyword <literal-constant>)
			     (instance? ?name <variable-name>))
		    (bind ((keyword (literal-constant-object ?keyword)))
		      (when (instance? keyword <keyword>)
			(set! variables
			      (add! variables (list ?name depth ?default))
			(return keyword))))))))))
	(values (parse pattern 0)
		(reverse! variables))))))

); compile-time-eval-also

(define expression-case
  (macro
   ((? ?expr (?pattern ?form ...) ...)
    (bind ((?return (expression return))
	   (?temp (expression temp))
	   (?matcher
	    (map (method (pattern ?forms)
		   (bind ((parsed-pattern variables (parse-pattern pattern))
			  (?pattern (make <literal-constant> parsed-pattern))
			  (?vars (map (method (x)
					(if (instance? x <list>)
					    (head x)
					    x))
				      variables))
			  (?vals
			   (map (method (x)
				  (if (instance? x <list>)
				      (bind ((?var (first x))
					     (?def (third x)))
					(iterate repeat
						 ((depth (second x)))
					  (if (zerop depth)
					      (expression
					       (or ?var ?def))
					      (bind ((?guts
						      (repeat (1- depth))))
						(expression
						 (map (method (?var)
							?guts)
						      ?var))))))
				      x))
				variables)))
		     (expression
		      (bind ((matches bindings
				      (match-pattern ?pattern ?temp #f)))
			(when matches
			  (bind ((result
				  (apply (method (?vars ...)
					   (bind ((?vars ...
						   (values ?vals ...)))
					     ?forms ...))
					 bindings)))
			    (when result
			      (?return (check-type result
						   <expression>)))))))))
		 ?pattern ?form)))
      (expression
       (bind-exit (?return)
	 (bind ((?temp ?expr))
	   ?matcher ...
	   (error "Invalid syntax: ~S" ?temp))))))))


;;;; Pattern matchings.

;;; MATCH-PATTERN -- internal.
;;;
;;; Check to see if EXPR matches PATTERN.  Returns T and a list of the parts
;;; that correspond to the pattern variables if it matches, or NIL and NIL if
;;; not.
;;;
;;; Basically, descend down through the pattern, checking to make sure the
;;; expression matches at that level.  At each recursion, we are passed the
;;; result list for everything that is ``after'' this node in the pattern.
;;; If this pattern node corresponds to a pattern variable, then we just
;;; cons the expression onto the front of the result list and return it.
;;;
;;; When we hit ``ellipsis'' nodes (which correspond to occurances of ... in
;;; the pattern) then we have to recurse, using the same subpattern on each
;;; element of the expression (which must be a list).  We will then have
;;; several results, one for each subexpression.  For example, if we had the
;;; pattern:
;;; 
;;;   ((foo bar) ...)
;;; 
;;; and applied it to the expression:
;;;
;;;   ((foo1 bar1) (foo2 bar2) (foo3 bar3))
;;;
;;; we would have a list of 3 result lists (identical to the expression).
;;; Well, we want to turn that into a result list with two entries, one for foo
;;; and one for bar.  To do this, we iterate over the list of result lists,
;;; using (mapcar #'car ...) to extract all the foos, and then (mapcar #'cdr
;;; ...) to advance the lists.
;;;
;;; But if the ellipsis node is matched against an empty list, then we have to
;;; grovel the subpattern to figure out how many pattern variables there are
;;; because there are no sub-expressions to match against the sub-pattern.
;;; This is what the match-empty function does: it just grovels the subpattern
;;; ``matching'' it against nothing.
;;;
(define match-pattern
  (method (pattern expr)
    (bind-exit (return)
      (values #t (match pattern expr '() (method () (return #f '())))))))

(define-method match ((pattern <pattern>) (expr <expression>) results punt)
  (punt))

(define-method match ((pattern <literal-pattern>) (expr <literal-constant>)
		      results punt)
  (if (similar? (literal-constant-object expr)
		(literal-pattern-literal pattern))
      results
      (punt)))

(define-method match ((pattern <name-pattern>) (expr <variable-name>)
		      results punt)
;		(multiple-value-bind
;		    (expr-defn ignore expr-module)
;		    (lookup expr *macro-lexenv*)
;		  (declare (ignore ignore))
;		  (multiple-value-bind
;		      (pattern-defn ignore pattern-module)
;		      (lookup (name-pattern-name pattern)
;			      (name-pattern-lexenv pattern))
;		(declare (ignore ignore))
;		(if (if (and expr-defn pattern-defn)
;			(flet ((meaning (defn)
;				 (typecase defn
;				   (macro-binding
;				    (macro-binding-macro defn))
;				   (macro-info
;				    (macro-info-macro defn))
;				   (t
;				    defn))))
;			  (eq (meaning expr-defn) (meaning pattern-defn)))
;			(and (eq expr-module pattern-module)
;			     (eq (variable-name-symbol expr)
;				 (variable-name-symbol
;				  (name-pattern-name pattern)))))
;		    results
  (punt))

(define-method match ((pattern <variable-pattern>) (expr <expression>)
		      results punt)
  (pair expr results))

(define-method match ((pattern <combination-pattern>) (expr <combination>)
		      results punt)
  (bind ((pattern-pieces (combination-pattern-pieces pattern))
	 (expr-pieces (combination-pieces expr)))
    (match-combination pattern pattern-pieces (initial-state pattern-pieces)
		       expr-pieces (initial-state expr-pieces) results punt)))

(define-method match-combination ((pattern <combination-pattern>)
				  (pattern-pieces <sequence>) pattern-state
				  (expr-pieces <sequence>) expr-state
				  results punt)
  (if pattern-state
      (if expr-state
	  (match (current-element pattern-pieces pattern-state)
		 (current-element expr-pieces expr-state)
		 (match-combination pattern pattern-pieces
				    (next-state pattern-pieces pattern-state)
				    expr-pieces
				    (next-state expr-pieces expr-state)
				    results punt)
		 punt)
	  (punt))
      (match-tail pattern expr-pieces expr-state results punt)))

(define-method match-tail ((pattern <combination-pattern>)
			   (expr-pieces <sequence>) expr-state
			   results punt)
  (if expr-state
      (punt)
      results))

(define-method match-tail ((pattern <ellipsis-pattern>)
			   (expr-pieces <sequence>) expr-state results punt)
  (bind ((subpattern
	  (ellipsis-pattern-repeated pattern)))
    (if expr-state
	(bind ((list-o-lists
		(iterate repeat ((state expr-state))
		  (if state
		      (pair (match subpattern
				   (current-element expr-pieces state)
				   '() punt)
			    (repeat (next-state expr-pieces state)))
		      '()))))
	  (iterate repeat ((states (map initial-state list-o-lists)))
	    (if (first states)
		(pair (map (curry current-element list-o-lists) states)
		      (repeat (map (curry next-state list-o-lists) states)))
		results)))
	(match-empty subpattern results))))


(define-method match-tail ((pattern <keyword-pattern>) (expr-pieces <sequence>)
			   expr-state results punt)
  (bind ((keywords (keyword-pattern-keywords pattern)))
    (match-keywords keywords
		    (check-keywords keywords expt-pieces expr-state punt)
		    results)))

(define-method check-keywords (keywords expr-pieces expr-state punt)
  (iterate repeat ((state expr-state))
    (if state
	(bind ((keyword-expr (current-element expr-pieces state))
	       (keyword (and (instance? keyword-expr <literal-constant>)
			     (literal-constant-object keyword-expr)))
	       (state (next-state expr-pieces state)))
	  (unless state
	    (punt))
	  (unless (member? keyword keywords)
	    (punt))
	  (pair (pair keyword (current-element expr-pieces state))
		(repeat (next-state expr-pieces state))))
	'())))


(define-method match-keywords (keywords key-value-pairs results)
  (if (empty? keywords)
      results
      (pair (bind ((keyword (first keywords))
		   (entry (any? (method (x) (= (head x) keyword))
				key-value-pairs)))
	      (and entry (tail entry)))
	    (match-keywords (tail keywords) key-value-pairs results))))


(define-method match-empty ((pattern <literal-pattern>) results)
  results)

(define-method match-empty ((pattern <name-pattern>) results)
  results)

(define-method match-empty ((pattern <variable-pattern>) results)
  (pair #f results))

(define-method match-empty ((pattern <combination-pattern>) results)
  (bind ((pieces (combination-pattern-pieces pattern)))
    (match-empty-combination pattern pieces (initial-state pieces) results)))

(define-method match-empty-combination ((pattern <combination-pattern>)
					(pieces <sequence>) state results)
  (match-empty (current-element pieces state)
	       (match-empty-combination pattern pieces
					(next-state pieces state) results)))

(define-method match-empty-combination
	       ((pattern <combination-pattern>) (pieces <sequence>)
		(state (singleton #f)) results)
  results)

(define-method match-empty-combination
	       ((pattern <ellipsis-pattern>) (pieces <sequence>)
		(state (singleton #f)) results)
  (match-empty (ellipsis-pattern-repeated pattern) results))

(define-method match-empty-combination
	       ((pattern <keyword-pattern>) (pieces <sequence>)
		(state (singleton #f)) results)
  (for-each ((keyword (keyword-pattern-keywords pattern)))
	    ()
    (set! results (pair #f results)))
  results)