Skip to content
Snippets Groups Projects
Commit 5ff87105 authored by toy's avatar toy
Browse files

Port over SBCL's fix for the Entomotomy bug

backquote-over-eager-optimization.
parent c4648408
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.10 1994/10/31 04:11:27 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/backq.lisp,v 1.11 2002/10/14 21:37:57 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -78,15 +78,23 @@ ...@@ -78,15 +78,23 @@
(cons *bq-comma-flag* (read stream t nil t)))) (cons *bq-comma-flag* (read stream t nil t))))
'list))) 'list)))
;;;
(defun expandable-backq-expression-p (object)
(and (consp object)
(let ((flag (car object)))
(or (eq flag *bq-at-flag*)
(eq flag *bq-dot-flag*)))))
;;; This does the expansion from table 2. ;;; This does the expansion from table 2.
(defun backquotify (stream code) (defun backquotify (stream code)
(cond ((atom code) (cond ((atom code)
(cond ((null code) (values nil nil)) (cond ((null code) (values nil nil))
((or (numberp code) ((or (consp code)
(eq code t)) (symbolp code))
;; Keywords are self evaluating. Install after packages. ;; Keywords are self evaluating. Install after packages.
(values t code)) (values 'quote code))
(t (values 'quote code)))) (t (values t code))))
((or (eq (car code) *bq-at-flag*) ((or (eq (car code) *bq-at-flag*)
(eq (car code) *bq-dot-flag*)) (eq (car code) *bq-dot-flag*))
(values (car code) (cdr code))) (values (car code) (cdr code)))
...@@ -105,14 +113,18 @@ ...@@ -105,14 +113,18 @@
(cond (cond
((eq aflag *bq-at-flag*) ((eq aflag *bq-at-flag*)
(if (null dflag) (if (null dflag)
(comma a) (if (expandable-backq-expression-p a)
(values 'append (list a))
(comma a))
(values 'append (values 'append
(cond ((eq dflag 'append) (cond ((eq dflag 'append)
(cons a d )) (cons a d ))
(t (list a (backquotify-1 dflag d))))))) (t (list a (backquotify-1 dflag d)))))))
((eq aflag *bq-dot-flag*) ((eq aflag *bq-dot-flag*)
(if (null dflag) (if (null dflag)
(comma a) (if (expandable-backq-expression-p a)
(values 'nconc (list a))
(comma a))
(values 'nconc (values 'nconc
(cond ((eq dflag 'nconc) (cond ((eq dflag 'nconc)
(cons a d)) (cons a d))
...@@ -140,7 +152,8 @@ ...@@ -140,7 +152,8 @@
((or (numberp code) (eq code 't)) ((or (numberp code) (eq code 't))
(values t code)) (values t code))
(t (values *bq-comma-flag* code)))) (t (values *bq-comma-flag* code))))
((eq (car code) 'quote) ((and (eq (car code) 'quote)
(not (expandable-backq-expression-p (cadr code))))
(values (car code) (cadr code))) (values (car code) (cadr code)))
((memq (car code) '(append list list* nconc)) ((memq (car code) '(append list list* nconc))
(values (car code) (cdr code))) (values (car code) (cdr code)))
...@@ -156,9 +169,15 @@ ...@@ -156,9 +169,15 @@
((eq flag 'quote) ((eq flag 'quote)
(list 'quote thing)) (list 'quote thing))
((eq flag 'list*) ((eq flag 'list*)
(cond ((null (cddr thing)) (cond ((and (null (cddr thing))
(not (expandable-backq-expression-p (cadr thing))))
(cons 'backq-cons thing)) (cons 'backq-cons thing))
(t ((expandable-backq-expression-p (car (last thing)))
(list 'backq-append
(cons 'backq-list (butlast thing))
;; Can it be optimized further? -- APD, 2001-12-21
(car (last thing))))
(t
(cons 'backq-list* thing)))) (cons 'backq-list* thing))))
((eq flag 'vector) ((eq flag 'vector)
(list 'backq-vector thing)) (list 'backq-vector thing))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment