mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-25 05:51:55 -08:00
cmp: move functions from cmpmac to cmputil
both files served the same purpose
This commit is contained in:
Daniel Kochmański
parent
9eff84b622
commit
0489f2e227
3 changed files with 107 additions and 115 deletions
|
|
@ -1,114 +0,0 @@
|
|||
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
|
||||
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
||||
|
||||
;;;;
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Macros only used in the code of the compiler itself:
|
||||
|
||||
(in-package "COMPILER")
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; CACHED FUNCTIONS
|
||||
;;
|
||||
(defmacro defun-cached (name lambda-list test &body body)
|
||||
(let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*")
|
||||
(symbol-package name)))
|
||||
(reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE")
|
||||
(symbol-package name)))
|
||||
(hash-function (case test
|
||||
(EQ 'SI::HASH-EQ)
|
||||
(EQL 'SI::HASH-EQL)
|
||||
((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL)
|
||||
(t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
|
||||
`(progn
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil)))
|
||||
(defun ,reset-name ()
|
||||
(make-array 1024 :element-type t :adjustable nil))
|
||||
(defun ,name ,lambda-list
|
||||
(flet ((,name ,lambda-list ,@body))
|
||||
(let* ((hash (logand (,hash-function ,@lambda-list) 1023))
|
||||
(elt (aref ,cache-name hash)))
|
||||
(declare (type (integer 0 1023) hash)
|
||||
(type (array t (*)) ,cache-name))
|
||||
(if (and elt ,@(loop for arg in lambda-list
|
||||
collect `(,test (pop (ext:truly-the cons elt)) ,arg)))
|
||||
(first (ext:truly-the cons elt))
|
||||
(let ((output (,name ,@lambda-list)))
|
||||
(setf (aref ,cache-name hash) (list ,@lambda-list output))
|
||||
output))))))))
|
||||
|
||||
(defmacro defun-equal-cached (name lambda-list &body body)
|
||||
`(defun-cached ,name ,lambda-list equal-with-circularity ,@body))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; CONVENIENCE FUNCTIONS / MACROS
|
||||
;;;
|
||||
|
||||
(defun-cached env-var-name (n) eql
|
||||
(format nil "env~D" n))
|
||||
|
||||
(defun-cached lex-env-var-name (n) eql
|
||||
(format nil "lex~D" n))
|
||||
|
||||
(defun same-fname-p (name1 name2) (equal name1 name2))
|
||||
|
||||
;;; from cmplabel.lsp
|
||||
(defun next-label ()
|
||||
(cons (incf *last-label*) nil))
|
||||
|
||||
(defun next-label* ()
|
||||
(cons (incf *last-label*) t))
|
||||
|
||||
(defun labelp (x)
|
||||
(and (consp x) (integerp (si:cons-car x))))
|
||||
|
||||
(defun maybe-next-label ()
|
||||
(if (labelp *exit*)
|
||||
*exit*
|
||||
(next-label)))
|
||||
|
||||
(defun maybe-wt-label (label)
|
||||
(unless (eq label *exit*)
|
||||
(wt-label label)))
|
||||
|
||||
(defmacro with-exit-label ((label) &body body)
|
||||
`(let* ((,label (next-label))
|
||||
(*unwind-exit* (cons ,label *unwind-exit*)))
|
||||
,@body
|
||||
(wt-label ,label)))
|
||||
|
||||
(defmacro with-optional-exit-label ((label) &body body)
|
||||
`(let* ((,label (maybe-next-label))
|
||||
(*unwind-exit* (adjoin ,label *unwind-exit*)))
|
||||
,@body
|
||||
(maybe-wt-label ,label)))
|
||||
|
||||
(defun next-lcl (&optional name)
|
||||
(list 'LCL (incf *lcl*) T
|
||||
(if (and name (symbol-package name))
|
||||
(lisp-to-c-name name)
|
||||
"")))
|
||||
|
||||
(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
|
||||
(let ((code (incf *next-cfun*)))
|
||||
(format nil prefix code (lisp-to-c-name lisp-name))))
|
||||
|
||||
(defun next-temp ()
|
||||
(prog1 *temp*
|
||||
(incf *temp*)
|
||||
(setq *max-temp* (max *temp* *max-temp*))))
|
||||
|
||||
(defun next-lex ()
|
||||
(prog1 (cons *level* *lex*)
|
||||
(incf *lex*)
|
||||
(setq *max-lex* (max *lex* *max-lex*))))
|
||||
|
||||
(defun next-env ()
|
||||
(prog1 *env*
|
||||
(incf *env*)
|
||||
(setq *max-env* (max *env* *max-env*))))
|
||||
|
||||
(defmacro reckless (&rest body)
|
||||
`(locally (declare (optimize (safety 0)))
|
||||
,@body))
|
||||
|
|
@ -473,3 +473,110 @@ comparing circular objects."
|
|||
(and (equal-recursive (car x) (car y) x0 y0 t (logior (ash path-spec 1) 1) (the fixnum (1+ n)))
|
||||
(equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n))))))))
|
||||
(equal-recursive x y nil nil t 0 -1)))
|
||||
|
||||
;; ----------------------------------------------------------------------
|
||||
;; CACHED FUNCTIONS
|
||||
;;
|
||||
(defmacro defun-cached (name lambda-list test &body body)
|
||||
(let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*")
|
||||
(symbol-package name)))
|
||||
(reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE")
|
||||
(symbol-package name)))
|
||||
(hash-function (case test
|
||||
(EQ 'SI::HASH-EQ)
|
||||
(EQL 'SI::HASH-EQL)
|
||||
((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL)
|
||||
(t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
|
||||
`(progn
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil)))
|
||||
(defun ,reset-name ()
|
||||
(make-array 1024 :element-type t :adjustable nil))
|
||||
(defun ,name ,lambda-list
|
||||
(flet ((,name ,lambda-list ,@body))
|
||||
(let* ((hash (logand (,hash-function ,@lambda-list) 1023))
|
||||
(elt (aref ,cache-name hash)))
|
||||
(declare (type (integer 0 1023) hash)
|
||||
(type (array t (*)) ,cache-name))
|
||||
(if (and elt ,@(loop for arg in lambda-list
|
||||
collect `(,test (pop (ext:truly-the cons elt)) ,arg)))
|
||||
(first (ext:truly-the cons elt))
|
||||
(let ((output (,name ,@lambda-list)))
|
||||
(setf (aref ,cache-name hash) (list ,@lambda-list output))
|
||||
output))))))))
|
||||
|
||||
(defmacro defun-equal-cached (name lambda-list &body body)
|
||||
`(defun-cached ,name ,lambda-list equal-with-circularity ,@body))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; CONVENIENCE FUNCTIONS / MACROS
|
||||
;;;
|
||||
|
||||
(defun-cached env-var-name (n) eql
|
||||
(format nil "env~D" n))
|
||||
|
||||
(defun-cached lex-env-var-name (n) eql
|
||||
(format nil "lex~D" n))
|
||||
|
||||
(defun same-fname-p (name1 name2)
|
||||
(equal name1 name2))
|
||||
|
||||
;;; from cmplabel.lsp
|
||||
(defun next-label ()
|
||||
(cons (incf *last-label*) nil))
|
||||
|
||||
(defun next-label* ()
|
||||
(cons (incf *last-label*) t))
|
||||
|
||||
(defun labelp (x)
|
||||
(and (consp x) (integerp (si:cons-car x))))
|
||||
|
||||
(defun maybe-next-label ()
|
||||
(if (labelp *exit*)
|
||||
*exit*
|
||||
(next-label)))
|
||||
|
||||
(defun maybe-wt-label (label)
|
||||
(unless (eq label *exit*)
|
||||
(wt-label label)))
|
||||
|
||||
(defmacro with-exit-label ((label) &body body)
|
||||
`(let* ((,label (next-label))
|
||||
(*unwind-exit* (cons ,label *unwind-exit*)))
|
||||
,@body
|
||||
(wt-label ,label)))
|
||||
|
||||
(defmacro with-optional-exit-label ((label) &body body)
|
||||
`(let* ((,label (maybe-next-label))
|
||||
(*unwind-exit* (adjoin ,label *unwind-exit*)))
|
||||
,@body
|
||||
(maybe-wt-label ,label)))
|
||||
|
||||
(defun next-lcl (&optional name)
|
||||
(list 'LCL (incf *lcl*) T
|
||||
(if (and name (symbol-package name))
|
||||
(lisp-to-c-name name)
|
||||
"")))
|
||||
|
||||
(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
|
||||
(let ((code (incf *next-cfun*)))
|
||||
(format nil prefix code (lisp-to-c-name lisp-name))))
|
||||
|
||||
(defun next-temp ()
|
||||
(prog1 *temp*
|
||||
(incf *temp*)
|
||||
(setq *max-temp* (max *temp* *max-temp*))))
|
||||
|
||||
(defun next-lex ()
|
||||
(prog1 (cons *level* *lex*)
|
||||
(incf *lex*)
|
||||
(setq *max-lex* (max *lex* *max-lex*))))
|
||||
|
||||
(defun next-env ()
|
||||
(prog1 *env*
|
||||
(incf *env*)
|
||||
(setq *max-env* (max *env* *max-env*))))
|
||||
|
||||
(defmacro reckless (&rest body)
|
||||
`(locally (declare (optimize (safety 0)))
|
||||
,@body))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@
|
|||
'("src:cmp;cmppackage.lsp"
|
||||
"src:cmp;cmpglobals.lsp"
|
||||
"build:cmp;cmpdefs.lsp"
|
||||
"src:cmp;cmpmac.lsp"
|
||||
"src:cmp;cmputil.lsp"
|
||||
"src:cmp;cmpcond.lsp"
|
||||
;; Environment
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue