mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 13:52:16 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove / disable the code similarity routines. They simply do not work.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-10-19 23:02:14 +02:00
parent e18fdb426a
commit 166bbfd8f1
2 changed files with 77 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

9
src/cmp/cmpspecial.lsp
View file

@ -105,9 +105,12 @@
(fun-env fun) 0)))
(otherwise
(setf (fun-env fun) 0 (fun-level fun) 0)))
(let ((previous (dolist (old *local-funs*)
(when (similar fun old)
(return old)))))
(let ((previous
nil
#+(or)
(dolist (old *local-funs*)
(when (similar fun old)
(return old)))))
(if previous
(progn
(if (eq (fun-closure fun) 'CLOSURE)

116
src/cmp/cmptop.lsp
View file

@ -303,6 +303,7 @@
;;; Mechanism for sharing code:
;;; FIXME! Revise this 'DEFUN stuff.
(defun new-defun (new &optional no-entry)
#|
(unless (fun-exported new)
;; Check whether this function is similar to a previous one and
;; share code with it.
@ -315,58 +316,83 @@
(fun-minarg new) (fun-minarg old)
(fun-maxarg new) (fun-maxarg old))
(return))))
|#
(push new *global-funs*))
(defun print-function (x)
(format t "~%<a FUN: ~A, CLOSURE: ~A, LEVEL: ~A, ENV: ~A>"
(fun-name x) (fun-closure x) (fun-level x) (fun-env x)))
(defmacro and! (&body body)
`(let ((l (list ,@body)))
(pprint (list* 'l? l))
(every #'identity l)))
#|
(defun similar (x y)
;; FIXME! This could be more accurate
(labels ((similar-ref (x y)
(and (equal (ref-ref-ccb x) (ref-ref-ccb y))
(equal (ref-ref-clb x) (ref-ref-clb y))
(equal (ref-ref x) (ref-ref y))))
(similar-var (x y)
(and (similar-ref x y)
(equal (var-name x) (var-name y))
(equal (var-kind x) (var-kind y))
(equal (var-loc x) (var-loc y))
(equal (var-type x) (var-type y))
(equal (var-index x) (var-index y))))
(similar-c1form (x y)
(and (equal (c1form-name x) (c1form-name y))
(similar (c1form-args x) (c1form-args y))
(similar (c1form-local-vars x) (c1form-local-vars y))
(eql (c1form-sp-change x) (c1form-sp-change y))
(eql (c1form-volatile x) (c1form-volatile y))))
(similar-fun (x y)
(and (similar-ref x y)
(eql (fun-global x) (fun-global y))
(eql (fun-exported x) (fun-exported y))
(eql (fun-closure x) (fun-closure y))
(similar (fun-var x) (fun-var y))
(similar (fun-lambda x) (fun-lambda y))
(= (fun-level x) (fun-level y))
(= (fun-env x) (fun-env y))
(= (fun-minarg x) (fun-minarg y))
(eql (fun-maxarg x) (fun-maxarg y))
(similar (fun-local-vars x) (fun-local-vars y))
(similar (fun-referred-vars x) (fun-referred-vars y))
(similar (fun-referred-funs x) (fun-referred-funs y))
(similar (fun-child-funs x) (fun-child-funs y)))))
(and (eql (type-of x) (type-of y))
(typecase x
(CONS (and (similar (car x) (car y))
(similar (cdr x) (cdr y))))
(VAR (similar-var x y))
(FUN (similar-fun x y))
(REF (similar-ref x y))
(TAG NIL)
(BLK NIL)
(C1FORM (similar-c1form x y))
(SEQUENCE (and (every #'similar x y)))
(T (equal x y))))))
(let ((*processed* (make-hash-table :test #'equal)))
;; FIXME! This could be more accurate
(labels ((similar (x y)
(when (eql x y)
(return-from similar t))
(let ((pair (cons x y)))
(case (gethash pair *processed* :not-found)
((nil) (return-from similar nil))
((t) (return-from similar t))
((:ongoing) (return-from similar t))
((:not-found)))
(setf (gethash pair *processed*) :ongoing)
(setf (gethash pair *processed*)
(and (eql (type-of x) (type-of y))
(typecase x
(CONS (and (similar (car x) (car y))
(similar (cdr x) (cdr y))))
(VAR (similar-var x y))
(FUN (similar-fun x y))
(REF (similar-ref x y))
(TAG NIL)
(BLK NIL)
(C1FORM (similar-c1form x y))
(SEQUENCE (and (every #'similar x y)))
(T (equal x y)))))))
(similar-list (x y)
(null (set-difference x y)))
(similar-ref (x y)
(and (equal (ref-ref-ccb x) (ref-ref-ccb y))
(equal (ref-ref-clb x) (ref-ref-clb y))
(equal (ref-ref x) (ref-ref y))))
(similar-var (x y)
(print (list (var-loc x) (var-loc y)))
(and! (similar-ref x y)
(equal (var-name x) (var-name y))
(equal (var-kind x) (var-kind y))
(equal (var-loc x) (var-loc y))
(equal (var-type x) (var-type y))
(equal (var-index x) (var-index y))))
(similar-c1form (x y)
(and (equal (c1form-name x) (c1form-name y))
(similar (c1form-args x) (c1form-args y))
(similar (c1form-local-vars x) (c1form-local-vars y))
(eql (c1form-sp-change x) (c1form-sp-change y))
(eql (c1form-volatile x) (c1form-volatile y))))
(similar-fun (x y)
(print (list '? (fun-name x) (fun-name y)))
(and! (similar-ref x y)
(eql (fun-global x) (fun-global y))
(eql (fun-exported x) (fun-exported y))
(eql (fun-closure x) (fun-closure y))
(similar (fun-var x) (fun-var y))
(similar (fun-lambda x) (fun-lambda y))
(= (fun-level x) (fun-level y))
(= (fun-env x) (fun-env y))
(= (fun-minarg x) (fun-minarg y))
(eql (fun-maxarg x) (fun-maxarg y))
(every #'similar (fun-local-vars x) (fun-local-vars y))
(every #'similar (fun-referred-vars x) (fun-referred-vars y))
(every #'similar (fun-referred-funs x) (fun-referred-funs y))
(every #'similar (fun-child-funs x) (fun-child-funs y)))))
(similar x y))))
|#
(defun wt-function-prolog (&optional sp local-entry)
(wt " VT" *reservation-cmacro*