├── .gitignore ├── pf.png ├── pf-lite.png ├── .dependencies ├── clpmfile ├── src ├── form-types.lisp ├── package.lisp ├── nonlite │ ├── package.lisp │ ├── conditions.lisp │ ├── benchmark.lisp │ ├── utils.lisp │ ├── sbcl-deftransform.lisp │ ├── ensure-type-form.lisp │ ├── specializing.lisp │ ├── polymorph-compiler-macro.lisp │ ├── dispatch.lisp │ └── compiler-macro.lisp ├── pre-package.lisp ├── lambda-lists │ ├── doc.lisp │ ├── required.lisp │ ├── base.lisp │ ├── required-optional.lisp │ └── required-key.lisp ├── type-tools.lisp ├── swank.lisp ├── utils.lisp ├── conditions.lisp ├── ensure-type-form.lisp ├── types.lisp ├── misc-tests.lisp ├── dispatch.lisp └── polymorphic-function.lisp ├── polymorphic-functions.asd ├── polymorphic-functions-lite.asd └── .github └── workflows └── CI.yml /.gitignore: -------------------------------------------------------------------------------- 1 | clpmfile.lock -------------------------------------------------------------------------------- /pf.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/digikar99/polymorphic-functions/HEAD/pf.png -------------------------------------------------------------------------------- /pf-lite.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/digikar99/polymorphic-functions/HEAD/pf-lite.png -------------------------------------------------------------------------------- /.dependencies: -------------------------------------------------------------------------------- 1 | ("cl-form-types" :git "https://github.com/alex-gutev/cl-form-types") 2 | ("cl-environments" :git "https://github.com/alex-gutev/cl-environments") 3 | ("compiler-macro-notes" :git "https://github.com/digikar99/compiler-macro-notes") -------------------------------------------------------------------------------- /clpmfile: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; -*- 2 | (:api-version "0.4") 3 | 4 | (:source "quicklisp" :url "https://beta.quicklisp.org/dist/quicklisp.txt" :type :quicklisp) 5 | 6 | (:asd "polymorphic-functions.asd") 7 | (:asd "polymorphic-functions-lite.asd") 8 | 9 | (:github "cl-environments" :path "alex-gutev/cl-environments" :branch "main" :systems ("cl-environments")) 10 | (:github "cl-form-types" :path "alex-gutev/cl-form-types" :branch "main" :systems ("cl-form-types")) 11 | (:github "compiler-macro-notes" :path "digikar99/compiler-macro-notes" :branch "main" :systems ("compiler-macro-notes")) 12 | -------------------------------------------------------------------------------- /src/form-types.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmacro the* (type-specifier form) 4 | "CL:THE does not guarantee FORM to be of TYPE-SPECIFIER on all the 5 | implementations. But, THE* guarantees this." 6 | (once-only (form) 7 | `(if (typep ,form ',type-specifier) 8 | ,form 9 | (error 'type-error :expected-type ',type-specifier :datum ,form)))) 10 | 11 | (defmethod cl-form-types:custom-form-type ((op (eql 'the*)) args env) 12 | (declare (ignore op)) 13 | (let ((type1 (first args)) 14 | (type2 (cl-form-types:form-type (second args) env))) 15 | (declare (ignorable type2)) 16 | ;; TODO: Implement a SUBTYPEP that allows VALUES types. 17 | type1)) 18 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:polymorphic-functions.nonuser 2 | (:use) 3 | (:documentation 4 | "Package for internal use by POLYMORPHIC-FUNCTIONS not intended for direct use by users.")) 5 | 6 | (defpackage #:polymorphic-functions 7 | (:use #:alexandria #:cl) 8 | (:shadow #:named-lambda 9 | #:list-named-lambda 10 | #:find-class) 11 | (:import-from #:5am #:is #:def-test) 12 | (:import-from #:introspect-environment 13 | #:policy-quality 14 | #:constant-form-value 15 | #:typexpand) 16 | (:export #:define-polymorphic-function 17 | #:undefine-polymorphic-function 18 | #:defpolymorph 19 | ;; #:defpolymorph-compiler-macro 20 | #:undefpolymorph 21 | #:find-polymorph 22 | #:polymorph-apropos-list-type 23 | 24 | ;; Unstable API 25 | #:polymorphic-function 26 | #:polymorph 27 | #:no-applicable-polymorph 28 | #:polymorphic-function-type-lists 29 | #:inline-pf 30 | #:notinline-pf 31 | #:pf-defined-before-use 32 | #:not-pf-defined-before-use 33 | ;; #:*compiler-macro-expanding-p* 34 | ;; #:*disable-static-dispatch* 35 | 36 | ;; #:suboptimal-polymorph-note 37 | ;; #:more-optimal-polymorph-inapplicable 38 | 39 | #:specializing 40 | #:specializing-type-of)) 41 | 42 | (5am:def-suite :polymorphic-functions) 43 | -------------------------------------------------------------------------------- /src/nonlite/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:polymorphic-functions.nonuser 2 | (:use) 3 | (:documentation 4 | "Package for internal use by POLYMORPHIC-FUNCTIONS not intended for direct use by users.")) 5 | 6 | (defpackage #:polymorphic-functions 7 | (:use #:alexandria #:cl #:compiler-macro-notes) 8 | (:shadow #:named-lambda 9 | #:list-named-lambda 10 | #:find-class) 11 | (:import-from #:5am #:is #:def-test) 12 | (:import-from #:introspect-environment 13 | #:compiler-macroexpand 14 | #:parse-compiler-macro 15 | #:policy-quality 16 | #:constant-form-value 17 | #:typexpand) 18 | (:import-from #:cl-environments.cltl2 19 | #:function-information 20 | #:variable-information 21 | #:declaration-information 22 | #:define-declaration 23 | #:augment-environment) 24 | (:import-from #:cl-form-types 25 | #:combine-values-types) 26 | (:export #:define-polymorphic-function 27 | #:undefine-polymorphic-function 28 | #:defpolymorph 29 | #:defpolymorph-compiler-macro 30 | #:undefpolymorph 31 | #:find-polymorph 32 | #:polymorph-apropos-list-type 33 | 34 | ;; Unstable API 35 | #:polymorphic-function 36 | #:polymorph 37 | #:no-applicable-polymorph 38 | #:polymorphic-function-type-lists 39 | #:inline-pf 40 | #:notinline-pf 41 | #:pf-defined-before-use 42 | #:not-pf-defined-before-use 43 | #:*compiler-macro-expanding-p* 44 | #:*disable-static-dispatch* 45 | 46 | #:suboptimal-polymorph-note 47 | #:more-optimal-polymorph-inapplicable 48 | 49 | #:specializing 50 | #:specializing-type-of)) 51 | -------------------------------------------------------------------------------- /src/pre-package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:polymorphic-functions.defpackage 2 | (:use :cl :alexandria) 3 | (:shadow #:defpackage) 4 | (:export #:defpackage)) 5 | 6 | (in-package #:polymorphic-functions.defpackage) 7 | 8 | ;;; I didn't want to personally extend DEFPACKAGE-PLUS (someone do it please!) 9 | ;;; In addition, it doesn't integrate well with SLIME's M-. 10 | ;;; CONDUITS-PACKAGE doesn't provide this option (someone issue a PR please!) 11 | 12 | ;;; Default UIOP:DEFINE-PACKAGE doesn't work as correctly on CCL 13 | ;;; Latest ASDF does not work as reliably on *all* the implementations, 14 | ;;; at least not ECL 15 | (defmacro defpackage (package &body options) 16 | "Like CL:DEFPACKAGE but provides a (:SHADOWING-IMPORT-EXPORTED-SYMBOLS {package}*) option. 17 | Expects such package to be already defined." 18 | (let ((shadowing-import-symbols 19 | (loop :for option :in options 20 | :if (eq :shadowing-import-from (car option)) 21 | :appending (cddr option)))) 22 | `(cl:defpackage ,package 23 | ,@(loop :for option :in options 24 | :if (eq :shadowing-import-exported-symbols (car option)) 25 | :appending (mappend (lambda (package) 26 | (let* ((exported-symbols 27 | (set-difference 28 | (let (list) 29 | (do-external-symbols (s package) 30 | (push s list)) 31 | list) 32 | shadowing-import-symbols 33 | :test #'string=))) 34 | `((:shadowing-import-from ,package 35 | ,@exported-symbols)))) 36 | (cdr option)) 37 | :else 38 | :collect option)))) 39 | -------------------------------------------------------------------------------- /polymorphic-functions.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem "polymorphic-functions" 2 | :license "MIT" 3 | :version "0.5.2" ; beta 4 | :author "Shubhamkar Ayare (shubhamayare@yahoo.co.in)" 5 | :description "Type based dispatch for Common Lisp" 6 | :depends-on ("polymorphic-functions-lite" 7 | "cl-form-types" 8 | "compiler-macro-notes") 9 | :pathname #P"src/nonlite/" 10 | :components ((:file "package") 11 | (:file "utils" :depends-on ("package")) 12 | (:file "ensure-type-form" :depends-on ("utils")) 13 | (:file "polymorph-compiler-macro" :depends-on ("utils")) 14 | (:file "conditions" :depends-on ("polymorph-compiler-macro")) 15 | (:file "compiler-macro" :depends-on ("conditions")) 16 | #+sbcl 17 | (:file "sbcl-deftransform" :depends-on ("conditions")) 18 | (:file "dispatch" :depends-on ("conditions" 19 | "compiler-macro" 20 | #+sbcl 21 | "sbcl-deftransform")) 22 | (:file "misc-tests" :depends-on ("dispatch")) 23 | (:file "benchmark" :depends-on ("misc-tests"))) 24 | :perform (test-op (o c) 25 | (eval (with-standard-io-syntax 26 | (read-from-string "(LET ((5AM:*ON-FAILURE* :DEBUG) 27 | (5AM:*ON-ERROR* :DEBUG) 28 | (CL:*COMPILE-VERBOSE* NIL)) 29 | (FIVEAM:RUN! :POLYMORPHIC-FUNCTIONS))"))))) 30 | 31 | (defsystem "polymorphic-functions/specializing" 32 | :depends-on ("polymorphic-functions" 33 | "trivial-garbage") 34 | :description "Defines the polymorphic-functions:specializing macro" 35 | :pathname "src/nonlite/" 36 | :components ((:file "specializing"))) 37 | 38 | (defsystem "polymorphic-functions/swank" 39 | :depends-on ("polymorphic-functions-lite/swank") 40 | :description "slime/swank integration for polymorphic-functions") 41 | -------------------------------------------------------------------------------- /src/nonlite/conditions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :polymorphic-functions) 2 | 3 | (define-condition no-applicable-polymorph/compiler-note 4 | (no-applicable-polymorph compiler-macro-notes:note) 5 | ()) 6 | 7 | 8 | (define-condition defpolymorph-note (compiler-macro-notes:note) 9 | ((datum :initarg :datum :reader condition-datum)) 10 | (:report (lambda (c s) (write-string (condition-datum c) s)))) 11 | 12 | (define-condition form-type-failure (compiler-macro-notes:optimization-failure-note) 13 | ((form :initarg :form 14 | :initform (error "FORM not specified") 15 | :reader form)) 16 | (:report (lambda (condition stream) 17 | (format stream "Type of~% ~S~%could not be determined" (form condition))))) 18 | 19 | (define-condition polymorph-has-no-inline-lambda-body 20 | (compiler-macro-notes:optimization-failure-note) 21 | ((name :initarg :name 22 | :initform (error "NAME not specified") 23 | :reader name) 24 | (type-list :initarg :type-list 25 | :initform (error "TYPE-LIST not specified") 26 | :reader type-list)) 27 | (:report (lambda (condition stream) 28 | (format stream "~S with TYPE-LIST ~% ~S~%has no stored INLINE-LAMBDA-BODY" 29 | (name condition) 30 | (type-list condition))))) 31 | 32 | (define-condition suboptimal-polymorph-note 33 | (compiler-macro-notes:optimization-failure-note) 34 | ((type-list :initarg :type-list :reader type-list)) 35 | (:report (lambda (condition stream) 36 | (format stream "POLYMORPH with TYPE-LIST~% ~S~%was used for optimizing, but it is possibly suboptimal~%Better POLYMORPHs should exist" 37 | (type-list condition))))) 38 | 39 | (define-condition more-optimal-polymorph-inapplicable 40 | (suboptimal-polymorph-note) 41 | ((more-optimal-type-list :initarg :more-optimal-type-list 42 | :initform (error "MORE-OPTIMAL-TYPE-LIST not specified") 43 | :reader more-optimal-type-list)) 44 | (:report (lambda (condition stream) 45 | (format stream "More optimal POLYMORPH with TYPE-LIST~% ~S~%was found to be inapplicable" 46 | (more-optimal-type-list condition))))) 47 | 48 | (define-condition compile-time-return-type-mismatch 49 | (compiler-macro-notes:optimization-failure-note) 50 | ((derived :initarg :derived) 51 | (declared :initarg :declared) 52 | (form :initarg :form)) 53 | (:report (lambda (condition stream) 54 | (with-slots (derived declared form) condition 55 | (format stream "The declared return type~% ~S~%does not match the derived return type~% ~S~%of form~% ~S" 56 | declared derived form))))) 57 | 58 | -------------------------------------------------------------------------------- /polymorphic-functions-lite.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem "polymorphic-functions-lite" 2 | :license "MIT" 3 | :version "0.5.2" ; beta 4 | :author "Shubhamkar Ayare (shubhamayare@yahoo.co.in)" 5 | :description "Variant of polymorphic-functions with no support for static dispatch. This lets it have minimal dependencies." 6 | :depends-on ("alexandria" 7 | "fiveam" ;; just keep tests together! 8 | "introspect-environment" 9 | "optima") 10 | :pathname #P"src/" 11 | :components ((:file "package") 12 | (:file "utils" :depends-on ("package")) 13 | (:file "types" :depends-on ("utils")) 14 | (:file "type-tools" :depends-on ("utils")) 15 | (:file "ensure-type-form" :depends-on ("utils")) 16 | (:module "lambda-lists" :depends-on ("ensure-type-form" 17 | "type-tools" 18 | "types") 19 | :components ((:file "doc") 20 | (:file "parameters") 21 | (:file "base" :depends-on ("doc" 22 | "parameters")) 23 | (:file "required" :depends-on ("base")) 24 | (:file "required-optional" :depends-on ("base")) 25 | (:file "required-key" :depends-on ("base")) 26 | (:file "rest" :depends-on ("base")))) 27 | (:file "polymorphic-function" :depends-on ("lambda-lists")) 28 | (:file "conditions" :depends-on ("package")) 29 | (:file "dispatch" :depends-on ("polymorphic-function" 30 | "lambda-lists" 31 | "conditions")) 32 | (:file "misc-tests" :depends-on ("dispatch"))) 33 | :perform (test-op (o c) 34 | (eval (with-standard-io-syntax 35 | (read-from-string "(LET ((5AM:*ON-FAILURE* :DEBUG) 36 | (5AM:*ON-ERROR* :DEBUG) 37 | (CL:*COMPILE-VERBOSE* NIL)) 38 | (FIVEAM:RUN! :POLYMORPHIC-FUNCTIONS))"))))) 39 | 40 | (defsystem "polymorphic-functions-lite/swank" 41 | :depends-on ("polymorphic-functions-lite" 42 | "swank") 43 | :description "slime/swank integration for polymorphic-functions" 44 | :pathname "src" 45 | :components ((:file "swank"))) 46 | -------------------------------------------------------------------------------- /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | jobs: 4 | 5 | test: 6 | 7 | name: ${{ matrix.lisp }} 8 | 9 | strategy: 10 | matrix: 11 | lisp: [sbcl, ccl, ecl] 12 | runs-on: ubuntu-22.04 13 | 14 | steps: 15 | 16 | - uses: actions/checkout@v2 17 | 18 | - name: Update $PATH 19 | run: | 20 | echo $PATH 21 | echo "PATH=$HOME/bin:$PATH" >> $GITHUB_ENV 22 | - name: Check $PATH 23 | run: echo $PATH 24 | 25 | - name: Download implementation 26 | env: 27 | LISP: ${{ matrix.lisp }} 28 | run: | 29 | pwd 30 | ls -l 31 | bash <(curl -s https://raw.githubusercontent.com/digikar99/lisp-travis-lite/master/run.sh) 32 | 33 | - name: Download download-dependencies 34 | run: | 35 | git clone https://github.com/digikar99/download-dependencies $HOME/quicklisp/local-projects/download-dependencies 36 | 37 | 38 | - name: Download dependencies 39 | run: | 40 | cl --eval '(ql:quickload "download-dependencies")' \ 41 | --eval '(push "~/" ql:*local-project-directories*)' \ 42 | --eval '(in-package :download-dependencies)' \ 43 | --eval '(let ((*dependencies-home* (first ql:*local-project-directories*))) (ensure-system "polymorphic-functions"))'\ 44 | --eval '(ql:register-local-projects)' 45 | ls -l ~/ 46 | 47 | - name: Lite - Run Tests 48 | run: | 49 | cl --eval '(progn 50 | (push "~/" ql:*local-project-directories*) 51 | (push :travis *features*) 52 | (ql:quickload "polymorphic-functions-lite") 53 | (asdf:test-system "polymorphic-functions-lite") 54 | (uiop:quit 0))' 55 | 56 | - name: Full - Compile Tests 57 | run: | 58 | cl --eval '(progn 59 | (push "~/" ql:*local-project-directories*) 60 | (print ql:*local-project-directories*) 61 | (print (ql:where-is-system "polymorphic-functions")) 62 | (push :travis *features*) 63 | (ql:quickload "polymorphic-functions") 64 | (uiop:quit 0))' 65 | 66 | # Testing it on the second load confirms that functionalities do not 67 | # solely eval-when compile-toplevel, and that they persist across multiple loads. 68 | - name: Full - Run Tests 69 | run: | 70 | cl --eval '(progn 71 | (push "~/" ql:*local-project-directories*) 72 | (push :travis *features*) 73 | (ql:quickload "polymorphic-functions") 74 | (asdf:test-system "polymorphic-functions") 75 | (uiop:quit 0))' 76 | 77 | - name: Load Specializing 78 | run: | 79 | cl --eval '(progn 80 | (push "~/" ql:*local-project-directories*) 81 | (push :travis *features*) 82 | (ql:quickload "polymorphic-functions/specializing") 83 | (uiop:quit 0))' 84 | 85 | -------------------------------------------------------------------------------- /src/nonlite/benchmark.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (5am:in-suite :polymorphic-functions) 4 | 5 | (defmacro time-it (&body body) 6 | (with-gensyms (start end body-result) 7 | `(let (,start ,end ,body-result) 8 | (setq ,start (get-internal-real-time)) 9 | (setq ,body-result (progn ,@body)) 10 | (setq ,end (get-internal-real-time)) 11 | (values (- ,end ,start) ,body-result)))) 12 | 13 | (defmacro time-it/normalize (&body body) 14 | (with-gensyms (base-time real-time body-result) 15 | `(let ((,base-time (locally (declare (optimize (debug 1) (speed 1) (safety 1))) 16 | (time-it (loop repeat 1000000000 do (progn t)))))) 17 | (multiple-value-bind (,real-time ,body-result) 18 | (time-it ,@body) 19 | (values (/ ,real-time ,base-time 1.0) 20 | ,body-result))))) 21 | 22 | #+(and (or :sbcl :ccl) 23 | (not :travis)) 24 | (def-test performance () 25 | (unwind-protect (progn 26 | (ignoring-error-output 27 | (eval `(locally (declare (optimize (debug 1) (speed 1))) 28 | (define-polymorphic-function my= (a b) :overwrite t) 29 | (defpolymorph my= ((a string) (b string)) t 30 | (string= a b))))) 31 | 32 | (eval 33 | 34 | `(let ((a "hello") 35 | (b "world")) 36 | 37 | (macrolet 38 | ((expect-time ((expected) &body body) 39 | (with-gensyms (expected-sym actual-sym percent-diff) 40 | `(let* ((,expected-sym ,expected) 41 | (,actual-sym 42 | (time-it/normalize ,@body)) 43 | (,percent-diff (/ (abs (- ,actual-sym ,expected-sym)) 44 | ,expected-sym 0.01))) 45 | 46 | (5am:is (< ,percent-diff 10) 47 | "Expected: ~D~%Actual: ~D~%%diff: ~D%" 48 | ,expected-sym ,actual-sym ,percent-diff))))) 49 | 50 | #-extensible-compound-types ; too slow 51 | (expect-time (#+sbcl 3.9 52 | #+ccl 2.47) 53 | (locally (declare (optimize (debug 1) (speed 1))) 54 | (loop :repeat 50000000 :do (my= a b)))) 55 | 56 | (expect-time (#+sbcl 0.05 57 | #+ccl 0.75) 58 | (locally (declare (optimize (debug 1) (speed 3)) 59 | (type string a b)) 60 | (loop :repeat 50000000 :do (my= a b)))))))) 61 | 62 | (undefine-polymorphic-function 'my=) 63 | (unintern 'my=))) 64 | -------------------------------------------------------------------------------- /src/nonlite/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defun expand-macros-and-non-cl-compiler-macros (form env) 4 | ;; If the second return value is T, then the returned forms 5 | ;; are not walked further by CL-FORM-TYPES.WALKER:WALK-FORM. 6 | ;; In other words, return T to signal a "stop expansion". 7 | (optima:match form 8 | ((list* name _) 9 | (cond ((listp name) 10 | form) 11 | ((and (compiler-macro-function name env) 12 | (not (eq (find-package :cl) 13 | (symbol-package name)))) 14 | (funcall (compiler-macro-function name env) 15 | form 16 | env)) 17 | (t 18 | form))) 19 | (_ 20 | form))) 21 | 22 | (defun macroexpand-all (form &optional env) 23 | (cl-form-types.walker:walk-form 'expand-macros-and-non-cl-compiler-macros 24 | form 25 | env)) 26 | 27 | (defun env-speed (environment) 28 | (second (assoc 'speed (declaration-information 'optimize environment)))) 29 | 30 | (defun env-debug (environment) 31 | (second (assoc 'debug (declaration-information 'optimize environment)))) 32 | 33 | (defun env-safety (environment) 34 | (second (assoc 'safety (declaration-information 'optimize environment)))) 35 | 36 | (define-symbol-macro optim-safety (= 3 (env-safety env))) 37 | 38 | (define-symbol-macro optim-debug (or (= 3 (env-debug env)) 39 | (> (env-debug env) 40 | (env-speed env)))) 41 | (define-symbol-macro optim-speed (and (/= 3 (env-debug env)) 42 | (= 3 (env-speed env)))) 43 | (define-symbol-macro optim-slight-speed (and (/= 3 (env-debug env)) 44 | (/= 3 (env-speed env)) 45 | (<= (env-debug env) 46 | (env-speed env)))) 47 | 48 | 49 | (defun form-type (form env &key (return-default-type t) 50 | expand-compiler-macros constant-eql-types) 51 | (or (ignore-errors 52 | (handler-bind ((cl-form-types:unknown-special-operator 53 | (lambda (c) 54 | (declare (ignore c)) 55 | (invoke-restart 'cl-form-types:return-default-type 56 | return-default-type)))) 57 | (cl-form-types:form-type form env 58 | :expand-compiler-macros expand-compiler-macros 59 | :constant-eql-types constant-eql-types))) 60 | t)) 61 | 62 | (defun nth-form-type (form env n 63 | &optional 64 | constant-eql-types expand-compiler-macros (return-default-type t)) 65 | (or (ignore-errors 66 | (handler-bind ((cl-form-types:unknown-special-operator 67 | (lambda (c) 68 | (declare (ignore c)) 69 | (invoke-restart 'cl-form-types:return-default-type 70 | return-default-type)))) 71 | (cl-form-types:nth-form-type form env n constant-eql-types expand-compiler-macros))) 72 | t)) 73 | -------------------------------------------------------------------------------- /src/lambda-lists/doc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | ;; LAMBDA-LIST-TYPE ============================================================ 4 | 5 | (define-constant +lambda-list-type-doc+ 6 | "Returns the type of LAMBDA-LIST from amongst +LAMBDA-LIST-TYPES+. 7 | Raises an ERROR otherwise." 8 | :test 'string=) 9 | 10 | ;; EFFECTIVE-LAMBDA-LIST ======================================================= 11 | 12 | (define-constant +compute-effective-lambda-list-doc+ 13 | "Processes LAMBDA-LIST to return another lambda-list suitable for the lambda 14 | generated in REGISTER-POLYMORPHIC-FUNCTION and UPDATE-POLYMORPHIC-FUNCTION-LAMBDA. 15 | Raises an error if %LAMBDA-LIST-TYPE fails on *POTENTIAL-TYPE*." 16 | :test 'string=) 17 | 18 | (define-constant +effective-lambda-list-doc-helper+ 19 | "Processes LAMBDA-LIST assuming it is of type TYPE, and returns another lambda-list 20 | that is suitable for the lambda generated in REGISTER-POLYMORPHIC-FUNCTION and 21 | UPDATE-POLYMORPHIC-FUNCTION-LAMBDA. 22 | IF *LAMBDA-LIST-TYPED-P* is T, 23 | the second value is the type-list corresponding to the LAMBDA-LIST, 24 | and the third value is the effective-type-list." 25 | :test 'string=) 26 | 27 | ;; SBCL-TRANSFORM-ARG-LVARS-FROM-LAMBDA-LIST-FORM ============================== 28 | 29 | (define-constant +sbcl-transform-arg-lvars-from-lambda-list-form+ 30 | "Returns a FORM that can process the parameters of SB-C:DEFTRANSFORM to form an 31 | argument lvar alist list suitable for further processing." 32 | :test 'string=) 33 | 34 | ;; POLYMORPHIC-FUNCTION-BODY =================================================== 35 | 36 | (define-constant +compute-polymorphic-function-lambda-body-doc+ 37 | "Processes LAMBDA-LIST to return the body for the lambda constructed in 38 | UPDATE-POLYMORPHIC-FUNCTION-LAMBDA. 39 | Raises an error if %LAMBDA-LIST-TYPE fails on *POTENTIAL-TYPE*. 40 | If INVALIDATED-P is non-NIL, then emits a dummy body that will first call 41 | UPDATE-POLYMORPHIC-FUNCTION-LAMBDA with INVALIDATE as NIL, and then recall the function. 42 | Can contain CTYPE::CTYPE objects that are not expected dumped." 43 | :test 'string=) 44 | 45 | ;; LAMBDA-DECLARATIONS ========================================================= 46 | 47 | (define-constant +lambda-declarations-doc+ 48 | "Returns the list of declarations given the LAMBDA-LIST. the LAMBDA-LIST should 49 | be a TYPED-LAMBDA-LIST" 50 | :test 'string=) 51 | 52 | ;; type-list-more-specific-p ========================================================= 53 | 54 | (define-constant +type-list-more-specific-p+ 55 | "Returns T if TYPE-LIST-1 is more specialized than TYPE-LIST-2. 56 | If TYPE-LIST-1 is more specialized than TYPE-LIST-2, then that means 57 | that *if* both the type lists were applicable, then the polymorph 58 | with TYPE-LIST-1 list will be chosen over the polymorph with TYPE-LIST-2. 59 | More specialized does not mean all the types in TYPE-LIST-1 60 | are SUBTYPEP of the corresponding types in TYPE-LIST-2. 61 | 62 | For instance, (STRING ARRAY) is more specialized than (ARRAY STRING). 63 | 64 | See the tests under the suite POLYMORPHIC-FUNCTIONS::TYPE-LIST-MORE-SPECIFIC-P 65 | for more examples." 66 | :test 'string=) 67 | 68 | ;; TYPE-LIST-CAUSES-AMBIGUOUS-CALL-P =========================================== 69 | 70 | (define-constant +type-list-intersection-null-p+ 71 | "Returns T if there exist argument lists that are compatible with both 72 | TYPE-LIST-1 and TYPE-LIST-2" 73 | :test 'string=) 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/type-tools.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defun translate-body (body translation-alist) 4 | (flet ((translate (node) 5 | (if (listp node) 6 | node 7 | (or (cdr (assoc node translation-alist)) 8 | node)))) 9 | (traverse-tree body #'translate))) 10 | 11 | (defvar *subtypep-alist* nil 12 | "An ALIST mapping a (CONS TYPE1 TYPE2) to a boolean indicating whether TYPE1 13 | is a subtype of TYPE2.") 14 | 15 | (defun subtypep-using-subtypep-alist (type1 type2 &optional environment) 16 | (declare (ignore environment)) 17 | (let ((subtypep-value (assoc (cons type1 type2) *subtypep-alist* 18 | :test (lambda (type-pair-1 type-pair-2) 19 | (and (type= (car type-pair-1) 20 | (car type-pair-2)) 21 | (type= (cdr type-pair-1) 22 | (cdr type-pair-2))))))) 23 | (if subtypep-value 24 | (values (cdr subtypep-value) t) 25 | (values nil nil)))) 26 | 27 | (defvar *extended-subtypep-functions* nil 28 | "A list of function-designators that will be called by EXTENDED-SUBTYPEP.") 29 | 30 | (defun extended-subtypep (type1 type2 &optional environment) 31 | (loop :for fn :in *extended-subtypep-functions* 32 | :for (subtypep knownp) 33 | := (multiple-value-list (funcall fn type1 type2 environment)) 34 | :until knownp 35 | :finally 36 | (return (values subtypep knownp)))) 37 | 38 | (define-condition subtypep-not-known (condition) 39 | ((type1 :initarg :type1) 40 | (type2 :initarg :type2)) 41 | (:report (lambda (c s) 42 | (with-slots (type1 type2) c 43 | (format s "Not known whether ~S is a subtype of ~S" 44 | type1 type2))))) 45 | 46 | (defun type-pair-= (type-pair-1 type-pair-2 &optional env) 47 | "Each pair is a CONS of two types." 48 | (declare (ignore env)) 49 | (and (type= (car type-pair-1) 50 | (car type-pair-2)) 51 | (type= (cdr type-pair-1) 52 | (cdr type-pair-2)))) 53 | 54 | (defun definitive-subtypep (type1 type2 &optional environment) 55 | "Like POLYMORPHIC-FUNCTIONS.EXTENDED-TYPES:SUBTYPEP but uses *SUBTYPEP-ALIST* 56 | and *EXTENDED-SUBTYPEP-FUNCTIONS* and when the second value is NIL raises a 57 | restartable error to allow the user to specify whether the TYPE1 is 58 | a definite subtype of TYPE2. 59 | 60 | While using non-interactively, recommended way is to modify *SUBTYPEP-ALIST* 61 | and *EXTENDED-SUBTYPEP-FUNCTIONS* rather than invoking-restarts. 62 | 63 | The function-order for determining the SUBTYPEP functions is undefined." 64 | (let ((*extended-subtypep-functions* 65 | (append '(subtypep 66 | subtypep-using-subtypep-alist) 67 | *extended-subtypep-functions*))) 68 | (restart-case 69 | (multiple-value-bind (subtypep knownp) 70 | (extended-subtypep type1 type2 environment) 71 | (if knownp 72 | subtypep 73 | (error 'subtypep-not-known :type1 type1 :type2 type2))) 74 | (subtypep-t () 75 | :report (lambda (s) 76 | (format s "Treat TYPE1 as a subtype of TYPE2")) 77 | (setf (assoc-value *subtypep-alist* (cons type1 type2) :test #'type-pair-=) t) 78 | t) 79 | (subtypep-nil () 80 | :report (lambda (s) 81 | (format s "Treat TYPE1 as NOT a subtype of TYPE2")) 82 | (setf (assoc-value *subtypep-alist* (cons type1 type2) :test #'type-pair-=) nil) 83 | nil)))) 84 | -------------------------------------------------------------------------------- /src/swank.lisp: -------------------------------------------------------------------------------- 1 | (in-package :polymorphic-functions) 2 | 3 | (defparameter *swank-find-standard-definitions* #'swank/backend:find-definitions) 4 | (defparameter *swank-find-other-definitions* () 5 | " 6 | Each symbol or funcallable object in the list should take the NAME (symbol) 7 | as an argument Should return a list, such that each entry should in-turn be a 8 | list in the form 9 | 10 | (DESCRIPTION SOURCE) 11 | 12 | For SBCL, source can be captured using (SB-C:SOURCE-LOCATION) and needs to 13 | be stored in the appropriate object at the time of the object definition. 14 | 15 | To use the captured information, it must first be translated to 16 | SB-INTROSPECT:DEFINITION-SOURCE using SB-INTROSPECT::TRANSLATE-SOURCE-LOCATION, 17 | and then be passed through SWANK/SBCL::DEFINITION-SOURCE-FOR-EMACS to obtain 18 | SOURCE. 19 | 20 | It might be instructive to see the source code for 21 | (DEFIMPLEMENTATION FIND-DEFINITIONS ...) 22 | in swank/sbcl.lisp, as well as to trace SWANK/BACKEND:FIND-DEFINITIONS itself 23 | while it gets invoked for standard definitions. 24 | ") 25 | 26 | (defun extend-swank () 27 | (eval 28 | `(defun swank/backend:find-definitions (name) 29 | #.(documentation 'swank/backend:find-definitions 'cl:function) 30 | (apply #'append 31 | (funcall *swank-find-standard-definitions* name) 32 | (mapcar (lambda (deffn) (funcall deffn name)) 33 | *swank-find-other-definitions*)))) 34 | (pushnew 'find-polymorph-sources *swank-find-other-definitions*)) 35 | 36 | (defun find-polymorph-sources (name) 37 | (when (and (fboundp name) 38 | (typep (fdefinition name) 39 | 'polymorphic-function)) 40 | (let ((pf (fdefinition name))) 41 | (cons (list (list 'polymorphic-function name) 42 | (when (polymorphic-function-source pf) 43 | (swank/sbcl::definition-source-for-emacs 44 | (sb-introspect::translate-source-location 45 | (polymorphic-function-source pf)) 46 | 'polymorphic-function 47 | name))) 48 | (loop :for polymorph :in (polymorphic-function-polymorphs pf) 49 | :appending 50 | (list (list (list* 'polymorph 51 | name 52 | (polymorph-type-list polymorph)) 53 | (when (polymorph-source polymorph) 54 | (let ((source (sb-introspect::translate-source-location 55 | (polymorph-source polymorph)))) 56 | (swank/sbcl::definition-source-for-emacs 57 | source 58 | 'polymorph 59 | name))))) 60 | :if (polymorph-compiler-macro-lambda polymorph) 61 | :appending 62 | (list (list (list* 'polymorph-compiler-macro 63 | name 64 | (polymorph-type-list polymorph)) 65 | (when (polymorph-compiler-macro-source polymorph) 66 | (let ((source (sb-introspect::translate-source-location 67 | (polymorph-compiler-macro-source 68 | polymorph)))) 69 | (swank/sbcl::definition-source-for-emacs 70 | source 71 | 'polymorph-compiler-macro 72 | name)))))))))) 73 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmacro catch-condition (form) 4 | `(handler-case ,form 5 | (condition (condition) condition))) 6 | 7 | (defmacro is-error (form) 8 | `(5am:signals error ,form)) 9 | 10 | (defmacro named-lambda (name lambda-list &body body) 11 | `(flet ((,name ,lambda-list ,@body)) 12 | (function ,name))) 13 | 14 | (defmacro list-named-lambda (name package lambda-list &body body &environment env) 15 | (declare (type list name) 16 | (ignorable env package)) 17 | #+sbcl 18 | `(sb-int:named-lambda ,name ,lambda-list 19 | ,@body) 20 | #+ccl 21 | `(ccl:nfunction ,name 22 | #+extensible-compound-types 23 | (cl:lambda ,@(rest (macroexpand-1 `(lambda ,lambda-list ,@body) env))) 24 | #-extensible-compound-types 25 | (cl:lambda ,lambda-list ,@body)) 26 | #-(or sbcl ccl) 27 | (let ((function-name (intern (write-to-string name) package))) 28 | `(flet ((,function-name ,lambda-list ,@body)) 29 | #',function-name))) 30 | 31 | (define-symbol-macro optim-safety (= 3 (policy-quality 'safety env))) 32 | 33 | (define-symbol-macro optim-debug (or (= 3 (policy-quality 'debug env)) 34 | (> (policy-quality 'debug env) 35 | (policy-quality 'speed env)))) 36 | (define-symbol-macro optim-speed (and (/= 3 (policy-quality 'debug env)) 37 | (= 3 (policy-quality 'speed env)))) 38 | (define-symbol-macro optim-slight-speed (and (/= 3 (policy-quality 'debug env)) 39 | (/= 3 (policy-quality 'speed env)) 40 | (<= (policy-quality 'debug env) 41 | (policy-quality 'speed env)))) 42 | 43 | (defmacro with-eval-always (&body body) 44 | `(eval-when (:compile-toplevel :load-toplevel :execute) 45 | ,@body)) 46 | 47 | (defun type-specifier-p (type-specifier) 48 | "Returns true if TYPE-SPECIFIER is a valid type specfiier." 49 | (block nil 50 | #+sbcl (return (ignore-some-conditions (sb-kernel:parse-unknown-type) 51 | (sb-ext:valid-type-specifier-p type-specifier))) 52 | #+openmcl (return (ccl:type-specifier-p type-specifier)) 53 | #+ecl (return (c::valid-type-specifier type-specifier)) 54 | #+clisp (return (null 55 | (nth-value 1 (ignore-errors 56 | (ext:type-expand type-specifier))))) 57 | #+lispworks (return (type:valid-type-specifier type-specifier)) 58 | #-(or sbcl openmcl ecl clisp lispworks) 59 | (or (when (symbolp type-specifier) 60 | (documentation type-specifier 'type)) 61 | (error "TYPE-SPECIFIER-P not available for this implementation")))) 62 | 63 | (defun find-class (name &optional errorp environment) 64 | #-sbcl 65 | (if errorp 66 | (cl:find-class name t environment) 67 | (ignore-errors (cl:find-class name nil environment))) 68 | #+sbcl 69 | (cl:find-class name errorp environment)) 70 | 71 | (defun traverse-tree (tree &optional (function #'identity)) 72 | "Traverses TREE and calls function on each subtree and node of TREE. 73 | If FUNCTION returns a list, then traversing the list can be avoided if 74 | the second return value is non-NIL. If FUNCTION returns a list, traverses 75 | the list only if the second return value is NIL." 76 | (multiple-value-bind (new-tree traversal-complete-p) 77 | (funcall function tree) 78 | (if (and (proper-list-p new-tree) 79 | (not traversal-complete-p)) 80 | (loop :for node :in new-tree 81 | :collect (traverse-tree node function)) 82 | (funcall function new-tree)))) 83 | 84 | (deftype function-name () 85 | `(or (and symbol (not (member t nil))) 86 | (cons (eql setf) 87 | (cons (and symbol (not (member t nil))) 88 | null)))) 89 | 90 | (defmacro let+ (bindings &body body) 91 | (if (null bindings) 92 | `(locally ,@body) 93 | (optima:ematch (car bindings) 94 | ((list (list* '&values vars) value-form) 95 | `(multiple-value-bind ,vars ,value-form 96 | (let+ ,(cdr bindings) 97 | ,@body))) 98 | ((list variable value-form) 99 | `(let ((,variable ,value-form)) 100 | (let+ ,(cdr bindings) 101 | ,@body)))))) 102 | -------------------------------------------------------------------------------- /src/conditions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (define-condition lambda-list-has-changed (error) 4 | ((name :initarg :name 5 | :reader name 6 | :initform (error "NAME must be supplied!")) 7 | (new-lambda-list :initarg :new-lambda-list 8 | :reader new-lambda-list 9 | :initform (error "NEW LAMBDA LIST must be supplied!"))) 10 | (:report (lambda (condition stream) 11 | (let* ((name (name condition)) 12 | (apf (fdefinition name))) 13 | (format stream "New lambda list~% ~S~%does not match the old lambda list~% ~S 14 | of the POLYMORPHIC-FUNCTION ~S with TYPE-LISTS:~%~{~^ ~S~%~} 15 | 16 | Do you want to delete these POLYMORPHs to associate a new ones?" 17 | (new-lambda-list condition) 18 | (polymorphic-function-lambda-list apf) 19 | name 20 | (polymorphic-function-type-lists apf)))))) 21 | 22 | (define-condition not-a-ahp (error) 23 | ((name :initarg :name 24 | :reader name 25 | :initform (error "NAME must be supplied!"))) 26 | (:report (lambda (condition stream) 27 | (let* ((name (name condition))) 28 | (format stream "There already exists a FUNCTION ~S associated with NAME ~S.~%Do you want to delete the existing FUNCTION and associate a new~%POLYMORPHIC-FUNCTION with NAME ~S?" 29 | (fdefinition name) name name))))) 30 | 31 | (define-condition no-applicable-polymorph () 32 | ((name :initarg :name 33 | :initform (error "NAME not specified") 34 | :reader name) 35 | (args :initarg :args 36 | :initform (error "ARGS not specified") 37 | :reader args) 38 | (arg-types :initarg :arg-types 39 | :reader arg-types) 40 | (effective-type-lists :initarg :effective-type-lists 41 | :initform (error "EFFECTIVE-TYPE-LISTS not specified") 42 | :reader effective-type-lists)) 43 | (:report (lambda (condition s) 44 | (pprint-logical-block (s nil) 45 | (format s "No applicable POLYMORPH discovered for polymorphic-function~% ~S~%" 46 | (name condition)) 47 | (format s "and ARGS:~%~%") 48 | ;; It is possible that argss could be circular (?) 49 | ;; Or that they contain circular structures (?) 50 | (pprint-logical-block (s nil :per-line-prefix " ") 51 | (format s "~S" (args condition))) 52 | (format s "~%~%derived to be of TYPES:~%~%") 53 | (pprint-logical-block (s nil :per-line-prefix " ") 54 | (format s "~S" (if (slot-boundp condition 'arg-types) 55 | (arg-types condition) 56 | (mapcar #'type-of (args condition))))) 57 | ;; So, we only "improve" the printing for effective-type-lists 58 | (let ((*print-circle* nil) 59 | (type-lists (effective-type-lists condition))) 60 | (format s 61 | "~%~%Available Effective-Type-Lists include:~%~{~^~% ~S~}" 62 | (subseq type-lists 63 | 0 (if *print-length* 64 | (min *print-length* (length type-lists)) 65 | nil))) 66 | (when (and *print-length* 67 | (nthcdr *print-length* type-lists)) 68 | (format s "~% ..."))))))) 69 | 70 | (define-condition no-applicable-polymorph/error 71 | (no-applicable-polymorph error) 72 | ()) 73 | 74 | (defun no-applicable-polymorph (name env args &optional arg-types) 75 | (declare (ignore env)) 76 | (if *compiler-macro-expanding-p* 77 | (signal 'no-applicable-polymorph/compiler-note 78 | :name name 79 | :args args 80 | :arg-types arg-types 81 | :effective-type-lists 82 | (polymorphic-function-effective-type-lists (fdefinition name))) 83 | (error 'no-applicable-polymorph/error 84 | :name name 85 | :args args 86 | :effective-type-lists 87 | (polymorphic-function-effective-type-lists (fdefinition name))))) 88 | 89 | (defun note-null-env (form datum &rest arguments) 90 | (let ((*print-pretty* t)) 91 | (format *error-output* "~%Inlining~%") 92 | (pprint-logical-block (*error-output* nil :per-line-prefix " ") 93 | (format *error-output* "~S" form)) 94 | (format *error-output* "~&in null environment is not without warnings:~%") 95 | (pprint-logical-block (*error-output* nil :per-line-prefix " ") 96 | (format *error-output* "~A" 97 | (handler-case (apply #'signal datum arguments) 98 | (condition (c) c)))))) 99 | 100 | (defun note-no-inline (form datum &rest arguments) 101 | (let ((*print-pretty* t)) 102 | (format *error-output* "Will not inline~%~A~%because ~A" 103 | (with-output-to-string (*error-output*) 104 | (pprint-logical-block (*error-output* nil :per-line-prefix " ") 105 | (format *error-output* "~S" form))) 106 | (if (string= "" datum) 107 | "" 108 | (format nil "~&~A" 109 | (handler-case (apply #'signal datum arguments) 110 | (condition (c) c))))))) 111 | -------------------------------------------------------------------------------- /src/lambda-lists/required.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmethod %lambda-list-type ((type (eql 'required)) (lambda-list list)) 4 | (if *lambda-list-typed-p* 5 | (every (lambda (arg) 6 | (valid-parameter-name-p (first arg))) 7 | lambda-list) 8 | (every 'valid-parameter-name-p lambda-list))) 9 | 10 | (def-test type-identification (:suite lambda-list) 11 | (is (eq 'required (lambda-list-type '(a b)))) 12 | (is-error (lambda-list-type '(a 5))) 13 | (is-error (lambda-list-type '(a b &rest)))) 14 | 15 | (defmethod compute-polymorphic-function-lambda-body 16 | ((type (eql 'required)) (untyped-lambda-list list) declaration &optional invalidated-p) 17 | (let ((block-name (blockify-name *name*))) 18 | `((declare ,declaration) 19 | (block ,block-name 20 | ,(cond (invalidated-p 21 | `(progn 22 | (update-polymorphic-function-lambda (fdefinition ',*name*)) 23 | (funcall (fdefinition ',*name*) ,@untyped-lambda-list))) 24 | (t 25 | `(funcall 26 | (cl:the cl:function 27 | (locally 28 | (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 29 | (cond 30 | ,@(loop 31 | :for i :from 0 32 | :for polymorph 33 | :in (polymorphic-function-polymorphs (fdefinition *name*)) 34 | :for static-dispatch-name 35 | := (polymorph-static-dispatch-name polymorph) 36 | :for runtime-applicable-p-form 37 | := (polymorph-runtime-applicable-p-form polymorph) 38 | :collect 39 | `(,runtime-applicable-p-form #',static-dispatch-name)) 40 | (t 41 | (return-from ,block-name 42 | (funcall ,(polymorphic-function-default (fdefinition *name*)) 43 | ',*name* nil (list ,@untyped-lambda-list))))))) 44 | ,@untyped-lambda-list))))))) 45 | 46 | (defmethod %sbcl-transform-arg-lvars-from-lambda-list-form ((type (eql 'required)) 47 | (untyped-lambda-list list)) 48 | (assert (not *lambda-list-typed-p*)) 49 | `(list ,@(loop :for arg :in untyped-lambda-list 50 | :collect `(cons ',arg ,arg)))) 51 | 52 | (defmethod %type-list-compatible-p ((type (eql 'required)) 53 | (type-list list) 54 | (untyped-lambda-list list)) 55 | (length= type-list untyped-lambda-list)) 56 | 57 | (defmethod %type-list-more-specific-p ((type-1 (eql 'required)) 58 | (type-2 (eql 'required)) 59 | list-1 60 | list-2) 61 | (declare (optimize speed) 62 | (type list list-1 list-2)) 63 | (and (length= list-1 list-2) 64 | (loop :for type-1 :in list-1 65 | :for type-2 :in list-2 66 | ;; Return T the moment we find a SUBTYPEP with not TYPE= 67 | ;; The ones before this point should be TYPE= 68 | :do (cond ((type= type-1 type-2) 69 | t) 70 | ((subtypep type-1 type-2) 71 | (return-from %type-list-more-specific-p t)) 72 | (t 73 | (return-from %type-list-more-specific-p nil))) 74 | :finally (return t)))) 75 | 76 | (def-test type-list-subtype-required (:suite type-list-more-specific-p) 77 | (5am:is-true (type-list-more-specific-p '(string string) '(string array))) 78 | (5am:is-false (type-list-more-specific-p '(array string) '(string array))) 79 | (5am:is-true (type-list-more-specific-p '(string array) '(array string))) 80 | (5am:is-false (type-list-more-specific-p '(string string) '(string number))) 81 | (5am:is-false (type-list-more-specific-p '(string string) '(string))) 82 | (5am:is-false (type-list-more-specific-p '((or string number) string) '((or string symbol) array)))) 83 | 84 | (defmethod %type-list-intersection-null-p 85 | ((type-1 (eql 'required)) (type-2 (eql 'required)) list-1 list-2) 86 | (declare (optimize speed) 87 | (type list list-1 list-2)) 88 | (or (/= (length list-1) (length list-2)) 89 | (loop :for type-1 :in list-1 90 | :for type-2 :in list-2 91 | 92 | ;; Return T the moment we have a non-null intersection 93 | ;; without a definite direction of SUBTYPEP 94 | 95 | ;; While going from left to right, 96 | ;; because the CALLER has previously checked that 97 | ;; none of the two type-lists are more specific than the other, 98 | ;; it must mean that the first time the types are different, 99 | ;; their intersection be NIL; if not, there would be ambiguity 100 | 101 | :do (if (type= type-1 type-2) 102 | t 103 | (when (definitive-intersection-null-p type-1 type-2 104 | (when (boundp '*environment*) 105 | *environment*)) 106 | (return-from %type-list-intersection-null-p t))) 107 | :finally (return nil)))) 108 | 109 | (def-test type-list-intersection-null-required 110 | (:suite type-list-intersection-null-p) 111 | (5am:is-false (type-list-intersection-null-p '(string) '(string))) 112 | (5am:is-true (type-list-intersection-null-p '(string string) '(string))) 113 | (5am:is-true (type-list-intersection-null-p '(string string) '(t))) 114 | (5am:is-true (type-list-intersection-null-p '(string string) '(number array))) 115 | (5am:is-false (type-list-intersection-null-p '(string string) '(string array))) 116 | (5am:is-false (type-list-intersection-null-p '(array string) '(string array))) 117 | (5am:is-false (type-list-intersection-null-p '((or string number) string) 118 | '((or string symbol) array))) 119 | (5am:is-true (type-list-intersection-null-p '((or string number) string) 120 | '((or string symbol) number))) 121 | ) 122 | -------------------------------------------------------------------------------- /src/nonlite/sbcl-deftransform.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defun most-specialized-applicable-transform-p (name arg-types-alist type-list) 4 | (declare (optimize debug)) 5 | (let* ((*compiler-macro-expanding-p* t) 6 | (polymorph-may-be (apply #'compiler-retrieve-polymorph name arg-types-alist))) 7 | (when polymorph-may-be 8 | (equalp type-list 9 | (polymorph-type-list polymorph-may-be))))) 10 | 11 | (defun make-sbcl-deftransform-form 12 | (name typed-lambda-list inline-lambda-body polymorph-parameters) 13 | (declare (optimize debug)) 14 | (multiple-value-bind (param-list type-list effective-type-list) 15 | (polymorph-effective-lambda-list polymorph-parameters) 16 | (declare (ignore effective-type-list)) 17 | (let ((lambda-list-type (lambda-list-type typed-lambda-list :typed t)) 18 | (transform-lambda-list (untyped-lambda-list typed-lambda-list))) 19 | (with-gensyms (node env arg arg-lvar-alist compiler-macro-lambda 20 | inline-lambda-body-sym param-list-sym lambda declarations body 21 | arg-types-alist arg-types type arg-syms lvar lvars lvar-syms lvar-sym 22 | arg-sym lvar-types lvar-type compiler-macro-env sym) 23 | 24 | ;; For the polymorph compiler macro: 25 | ;; Firstly, call the COMPILER-MACRO-LAMBDA with SB-C::LVARs 26 | ;; We expect it to be able to deal with them 27 | ;; Secondly, replace any SB-C::LVAR in the result form 28 | ;; with the appropriate variable name 29 | ;; FIXME: SB-CLTL2:MACROEXPAND-ALL does not expand commas 30 | ;; as of SBCL 2.1.5 31 | 32 | `(sb-c:deftransform ,name (,transform-lambda-list 33 | ,(if (eq 'rest lambda-list-type) 34 | (append type-list '(t)) 35 | type-list) 36 | * 37 | :policy (< debug speed) 38 | :node ,node) 39 | 40 | (when *disable-static-dispatch* 41 | (sb-c::abort-ir1-transform)) 42 | 43 | (let* ((,arg-lvar-alist 44 | ,(sbcl-transform-arg-lvars-from-lambda-list-form 45 | transform-lambda-list :typed nil)) 46 | ;; Although we call it LVARS, these may also contain KEYWORDs 47 | (,lvars (mapcar #'rest ,arg-lvar-alist)) 48 | (,lvar-syms (make-gensym-list (length ,lvars))) 49 | (,lvar-types (loop :for ,lvar :in ,lvars 50 | :for ,lvar-type 51 | := (if (typep ,lvar 'sb-c::lvar) 52 | (sb-c::type-specifier 53 | (sb-c::%lvar-derived-type ,lvar)) 54 | (nth-form-type ,lvar nil 0)) 55 | :collect (optima:match ,lvar-type 56 | ((list* 'values ,type _) 57 | ,type) 58 | (_ 59 | ,lvar-type)))) 60 | (,arg-syms (mapcar #'first ,arg-lvar-alist)) 61 | (,arg-types-alist 62 | (mapcar (lambda (,arg) 63 | (if (keywordp ,arg) 64 | (cons ,arg `(eql ,,arg)) 65 | (let ((,type 66 | (sb-c::type-specifier 67 | (sb-c::%lvar-derived-type ,arg)))) 68 | (cons ,arg 69 | (if (eq 'cl:* ,type) 70 | t 71 | (nth 1 ,type)))))) 72 | ,lvars)) 73 | (,arg-types (mapcar #'rest ,arg-types-alist)) 74 | 75 | (,compiler-macro-lambda (polymorph-compiler-macro-lambda 76 | (find-polymorph ',name ',type-list))) 77 | (,env (sb-c::node-lexenv ,node)) 78 | (,compiler-macro-env (augment-environment 79 | (augment-environment 80 | ,env 81 | :variable ,lvar-syms) 82 | :declare (mapcar (lambda (,type ,sym) 83 | (list 'type ,type ,sym)) 84 | ,lvar-types 85 | ,lvar-syms)))) 86 | 87 | (unless (most-specialized-applicable-transform-p 88 | ',name ,arg-types-alist ',type-list) 89 | (sb-c::give-up-ir1-transform)) 90 | 91 | (let ((,inline-lambda-body-sym 92 | (destructuring-bind (,lambda ,param-list-sym ,declarations &body ,body) 93 | ',inline-lambda-body 94 | (declare (ignore ,lambda ,param-list-sym)) 95 | `(cl:lambda ,',param-list 96 | ;; The source of parametric-polymorphism 97 | ,(enhanced-lambda-declarations (polymorph-parameters 98 | (find-polymorph ',name ',type-list)) 99 | ,arg-types) 100 | ,,declarations 101 | ,@,body)))) 102 | 103 | ,(if (eq 'rest lambda-list-type) 104 | ;; Yes, we are returning a LAMBDA-FORM below 105 | ``(cl:lambda ,,arg-syms 106 | ,(if ,compiler-macro-lambda 107 | (translate-body 108 | (macroexpand-all 109 | (funcall ,compiler-macro-lambda 110 | (cons ,inline-lambda-body-sym ,lvar-syms) 111 | ,compiler-macro-env)) 112 | (mapcar (lambda (,lvar-sym ,arg-sym) 113 | (cons ,lvar-sym ,arg-sym)) 114 | ,lvar-syms ,arg-syms)) 115 | `(funcall ,,inline-lambda-body-sym ,@,arg-syms))) 116 | `(if ,compiler-macro-lambda 117 | (translate-body (macroexpand-all 118 | (funcall ,compiler-macro-lambda 119 | (cons ,inline-lambda-body-sym 120 | ,lvar-syms) 121 | ,compiler-macro-env)) 122 | (mapcar (lambda (,lvar-sym ,arg-sym) 123 | (cons ,lvar-sym ,arg-sym)) 124 | ,lvar-syms ,arg-syms)) 125 | `(funcall ,,inline-lambda-body-sym ,@,arg-syms)))))))))) 126 | 127 | (defun make-and-wrap-sbcl-deftransform-form 128 | (env name typed-lambda-list inline-lambda-body parameters) 129 | (let ((sbcl-deftransform-form 130 | (make-sbcl-deftransform-form 131 | name typed-lambda-list inline-lambda-body parameters))) 132 | (if optim-debug 133 | sbcl-deftransform-form ; Leave the form as it is. 134 | `(locally (declare (sb-ext:muffle-conditions style-warning)) 135 | (handler-bind ((style-warning #'muffle-warning)) 136 | ,sbcl-deftransform-form))))) 137 | -------------------------------------------------------------------------------- /src/ensure-type-form.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (define-condition return-type-mismatch (condition) 4 | ((actual :initarg :actual) 5 | (index :initarg :index))) 6 | 7 | (define-condition return-type-mismatch/warning (return-type-mismatch warning) 8 | ((declared :initarg :declared)) 9 | (:report (lambda (c s) 10 | (with-slots (declared actual index) c 11 | (if (member index '(1 2 3)) 12 | (format s (concatenate 13 | 'string 14 | (ecase index 15 | (1 "1st") 16 | (2 "2nd") 17 | (3 "3rd")) 18 | " derived return-type (0-indexed) is~% ~S~%not of declared type~% ~S") 19 | actual declared) 20 | (format s 21 | "~Sth derived return-type (0-indexed) is~% ~S~%not of declared type~% ~S" 22 | index actual declared)))))) 23 | 24 | (define-condition return-type-mismatch/error (return-type-mismatch error) 25 | ((expected :initarg :expected)) 26 | (:report (lambda (c s) 27 | (with-slots (expected actual index) c 28 | (if (member index '(1 2 3)) 29 | (format s (concatenate 30 | 'string 31 | (ecase index 32 | (1 "1st") 33 | (2 "2nd") 34 | (3 "3rd")) 35 | " return-value (0-indexed) is~% ~S~%not of expected type~% ~S") 36 | actual expected) 37 | (format s 38 | "~Sth return-value (0-indexed) is~% ~S~%not of expected type~% ~S" 39 | index actual expected)))))) 40 | 41 | 42 | (define-condition return-type-count-mismatch (condition) 43 | ((min :initarg :min) 44 | (max :initarg :max) 45 | (actual :initarg :actual)) 46 | ;; TODO: Put this to use 47 | (:report (lambda (c s) 48 | (if (slot-boundp c 'max) 49 | (with-slots (min max actual) c 50 | (format s "Expected at least ~S and at most ~S return-values but received ~S" 51 | min max actual)) 52 | (with-slots (min actual) c 53 | (format s "Expected at least ~S return-values but received ~S" 54 | min actual)))))) 55 | 56 | (define-condition return-type-count-mismatch/warning (return-type-count-mismatch warning) 57 | ()) 58 | 59 | (defmacro with-return-type (return-type &body body) 60 | ;; We put the &BODY only for good indentation 61 | (declare (optimize debug)) 62 | (assert (null (cdr body))) 63 | (let* ((form (car body)) 64 | (type (typexpand return-type)) 65 | (optional-position (when (listp type) 66 | (position '&optional type))) 67 | (min-values (cond (optional-position 68 | (1- optional-position)) 69 | ((atom type) 70 | 1) 71 | ((eq 'values (first type)) 72 | (1- (length type))) 73 | (t 74 | 1))) 75 | (rest-supplied-p (when (listp type) 76 | (member '&rest type))) 77 | (rest-p (if optional-position 78 | (member '&rest type) 79 | t)) 80 | (type-forms (if (and (listp type) 81 | (eq 'values (first type))) 82 | (remove '&rest 83 | (remove '&optional 84 | (rest type))) 85 | (list type))) 86 | 87 | (type-forms (loop :for type :in type-forms 88 | :collect `(quote ,type))) 89 | (rest-type-form (if rest-supplied-p 90 | (lastcar type-forms) 91 | t)) 92 | (type-forms (if rest-supplied-p 93 | (butlast type-forms) 94 | type-forms)) 95 | (num-types (length type-forms)) 96 | (form-values (make-gensym-list (length type-forms) "FORM-VALUE")) 97 | (form-value-list (gensym "FORM-VALUE-LIST")) 98 | (num-values (gensym "NUM-VALUES")) 99 | 100 | (ensure-type-forms 101 | (loop :for form-value :in form-values 102 | :for type :in type-forms 103 | :for i :from 0 104 | :collect 105 | `(when ,(cond ((< i min-values) 106 | t) 107 | (t 108 | `(< ,min-values ,num-values))) 109 | (assert (typep ,form-value ,type) 110 | (,form-value) 111 | 'return-type-mismatch/error 112 | :index ,i 113 | :actual ,form-value 114 | :expected ,type))))) 115 | 116 | 117 | `(let* ((,form-value-list (multiple-value-list ,form)) 118 | (,num-values (length ,form-value-list))) 119 | (declare (ignorable ,num-values)) 120 | 121 | ,@(let ((return-type-count-form 122 | (cond ((and optional-position rest-p) 123 | `(assert (<= ,(1- optional-position) 124 | ,num-values) 125 | (,form-value-list) 126 | 'return-type-count-mismatch :min ,min-values :actual ,num-values)) 127 | ((and optional-position (not rest-p)) 128 | `(assert (<= ,(1- optional-position) 129 | ,num-values 130 | ,num-types) 131 | (,form-value-list) 132 | 'return-type-count-mismatch 133 | :min ,min-values :max ,num-types :actual ,num-values)))) 134 | 135 | (rest-type-form 136 | (unless (eq rest-type-form t) 137 | (with-gensyms (value i) 138 | `(loop :for ,value :in (nthcdr ,num-types ,form-value-list) 139 | :for ,i :from ,num-types 140 | :do (assert (typep ,value ,rest-type-form) 141 | (,form-value-list) 142 | 'return-type-mismatch/error 143 | :expected ,rest-type-form 144 | :actual ,value 145 | :index ,i)))))) 146 | (list return-type-count-form 147 | rest-type-form)) 148 | 149 | (multiple-value-bind ,form-values 150 | (values-list ,form-value-list) 151 | (declare (ignorable ,@form-values)) 152 | ,@ensure-type-forms) 153 | 154 | (values-list ,form-value-list)))) 155 | 156 | (defun ensure-type-form (type block-name body &key variable declare) 157 | "Returns two values: a form that has ASSERTs with SIMPLE-TYPE-ERROR to check the type 158 | as well as the type enhanced using TYPE." 159 | (declare (optimize debug)) 160 | (if (macro-function 'with-return-type-in-env) 161 | (values `(with-return-type-in-env (:variable ,variable :declare ,declare) 162 | ,type 163 | (block ,block-name (locally ,@body))) 164 | (uiop:symbol-call '#:polymorphic-functions '#:form-type 165 | `(the ,type (block ,block-name (locally ,@body))) 166 | (uiop:symbol-call '#:cl-environments 167 | '#:augment-environment 168 | nil 169 | :variable variable 170 | :declare declare) 171 | :expand-compiler-macros t)) 172 | (values `(with-return-type ,type 173 | (block ,block-name (locally ,@body))) 174 | type))) 175 | -------------------------------------------------------------------------------- /src/nonlite/ensure-type-form.lisp: -------------------------------------------------------------------------------- 1 | (in-package :polymorphic-functions) 2 | 3 | (defmacro with-return-type-in-env ((&key variable declare) return-type &body body) 4 | ;; We put the &BODY only for good indentation 5 | "Returns two values: a form that has ASSERTs with SIMPLE-TYPE-ERROR to check the type 6 | as well as the type enhanced using TYPE." 7 | (declare (optimize debug)) 8 | (assert (null (cdr body))) 9 | (let* ((env (augment-environment nil :variable variable 10 | :declare declare)) 11 | (form (car body)) 12 | (type (typexpand return-type env)) 13 | (optional-position (when (listp type) 14 | (position '&optional type))) 15 | (min-values (cond (optional-position 16 | (1- optional-position)) 17 | ((atom type) 18 | 1) 19 | ((eq 'values (first type)) 20 | (1- (length type))) 21 | (t 22 | 1))) 23 | (rest-supplied-p (when (listp type) 24 | (member '&rest type))) 25 | (rest-p (if optional-position 26 | (member '&rest type) 27 | t)) 28 | (type-forms (if (and (listp type) 29 | (eq 'values (first type))) 30 | (remove '&rest 31 | (remove '&optional 32 | (rest type))) 33 | (list type))) 34 | 35 | (types type-forms) 36 | (rest-type (if rest-supplied-p 37 | (lastcar types) 38 | t)) 39 | (types (if rest-supplied-p 40 | (butlast types) 41 | types)) 42 | 43 | (type-forms (loop :for type :in type-forms 44 | :collect `(quote ,type))) 45 | (rest-type-form (if rest-supplied-p 46 | (lastcar type-forms) 47 | t)) 48 | (type-forms (if rest-supplied-p 49 | (butlast type-forms) 50 | type-forms)) 51 | (num-types (length type-forms)) 52 | (form-values (make-gensym-list (length type-forms) "FORM-VALUE")) 53 | (form-value-list (gensym "FORM-VALUE-LIST")) 54 | (num-values (gensym "NUM-VALUES")) 55 | 56 | (form-types (let ((may-be-list (form-type form env 57 | :expand-compiler-macros t 58 | :constant-eql-types t))) 59 | (if (and (listp may-be-list) 60 | (eql 'values (first may-be-list))) 61 | (the list (remove '&optional (rest may-be-list))) 62 | (list may-be-list)))) 63 | (form-rest-type (if (member '&rest form-types) 64 | (lastcar form-types) 65 | nil)) 66 | (form-types (if (member '&rest form-types) 67 | (butlast form-types 2) 68 | form-types)) 69 | (num-form-types (length form-types)) 70 | 71 | (ensure-type-forms 72 | (loop :for form-value :in form-values 73 | :for form-type :in form-types 74 | :for type :in type-forms 75 | :for compiler-type :in types 76 | :for i :from 0 77 | :do (multiple-value-bind (nilp knownp) 78 | (subtypep `(and ,form-type ,compiler-type) nil env) 79 | (when (and (not (type= t form-type)) 80 | knownp 81 | nilp) 82 | (warn 'return-type-mismatch/warning 83 | :index i :actual form-type :declared compiler-type))) 84 | :collect 85 | `(when ,(cond ((< i min-values) 86 | t) 87 | (t 88 | `(< ,min-values ,num-values))) 89 | (assert (typep ,form-value ,type) 90 | (,form-value) 91 | 'return-type-mismatch/error 92 | :index ,i 93 | :actual ,form-value 94 | :expected ,type))))) 95 | 96 | 97 | `(let* ((,form-value-list (multiple-value-list ,form)) 98 | (,num-values (length ,form-value-list))) 99 | (declare (ignorable ,num-values)) 100 | 101 | ,@(let ((return-type-count-form 102 | (cond ((and optional-position rest-p) 103 | (when (and (not (<= (1- optional-position) 104 | num-form-types)) 105 | (not form-rest-type)) 106 | (warn 'return-type-count-mismatch/warning 107 | :min min-values :actual num-form-types)) 108 | `(assert (<= ,(1- optional-position) 109 | ,num-values) 110 | (,form-value-list) 111 | 'return-type-count-mismatch :min ,min-values :actual ,num-values)) 112 | ((and optional-position (not rest-p)) 113 | (when (and (not (<= (1- optional-position) 114 | num-form-types 115 | num-types)) 116 | (not form-rest-type)) 117 | (warn 'return-type-count-mismatch/warning 118 | :min min-values :max num-types :actual num-form-types)) 119 | `(assert (<= ,(1- optional-position) 120 | ,num-values 121 | ,num-types) 122 | (,form-value-list) 123 | 'return-type-count-mismatch 124 | :min ,min-values :max ,num-types :actual ,num-values)))) 125 | 126 | (rest-type-form 127 | (unless (eq rest-type-form t) 128 | (loop :for form-type :in (nthcdr num-types form-types) 129 | :for i :from num-types 130 | :do (multiple-value-bind (nilp knownp) 131 | (subtypep `(and ,form-type ,rest-type) nil env) 132 | (when (and (not (type= t form-type)) 133 | knownp 134 | nilp) 135 | (warn 'return-type-mismatch/warning 136 | :index i :actual form-type :declared rest-type))) 137 | :finally 138 | (multiple-value-bind (subtypep knownp) 139 | (subtypep form-rest-type rest-type) 140 | (when (and (not (type= t form-type)) 141 | knownp 142 | (not subtypep)) 143 | (warn 'return-type-mismatch/warning 144 | :index i :actual form-rest-type :declared rest-type)))) 145 | (with-gensyms (value i) 146 | `(loop :for ,value :in (nthcdr ,num-types ,form-value-list) 147 | :for ,i :from ,num-types 148 | :do (assert (typep ,value ,rest-type-form) 149 | (,form-value-list) 150 | 'return-type-mismatch/error 151 | :expected ,rest-type-form 152 | :actual ,value 153 | :index ,i)))))) 154 | (list return-type-count-form 155 | rest-type-form)) 156 | 157 | (multiple-value-bind ,form-values 158 | (values-list ,form-value-list) 159 | (declare (ignorable ,@form-values)) 160 | ,@ensure-type-forms) 161 | 162 | (values-list ,form-value-list)))) 163 | -------------------------------------------------------------------------------- /src/nonlite/specializing.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (define-polymorphic-function specializing-type-of (object) :overwrite t 4 | :documentation "A clean wrapper around CL:TYPE-OF to deal with overspecialized 5 | types returned by CL:TYPE-OF. For instance, often times knowing an array is 6 | (ARRAY SINGLE-FLOAT) can be enough for optimization, (ARRAY SINGLE-FLOAT (2 3 4)) 7 | is an overspecialized type in this sense.") 8 | (declaim (notinline specializing-type-of)) 9 | 10 | (defpolymorph specializing-type-of (object) (or list symbol) 11 | (type-of object)) 12 | 13 | (defpolymorph specializing-type-of ((object array)) (or list symbol) 14 | `(array ,(array-element-type object) ,(array-rank object))) 15 | 16 | (defpolymorph specializing-type-of ((object simple-array)) (or list symbol) 17 | `(simple-array ,(array-element-type object) ,(array-rank object))) 18 | 19 | (defpolymorph specializing-type-of ((object fixnum)) (or list symbol) 20 | (declare (ignore object)) 21 | 'fixnum) 22 | 23 | (defpolymorph specializing-type-of ((object (signed-byte 32))) (or list symbol) 24 | (declare (ignore object)) 25 | '(signed-byte 32)) 26 | 27 | (defun add-specialization (new-specialization table &rest arg-values) 28 | "NEW-SPECIALIZATION should be a list of two elements 29 | TYPE-LIST SPECIALIZED-LAMBDA" 30 | (let* ((new-type-list (first new-specialization)) 31 | (specialization-position 32 | (loop :for position :from 0 33 | :for old-specialization :in table 34 | :for old-type-list := (first old-specialization) 35 | :while (type-list-more-specific-p old-type-list new-type-list) 36 | :finally (return position))) 37 | (all-specializations 38 | (nconc (subseq table 0 specialization-position) 39 | (list new-specialization) 40 | (subseq table specialization-position))) 41 | (args (make-gensym-list (length arg-values)))) 42 | (cons (compile nil 43 | `(cl:lambda (,@args) 44 | (declare (optimize speed) 45 | #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note) 46 | (compiler-macro-notes:muffle 47 | compiler-macro-notes:optimization-failure-note)) 48 | (cond ,@(mapcar (lambda (specialization) 49 | (destructuring-bind 50 | (type-list specialized-lambda) 51 | specialization 52 | `((and ,@(loop :for type :in type-list 53 | :for arg :in args 54 | :collect `(typep ,arg ',type))) 55 | ,specialized-lambda))) 56 | all-specializations)))) 57 | all-specializations))) 58 | 59 | (defvar *specialization-table* (trivial-garbage:make-weak-hash-table) 60 | "A weak-hash-table mapping a global specialization-idx counter to 61 | a CONS containing the specialization-dispatcher-lambda as the CAR 62 | and the specializations as the CDR.") 63 | 64 | (declaim (type hash-table *specialization-table*)) 65 | (defvar *specialization-count* 0) 66 | 67 | (defmacro specializing (vars &body body) 68 | "Analogous to SPECIALIZED-FUNCTION:SPECIALIZING. 69 | 70 | At runtime, compiles and caches a function corresponding to the 71 | runtime types of VARS, with (OPTIMIZE SPEED) declaration. 72 | Uses SPECIALIZING-TYPE-OF to avoid overspecializing types. 73 | The function is compiled in a null lexical environment, with 74 | only access to variables specified in VARS. 75 | 76 | POLYMORPHIC-FUNCTIONS> (defun dot-original (a b c) 77 | (declare (optimize (speed 3))) 78 | (loop 79 | for ai across a 80 | for bi across b 81 | do (incf c (* ai bi))) 82 | c) 83 | DOT-ORIGINAL 84 | POLYMORPHIC-FUNCTIONS> (let ((a (aops:rand* 'single-float 10000)) 85 | (b (aops:rand* 'single-float 10000))) 86 | (time (loop repeat 1000 do (dot-original a b 0.0f0)))) 87 | Evaluation took: 88 | 0.516 seconds of real time 89 | 0.515704 seconds of total run time (0.515704 user, 0.000000 system) 90 | 100.00% CPU 91 | 1,138,873,226 processor cycles 92 | 0 bytes consed 93 | 94 | NIL 95 | POLYMORPHIC-FUNCTIONS> (defun dot-specialized (a b c) 96 | (specializing (a b c) 97 | (declare (optimize (speed 3))) 98 | (loop 99 | for ai across a 100 | for bi across b 101 | do (incf c (* ai bi))) 102 | c)) 103 | DOT-SPECIALIZED 104 | POLYMORPHIC-FUNCTIONS> (let ((a (aops:rand* 'single-float 10000)) 105 | (b (aops:rand* 'single-float 10000))) 106 | (time (loop repeat 1000 do (dot-specialized a b 0.0f0)))) 107 | Evaluation took: 108 | 0.076 seconds of real time 109 | 0.076194 seconds of total run time (0.076194 user, 0.000000 system) 110 | 100.00% CPU 111 | 4 forms interpreted 112 | 27 lambdas converted 113 | 168,267,912 processor cycles 114 | 1,502,576 bytes consed ; runtime compilation overhead on first call 115 | 116 | NIL 117 | POLYMORPHIC-FUNCTIONS> (let ((a (aops:rand* 'single-float 10000)) 118 | (b (aops:rand* 'single-float 10000))) 119 | (time (loop repeat 1000 do (dot-specialized a b 0.0f0)))) 120 | Evaluation took: 121 | 0.080 seconds of real time 122 | 0.078954 seconds of total run time (0.078954 user, 0.000000 system) 123 | 98.75% CPU 124 | 174,478,140 processor cycles 125 | 0 bytes consed 126 | 127 | NIL 128 | 129 | Note that as of this writing, compiling a specialized variant still 130 | requires at least one runtime dispatch to take place; as such this 131 | is only useful if the specialized variant offsets the cost of dispatch, 132 | and may not be useful for wrapping around simple functions such as addition 133 | of two numbers, but only for more expensive functions such as element-wise 134 | addition of two 10000-sized vectors. 135 | 136 | In addition, this is not suitable for mutating variables outside the 137 | SPECIALIZING form. 138 | " 139 | (assert (every #'symbolp vars)) 140 | (let ((specialization-idx *specialization-count*)) 141 | (incf *specialization-count*) 142 | (with-gensyms (specialized-lambda var-types var-type var add-new-specialization) 143 | `(flet ((,add-new-specialization () 144 | (let* ((,var-types (mapcar #'specializing-type-of (list ,@vars))) 145 | (,specialized-lambda 146 | (compile nil `(lambda ,',vars 147 | (declare (optimize speed)) 148 | (declare ,@(loop :for ,var :in ',vars 149 | :for ,var-type :in ,var-types 150 | :collect (list 151 | 'type 152 | ,var-type 153 | ,var))) 154 | ,@',body)))) 155 | (setf (gethash ,specialization-idx *specialization-table*) 156 | (add-specialization 157 | (list 158 | (list ,@(loop :For var :in vars 159 | :collect `(specializing-type-of ,var))) 160 | ,specialized-lambda) 161 | (cdr (gethash ,specialization-idx *specialization-table*)) 162 | ,@vars)) 163 | ,specialized-lambda))) 164 | (let* ((,specialized-lambda 165 | (if (gethash ,specialization-idx *specialization-table*) 166 | (or (funcall (cl:the cl:function 167 | (car (gethash ,specialization-idx *specialization-table*))) 168 | ,@vars) 169 | (,add-new-specialization)) 170 | (,add-new-specialization)))) 171 | (declare (type cl:function ,specialized-lambda)) 172 | (funcall ,specialized-lambda ,@vars)))))) 173 | -------------------------------------------------------------------------------- /src/nonlite/polymorph-compiler-macro.lisp: -------------------------------------------------------------------------------- 1 | (in-package :polymorphic-functions) 2 | 3 | (defun compiler-retrieve-polymorph (name &rest arg-types-alist) 4 | (declare (type function-name name)) 5 | (assert *compiler-macro-expanding-p*) 6 | ;; This function is used by the main compiler macro of the polymorphic-function 7 | ;; The RETRIEVE-POLYMORPH-FORM below is a complementary to this function. 8 | (let* ((apf (fdefinition name)) 9 | (polymorphs (polymorphic-function-polymorphs apf)) 10 | (num-args (length arg-types-alist))) 11 | (declare (optimize debug)) 12 | (loop :for polymorph :in polymorphs 13 | :for lambda-list-type := (polymorph-lambda-list-type polymorph) 14 | :for type-list := (polymorph-type-list polymorph) 15 | :for app-p-lambda := (polymorph-compiler-applicable-p-lambda polymorph) 16 | :do (when (block app-p-lambda 17 | (case lambda-list-type 18 | (required 19 | (if (= num-args (length type-list)) 20 | (apply app-p-lambda arg-types-alist) 21 | nil)) 22 | (required-optional 23 | (if (<= (position '&optional type-list) 24 | num-args 25 | (1- (length type-list))) 26 | (apply app-p-lambda arg-types-alist) 27 | nil)) 28 | (required-key 29 | (let ((key-pos (position '&key type-list))) 30 | (if (and (evenp (- num-args key-pos)) 31 | (<= key-pos 32 | num-args 33 | (+ key-pos (* 2 (- (length type-list) key-pos 1))))) 34 | (apply app-p-lambda 35 | (loop :for (arg . arg-type) :in arg-types-alist 36 | :for idx :from 0 37 | :with keyword-start := key-pos 38 | :if (and (>= idx keyword-start) 39 | (evenp (- idx keyword-start))) 40 | :collect (if (and (listp arg-type) 41 | ;; FIXME: Use CTYPE 42 | (member (first arg-type) 43 | '(eql member)) 44 | (null (cddr arg-type))) 45 | (second arg-type) 46 | (return-from app-p-lambda nil)) 47 | :else 48 | :collect (cons arg arg-type))) 49 | nil))) 50 | (rest 51 | (if (<= (position '&rest type-list) 52 | num-args) 53 | (apply app-p-lambda arg-types-alist) 54 | nil)))) 55 | (return-from compiler-retrieve-polymorph polymorph))))) 56 | 57 | (defun register-polymorph-compiler-macro (name type-list lambda &optional source) 58 | (declare (type function-name name) 59 | (type type-list type-list) 60 | (type function lambda)) 61 | ;; TODO: Comment why this became impossible 62 | (assert (find-polymorph name type-list) 63 | () 64 | "Illegal to have a POLYMORPH-COMPILER-MACRO without a corresponding POLYMORPH") 65 | (let* ((apf (fdefinition name)) 66 | (lambda-list (polymorphic-function-effective-lambda-list apf)) 67 | (lambda-list-type (polymorphic-function-lambda-list-type apf)) 68 | (type-list (type-list-order-keywords type-list))) 69 | (if (eq lambda-list-type 'rest) 70 | ;; required-optional can simply be split up into multiple required or required-key 71 | (assert (not (member '&optional type-list)) 72 | nil 73 | "&OPTIONAL keyword is not allowed for LAMBDA-LIST~% ~S~%of the POLYMORPHIC-FUNCTION associated with ~S" 74 | lambda-list name) 75 | (assert (type-list-compatible-p lambda-list-type type-list lambda-list) 76 | nil 77 | "TYPE-LIST ~S is not compatible with the LAMBDA-LIST ~S of the POLYMORPHs associated with ~S" 78 | type-list lambda-list name)) 79 | ;; FIXME: How should we account for EFFECTIVE-TYPE-LIST here? 80 | (ensure-unambiguous-call name type-list type-list) 81 | (let ((polymorph (find type-list (polymorphic-function-polymorphs apf) 82 | :test #'equalp 83 | :key #'polymorph-type-list))) 84 | (setf (polymorph-compiler-macro-lambda polymorph) lambda) 85 | (setf (polymorph-compiler-macro-source polymorph) source)))) 86 | 87 | (defun retrieve-polymorph-compiler-macro (name &rest arg-list) 88 | (declare (type function-name name)) 89 | (let* ((apf (fdefinition name)) 90 | (polymorphs (polymorphic-function-polymorphs apf)) 91 | (type-lists (polymorphic-function-type-lists apf)) 92 | (apf-lambda-list-type (polymorphic-function-lambda-list-type apf)) 93 | (applicable-polymorphs 94 | (loop :for polymorph :in polymorphs 95 | :if (if (eq 'rest apf-lambda-list-type) 96 | (ignore-errors 97 | (apply 98 | (the function 99 | (polymorph-compiler-applicable-p-lambda polymorph)) 100 | arg-list)) 101 | (apply 102 | (the function 103 | (polymorph-compiler-applicable-p-lambda polymorph)) 104 | arg-list)) 105 | :collect polymorph))) 106 | (case (length applicable-polymorphs) 107 | (1 (polymorph-compiler-macro-lambda (first applicable-polymorphs))) 108 | (0 (error 'no-applicable-polymorph/error 109 | :arg-list arg-list :type-lists type-lists)) 110 | (t (error "Multiple applicable POLYMORPHs discovered for ARG-LIST ~S:~%~{~S~^ ~%~}" 111 | arg-list 112 | (mapcar #'polymorph-type-list applicable-polymorphs)))))) 113 | 114 | 115 | (defmacro defpolymorph-compiler-macro (name type-list compiler-macro-lambda-list 116 | &body body) 117 | "Example TYPE-LISTs: 118 | (NUMBER NUMBER) 119 | (STRING &OPTIONAL INTEGER) 120 | (STRING &KEY (:ARG INTEGER)) 121 | (NUMBER &REST)" 122 | (declare (type function-name name) 123 | (type type-list type-list)) 124 | `(eval-when (:compile-toplevel :load-toplevel :execute) 125 | (register-polymorph-compiler-macro 126 | ',name ',type-list 127 | (compile nil (parse-compiler-macro ',(if (and (listp name) 128 | (eq 'setf (first name))) 129 | (second name) 130 | name) 131 | ',compiler-macro-lambda-list 132 | ',body)) 133 | #+sbcl (sb-c:source-location)) 134 | ',name)) 135 | 136 | (define-declaration type-like (vars env) 137 | ;; FIXME: Consequences of emitting CL:TYPE declaration are undefined 138 | ;; On CCL, args starts with DECL-NAME while not using CL-ENVIRONMENTS-CL 139 | ;; Other times, it starts with the appropriate args 140 | (destructuring-bind (original &rest similar) (optima:match vars 141 | ((list* 'type-like vars) 142 | vars) 143 | (_ vars)) 144 | (values :variable 145 | (loop :with type 146 | := (rest (assoc 'cl:type 147 | (nth-value 2 (variable-information original env)))) 148 | :for var :in similar 149 | :collect `(,var cl:type ,type))))) 150 | 151 | (define-declaration inline-pf (vars env) 152 | (values :function 153 | (loop :for var :in vars 154 | :collect `(,var inline-pf inline-pf)))) 155 | 156 | (define-declaration notinline-pf (vars env) 157 | (values :function 158 | (loop :for var :in vars 159 | :collect `(,var inline-pf notinline-pf)))) 160 | 161 | (define-declaration pf-defined-before-use (args) 162 | #+sbcl (declare (ignore args)) 163 | (values :declare 164 | (cons 'pf-defined-before-use t))) 165 | 166 | (define-declaration not-pf-defined-before-use (args) 167 | #+sbcl (declare (ignore args)) 168 | (values :declare 169 | (cons 'pf-defined-before-use nil))) 170 | -------------------------------------------------------------------------------- /src/types.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (5am:in-suite :polymorphic-functions) 4 | 5 | (defstruct polymorph-parameters 6 | required 7 | optional 8 | rest 9 | keyword 10 | min-args 11 | max-args 12 | validator-form) 13 | 14 | (defmethod print-object ((o polymorph-parameters) s) 15 | (with-slots (required optional rest keyword) o 16 | (format s "# s))) 32 | 33 | (defstruct (polymorph-parameter (:conc-name pp-)) 34 | " 35 | LOCAL-NAME : Name inside the body of the polymorph 36 | FORM-IN-PF : The form which yields the parameter's value inside the lexical 37 | environment of the polymorphic-function 38 | 39 | Note: Only LOCAL-NAME and FORM-IN-PF are relevant for &REST parameter 40 | " 41 | local-name 42 | form-in-pf 43 | value-type 44 | default-value-form 45 | supplied-p-name 46 | value-effective-type) 47 | 48 | (defstruct polymorph 49 | " 50 | - If RUNTIME-APPLICABLE-P-FORM returns true when evaluated inside the lexical environment 51 | of the polymorphic-function, then the dispatch is done on LAMBDA. The prioritization 52 | is done by ADD-OR-UPDATE-POLYMORPH so that a more specialized polymorph is checked 53 | for compatibility before a less specialized polymorph. 54 | - The PF-COMPILER-MACRO calls the COMPILER-APPLICABLE-P-LAMBDA with the FORM-TYPEs 55 | of the arguments derived at compile time. The compiler macro dispatches on the polymorph 56 | at compile time if the COMPILER-APPLICABLE-P-LAMBDA returns true. 57 | 58 | - If this POLYMORPH is used for INLINE-ing or STATIC-DISPATCH and if MORE-OPTIMAL-TYPE-LIST 59 | or SUBOPTIMAL-NOTE is non-NIL, then emits a OPTIMIZATION-FAILURE-NOTE 60 | " 61 | (documentation nil :type (or null string)) 62 | (name (error "NAME must be supplied!")) 63 | (source) 64 | (return-type) 65 | (type-list nil) 66 | (lambda-list-type nil) 67 | (typed-lambda-list nil) 68 | (effective-type-list nil) 69 | (more-optimal-type-list nil) 70 | (suboptimal-note nil) 71 | (compiler-applicable-p-lambda) 72 | (runtime-applicable-p-form) 73 | (inline-p) 74 | (inline-lambda-body) 75 | (static-dispatch-name) 76 | (compiler-macro-lambda) 77 | (compiler-macro-source) 78 | (parameters (error "POLYMORPH-PARAMETERS must be supplied") :type polymorph-parameters)) 79 | 80 | (defmethod print-object ((o polymorph) stream) 81 | (print-unreadable-object (o stream :type t) 82 | (with-slots (name type-list) o 83 | (format stream "~S ~S" name type-list)))) 84 | 85 | (with-eval-always 86 | (defun sbcl-version-spec-list (&optional version) 87 | (let ((spec-list (uiop:split-string (or version (lisp-implementation-version)) 88 | :separator '(#\.)))) 89 | (cond ((nth 2 spec-list) ; there are atleast three elements 90 | (handler-case (loop :for elt :in spec-list 91 | :collect (parse-integer elt :junk-allowed t)) 92 | (parse-error () `(0 0 0)))) 93 | (t 94 | `(0 0 0))))) 95 | 96 | (defun sbcl-version-spec-integer (&optional version) 97 | (destructuring-bind (major-1 major-2 minor &rest sub-minor) 98 | (sbcl-version-spec-list version) 99 | (declare (ignore sub-minor)) 100 | (+ (* 12 (+ (* 10 major-1) major-2)) 101 | minor)))) 102 | 103 | (define-constant +optimize-speed-or-compilation-speed+ 104 | ;; optimize for compilation-speed for SBCL>2.2.3 else for speed 105 | (if (and (string= "SBCL" (lisp-implementation-type)) 106 | (let ((spec-integer (sbcl-version-spec-integer (lisp-implementation-version)))) 107 | (if (zerop spec-integer) 108 | (progn 109 | (warn "Detected implementation to be SBCL but could not parse version ~A as X.Y.Z~%Optimizing polymorphic-functions for compilation-speed." (lisp-implementation-version)) 110 | t) 111 | (< (sbcl-version-spec-integer "2.2.3") 112 | spec-integer)))) 113 | `(optimize compilation-speed) 114 | `(optimize speed)) 115 | :test #'equal) 116 | 117 | (defclass polymorphic-function () 118 | ((name :initarg :name 119 | :initform (error "NAME must be supplied.") 120 | :reader polymorphic-function-name) 121 | (source :initarg :source :reader polymorphic-function-source) 122 | (lambda-list :initarg :lambda-list :type list 123 | :initform (error "LAMBDA-LIST must be supplied.") 124 | :reader polymorphic-function-lambda-list) 125 | (effective-lambda-list :initarg :effective-lambda-list :type list 126 | :initform (error "EFFECTIVE-LAMBDA-LIST must be supplied.") 127 | :reader polymorphic-function-effective-lambda-list) 128 | (lambda-list-type :type lambda-list-type 129 | :initarg :lambda-list-type 130 | :initform (error "LAMBDA-LIST-TYPE must be supplied.") 131 | :reader polymorphic-function-lambda-list-type) 132 | (dispatch-declaration :initarg :dispatch-declaration 133 | :initform +optimize-speed-or-compilation-speed+ 134 | :accessor polymorphic-function-dispatch-declaration) 135 | (default :initarg :default 136 | :initform (error ":DEFAULT must be supplied") 137 | :reader polymorphic-function-default 138 | :type function) 139 | (polymorphs :initform nil 140 | :accessor polymorphic-function-polymorphs) 141 | (documentation :initarg :documentation 142 | :type (or string null) 143 | :accessor polymorphic-function-documentation) 144 | (invalidated-p :accessor polymorphic-function-invalidated-p 145 | :initform nil) 146 | #+sbcl (%lock 147 | :initform (sb-thread:make-mutex :name "GF lock") 148 | :reader sb-pcl::gf-lock)) 149 | ;; TODO: Check if a symbol / list denotes a type 150 | (:metaclass closer-mop:funcallable-standard-class)) 151 | 152 | (defmethod print-object ((o polymorphic-function) stream) 153 | (print-unreadable-object (o stream :type t) 154 | (with-slots (name polymorphs) o 155 | (format stream "~S (~S)" name (length polymorphs))))) 156 | 157 | (defun type-list-p (list) 158 | ;; TODO: what parameter-names are valid? 159 | (let ((valid-p t)) 160 | (loop :for elt := (first list) 161 | :while (and list valid-p) ; we don't want list to be empty 162 | :until (member elt '(&key &rest)) 163 | :do (setq valid-p 164 | (and valid-p 165 | (cond ((eq '&optional elt) 166 | t) 167 | ((member elt lambda-list-keywords) 168 | nil) 169 | (t 170 | t)))) 171 | (setq list (rest list))) 172 | (when valid-p 173 | (cond ((eq '&key (first list)) 174 | (when list 175 | (loop :for param-type :in (rest list) 176 | :do (setq valid-p (and (listp param-type) 177 | (cdr param-type) 178 | (null (cddr param-type))))))) 179 | ((eq '&rest (first list)) 180 | (unless (null (rest list)) 181 | (setq valid-p nil))) 182 | (list 183 | (setq valid-p nil)))) 184 | valid-p)) 185 | 186 | (def-test type-list () 187 | (5am:is-true (type-list-p '())) 188 | (5am:is-true (type-list-p '(number string))) 189 | (5am:is-true (type-list-p '(number string &rest))) 190 | (5am:is-true (type-list-p '(&optional))) 191 | (5am:is-true (type-list-p '(&key))) 192 | (5am:is-true (type-list-p '(&rest))) 193 | (5am:is-true (type-list-p '(number &optional string))) 194 | (5am:is-true (type-list-p '(number &key (:a string))))) 195 | 196 | (deftype type-list () `(satisfies type-list-p)) 197 | 198 | (defun type-list-order-keywords (type-list) 199 | (let ((key-position (position '&key type-list))) 200 | (if key-position 201 | (append (subseq type-list 0 (1+ key-position)) 202 | (sort (copy-list (subseq type-list (1+ key-position))) #'string< :key #'first)) 203 | type-list))) 204 | 205 | (define-constant +lambda-list-types+ 206 | (list 'required 207 | 'required-optional 208 | 'required-key 209 | 'rest) 210 | :test #'equalp) 211 | 212 | (defun lambda-list-type-p (object) 213 | "Checks whhether the OBJECT is in +LAMBDA-LIST-TYPES+" 214 | (member object +lambda-list-types+)) 215 | 216 | (deftype lambda-list-type () `(satisfies lambda-list-type-p)) 217 | 218 | (defun untyped-lambda-list-p (lambda-list) 219 | (ignore-errors (lambda-list-type lambda-list))) 220 | (defun typed-lambda-list-p (lambda-list) 221 | (ignore-errors (lambda-list-type lambda-list :typed t))) 222 | (deftype untyped-lambda-list () 223 | "Examples: 224 | (a b) 225 | (a b &optional c) 226 | Non-examples: 227 | ((a string))" 228 | `(satisfies untyped-lambda-list-p)) 229 | (deftype typed-lambda-list () 230 | "Examples: 231 | ((a integer) (b integer)) 232 | ((a integer) &optional ((b integer) 0 b-supplied-p))" 233 | `(satisfies typed-lambda-list-p)) 234 | -------------------------------------------------------------------------------- /src/misc-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (5am:in-suite :polymorphic-functions) 4 | 5 | (defmacro ignoring-error-output (&body body) 6 | `(let ((*error-output* (make-string-output-stream)) 7 | (*disable-static-dispatch* nil)) 8 | (handler-bind ((warning #'muffle-warning)) 9 | ,@body))) 10 | 11 | ;; unwind-protect (apparantly) does not have an effect in the def-test forms below :/ 12 | 13 | (def-test required-args-correctness () 14 | (ignoring-error-output 15 | (eval `(progn 16 | (define-polymorphic-function my= (a b) :overwrite t) 17 | (defpolymorph my= ((a string) (b string)) boolean 18 | (return-from my= (string= a b))) 19 | (defpolymorph my= ((a number) (b number)) boolean 20 | (= a b))))) 21 | (ignoring-error-output 22 | (eval `(let ((obj1 "hello") 23 | (obj2 "world") 24 | (obj3 "hello") 25 | (obj4 5) 26 | (obj5 5.0)) 27 | (is (eq t (my= obj1 obj3))) 28 | (is (eq nil (my= obj1 obj2))) 29 | (is (eq t (my= obj4 obj5))) 30 | (is-error (my= obj1 obj4))))) 31 | (undefine-polymorphic-function 'my=)) 32 | 33 | (def-test optional-args-correctness () 34 | (ignoring-error-output 35 | (eval `(progn ; This requires SBCL version 2.0.9+ 36 | (define-polymorphic-function bar (a &optional b c) :overwrite t) 37 | (defpolymorph bar ((str string) &optional ((b integer) 5) ((c integer) 7)) t 38 | (list str b c))))) 39 | (is (equal (eval `(bar "hello")) 40 | '("hello" 5 7))) 41 | (is (equal (eval `(bar "hello" 6)) 42 | '("hello" 6 7))) 43 | (is (equal (eval `(bar "hello" 6 9)) 44 | '("hello" 6 9))) 45 | (undefine-polymorphic-function 'bar)) 46 | 47 | (def-test typed-key-correctness () 48 | (ignoring-error-output 49 | (eval `(progn 50 | (define-polymorphic-function foobar (a &key key b) :overwrite t) 51 | (defpolymorph foobar ((str string) &key ((key number) 5) ((b string) "world")) t 52 | (declare (ignore str)) 53 | (list 'string key b)) 54 | (defpolymorph foobar ((num number) &key ((key number) 6) ((b string) "world")) t 55 | (declare (ignore num)) 56 | (list 'number key b))))) 57 | (is (equal '(string 5 "world") (eval `(foobar "hello")))) 58 | (is (equal '(string 5.6 "world") (eval `(foobar "hello" :key 5.6)))) 59 | (is (equal '(number 6 "world") (eval `(foobar 5.6)))) 60 | (is (equal '(number 9 "world") (eval `(foobar 5.6 :key 9)))) 61 | (is (equal '(number 6 "bye") (eval `(foobar 5.6 :b "bye")))) 62 | (is (equal '(number 4.4 "bye") (eval `(foobar 5.6 :b "bye" :key 4.4)))) 63 | (undefine-polymorphic-function 'foobar)) 64 | 65 | (def-test rest-correctness-1 () 66 | (ignoring-error-output 67 | (eval `(define-polymorphic-function my+ (arg &rest args) :overwrite t)) 68 | (eval `(progn 69 | (defpolymorph my+ ((num number) &rest numbers) number 70 | (if numbers 71 | (+ num (apply 'my+ numbers)) 72 | num)) 73 | (defpolymorph my+ ((l list) &rest lists) list 74 | (apply 'append l lists)) 75 | (defpolymorph my+ ((str string) (num number) &key ((coerce t) nil)) string 76 | (if coerce 77 | (uiop:strcat str (write-to-string num)) 78 | str))))) 79 | (is (eq 9 (eval `(my+ 2 3 4)))) 80 | (is (equal '(1 2 3) (eval `(my+ '(1 2) '(3))))) 81 | #+(or sbcl ccl ecl cmucl) 82 | (is (string= "hello5" (eval `(my+ "hello" 5 :coerce t)))) 83 | (undefine-polymorphic-function 'my+)) 84 | 85 | (def-test rest-correctness-2 () 86 | (ignoring-error-output 87 | (unwind-protect 88 | (progn 89 | (eval 90 | `(progn 91 | (define-polymorphic-function rest-tester (a &rest args) :overwrite t) 92 | (defpolymorph rest-tester ((a number) &key ((b number) 0)) number 93 | (+ a b)) 94 | (defpolymorph rest-tester ((a number) (b number) &key ((c number) 0)) number 95 | (+ a b c))))) 96 | (is (= 4 (eval `(rest-tester 4)))) 97 | (is (= 6 (eval `(rest-tester 4 :b 2)))) 98 | (is (= 6 (eval `(rest-tester 4 2)))) 99 | (is (= 8 (eval `(rest-tester 4 2 :c 2))))))) 100 | 101 | (def-test undefpolymorph () 102 | (ignoring-error-output 103 | (eval '(define-polymorphic-function undefpolymorph-tester (a) :overwrite t)) 104 | (eval '(progn 105 | (defpolymorph undefpolymorph-tester ((a list)) symbol 106 | (declare (ignore a)) 107 | 'list) 108 | (defpolymorph undefpolymorph-tester ((a string)) symbol 109 | (declare (ignore a)) 110 | 'string))) 111 | (eval `(locally (declare (notinline undefpolymorph-tester)) 112 | (is (equal 'list (undefpolymorph-tester '(a)))) 113 | (is (equal 'string (undefpolymorph-tester "hello"))) 114 | (undefpolymorph 'undefpolymorph-tester '(list)) 115 | (is-error (undefpolymorph-tester '(a))) 116 | (is (equal 'string (undefpolymorph-tester "hello"))))) 117 | (undefine-polymorphic-function 'fmakunbound-tester))) 118 | 119 | (def-test undefine-polymorphic-function () 120 | (ignoring-error-output 121 | (eval '(progn 122 | (define-polymorphic-function undefine-polymorphic-function-tester (a) :overwrite t) 123 | (defpolymorph undefine-polymorphic-function-tester ((a list)) symbol 124 | (declare (ignore a)) 125 | 'list) 126 | (defpolymorph undefine-polymorphic-function-tester ((a string)) symbol 127 | (declare (ignore a)) 128 | 'string))) 129 | (eval `(locally (declare (notinline undefine-polymorphic-function-tester)) 130 | (is (equal 'list (undefine-polymorphic-function-tester '(a)))) 131 | (is (equal 'string (undefine-polymorphic-function-tester "hello"))) 132 | (undefine-polymorphic-function 'undefine-polymorphic-function-tester) 133 | (is-error (undefine-polymorphic-function-tester '(a))) 134 | (is-error (undefine-polymorphic-function-tester "hello")))) 135 | (undefine-polymorphic-function 'undefine-polymorphic-function-tester))) 136 | 137 | (def-test ambiguous-type-lists () 138 | (ignoring-error-output 139 | (eval `(progn 140 | (undefine-polymorphic-function 'ambiguous-type-lists-tester) 141 | (define-polymorphic-function ambiguous-type-lists-tester (&key a) :overwrite t) 142 | (defpolymorph ambiguous-type-lists-tester (&key ((a string) "")) t 143 | (declare (ignore a))))) 144 | (is-error (eval `(defpolymorph ambiguous-type-lists-tester (&key ((a (or simple-string number)) 5)) t 145 | (declare (ignore a))))) 146 | (is-error (eval `(defpolymorph ambiguous-type-lists-tester 147 | (&key ((a (and array (not string))) #())) t 148 | (declare (ignore a))))) 149 | (eval `(undefpolymorph 'ambiguous-type-lists-tester 150 | '(&key (:a (and array (not string)))))) 151 | (eval `(undefpolymorph 'ambiguous-type-lists-tester 152 | '(&key (:a string)))) 153 | (5am:is-true (eval `(defpolymorph ambiguous-type-lists-tester (&key ((a array) #())) t 154 | (declare (ignore a))))) 155 | (5am:is-true (eval `(defpolymorph ambiguous-type-lists-tester (&key ((a string) "")) t 156 | (declare (ignore a))))) 157 | (eval `(undefine-polymorphic-function 'ambiguous-type-lists-tester)))) 158 | 159 | (def-test specialized-type-lists () 160 | (ignoring-error-output 161 | (eval `(progn 162 | (undefine-polymorphic-function 'most-specialized-polymorph-tester) 163 | (define-polymorphic-function most-specialized-polymorph-tester (a)) 164 | (defpolymorph most-specialized-polymorph-tester ((a string)) symbol 165 | (declare (ignore a)) 166 | 'string) 167 | (defpolymorph most-specialized-polymorph-tester ((a array)) symbol 168 | (declare (ignore a)) 169 | 'array))) 170 | (eval `(let ((a "string") 171 | (b #(a r r a y))) 172 | (5am:is-true (eq 'string (most-specialized-polymorph-tester a))) 173 | (5am:is-true (eq 'array (most-specialized-polymorph-tester b))))) 174 | (eval `(undefine-polymorphic-function 'most-specialized-polymorph-tester)))) 175 | 176 | (def-test once-only () 177 | (ignoring-error-output 178 | (eval `(progn 179 | (define-polymorphic-function my= (&key a b) :overwrite t) 180 | (defpolymorph my= (&key ((a number) 0) ((b number) 0)) boolean 181 | (= a b))))) 182 | (is (= 3 (eval `(let ((a 1)) 183 | (my= :a (incf a) :b (incf a)) 184 | a)))) 185 | (undefine-polymorphic-function 'my=)) 186 | 187 | (def-test setf-polymorphs () 188 | (ignoring-error-output 189 | (eval `(progn 190 | (define-polymorphic-function (setf foo) (a b) :overwrite t) 191 | (defpolymorph (setf foo) ((a number) (b number)) t 192 | (list a b))))) 193 | (is (equal '(2 3) (eval '(funcall #'(setf foo) 2 3)))) 194 | (undefine-polymorphic-function '(setf foo))) 195 | 196 | 197 | (def-test return-type-check () 198 | (ignoring-error-output 199 | (eval `(progn 200 | (defun my-identity (x) x) 201 | (define-polymorphic-function foo (x) :overwrite t)))) 202 | 203 | ;; Basic 204 | (5am:is-true (eval `(defpolymorph foo ((x string)) string x))) 205 | (5am:is-true (eval `(defpolymorph foo ((x string)) string (my-identity x)))) 206 | (5am:is-true (eval `(defpolymorph foo ((x string)) 207 | (values string number) 208 | (values x 5 #\a)))) 209 | 210 | ;; Optional 211 | (5am:is-true (eval `(defpolymorph foo ((x string)) 212 | (values string number &optional) 213 | (values x 5)))) 214 | ;; Rest 215 | (5am:is-true (eval `(defpolymorph foo ((x string)) 216 | (values string number &rest t) 217 | (values x 5)))) 218 | (5am:is-true (eval `(defpolymorph foo ((x string)) 219 | (values string number &rest t) 220 | (values x 5 #\a)))) 221 | 222 | ;; Optional and Rest 223 | (5am:is-true (eval `(defpolymorph foo ((x string)) 224 | (values string number &optional character &rest t) 225 | (values x 5 #\a)))) 226 | (5am:is-true (eval `(defpolymorph foo ((x string)) 227 | (values string number &optional character &rest t) 228 | (values x 5)))) 229 | (5am:is-true (eval `(defpolymorph foo ((x string)) 230 | (values string number &optional character &rest t) 231 | (values x 5 #\a "")))) 232 | 233 | (undefine-polymorphic-function 'foo) 234 | (fmakunbound 'my-identity)) 235 | -------------------------------------------------------------------------------- /src/lambda-lists/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | ;; In this file, our main functions/macros are 4 | ;; - DEFINE-LAMBDA-LIST-HELPER 5 | ;; - LAMBDA-LIST-TYPE 6 | ;; - COMPUTE-POLYMORPHIC-FUNCTION-LAMBDA-BODY 7 | ;; - SBCL-TRANSFORM-ARGS-FROM-LAMBDA-LIST-FORM 8 | ;; - TYPE-LIST-COMPATIBLE-P 9 | ;; - type-list-more-specific-p 10 | ;; - TYPE-LIST-CAUSES-AMBIGUOUS-CALL-P 11 | 12 | ;; THE BASICS ================================================================== 13 | 14 | (5am:def-suite lambda-list :in :polymorphic-functions) 15 | 16 | (defun valid-parameter-name-p (name) 17 | (and (symbolp name) 18 | (not (constantp name)) 19 | (not (member name lambda-list-keywords)))) 20 | 21 | (defun potential-type-of-lambda-list (lambda-list) 22 | ;; "potential" because it does not check the symbols 23 | (declare (type list lambda-list)) 24 | (the lambda-list-type 25 | (let ((intersection (intersection lambda-list lambda-list-keywords))) 26 | ;; premature optimization and over-abstraction :/ 27 | (cond ((null intersection) 'required) 28 | ((and (car intersection) (null (cdr intersection)) ; length is 1 29 | (member '&optional intersection)) 30 | 'required-optional) 31 | ((and (car intersection) (null (cddr intersection)) ; length is at most 2 32 | (or (set-equal intersection '(&key)) 33 | (set-equal intersection '(&key &rest)))) 34 | 'required-key) 35 | ((member '&rest intersection) ; don't check the lengths 36 | 'rest) 37 | (t 38 | (error "Neither of ~A types" +lambda-list-types+)))))) 39 | 40 | (defvar *potential-type*) 41 | (setf (documentation '*potential-type* 'variable) 42 | "POTENTIAL-TYPE of the LAMBDA-LIST of the typed function being compiled. 43 | Bound inside the functions defined by POLYMORPHS::DEFINE-LAMBDA-LIST-HELPER") 44 | 45 | (defvar *lambda-list*) 46 | (setf (documentation '*lambda-list* 'variable) 47 | "LAMBDA-LIST of the typed function being compiled. Bound inside the functions 48 | defined by POLYMORPHS::DEFINE-LAMBDA-LIST-HELPER") 49 | 50 | (defvar *lambda-list-typed-p*) 51 | (setf (documentation '*lambda-list-typed-p* 'variable) 52 | "Is T if the *LAMBDA-LIST* being processed is to be treated as if it had type 53 | specifiers. Bound inside the functions defined by POLYMORPHS::DEFINE-LAMBDA-LIST-HELPER") 54 | 55 | (defmacro define-lambda-list-helper ((outer-name outer-documentation) 56 | (inner-name inner-documentation) 57 | &body action-form) 58 | "ACTION-FORM should be defined in terms of *POTENTIAL-TYPE* and *LAMBDA-LIST* variables." 59 | `(progn 60 | (defun ,outer-name (lambda-list &key typed) 61 | ,outer-documentation 62 | (declare (type list lambda-list)) 63 | (let ((*potential-type* (potential-type-of-lambda-list lambda-list)) 64 | (*lambda-list* lambda-list) 65 | (*lambda-list-typed-p* typed)) 66 | (if (%lambda-list-type *potential-type* lambda-list) 67 | (progn ,@action-form) 68 | (error "LAMBDA-LIST ~S is neither of ~% ~S" lambda-list +lambda-list-types+)))) 69 | (defgeneric ,inner-name (potential-lambda-list-type lambda-list) 70 | (:documentation ,inner-documentation)) 71 | ;; For better error reporting 72 | (defmethod ,inner-name ((type t) (lambda-list t)) 73 | (assert (typep type 'lambda-list-type) 74 | () 75 | "Expected POTENTIAL-LAMBDA-LIST-TYPE to be one of ~% ~S~%but is ~S" 76 | +lambda-list-types+ type) 77 | (assert (typep lambda-list 'list) 78 | () 79 | "Expected LAMBDA-LIST to be a LIST but is ~S" 80 | lambda-list) 81 | (error "No potential type found for LAMBDA-LIST ~S from amongst ~% ~S" 82 | lambda-list +lambda-list-types+)))) 83 | 84 | ;; LAMBDA-LIST-TYPE ============================================================ 85 | 86 | (define-lambda-list-helper 87 | (lambda-list-type #.+lambda-list-type-doc+) 88 | (%lambda-list-type "Checks whether LAMBDA-LIST is of type POTENTIAL-LAMBDA-LIST-TYPE") 89 | *potential-type*) 90 | 91 | ;; COMPUTE-POLYMORPHIC-FUNCTION-LAMBDA-BODY ==================================== 92 | 93 | (defgeneric compute-polymorphic-function-lambda-body 94 | (lambda-list-type effective-untyped-lambda-list declaration &optional invalidated-p) 95 | (:documentation #.+compute-polymorphic-function-lambda-body-doc+)) 96 | 97 | ;; SBCL-TRANSFORM-ARG-LVARS-FROM-LAMBDA-LIST-FORM ============================== 98 | 99 | (define-lambda-list-helper 100 | (sbcl-transform-arg-lvars-from-lambda-list-form 101 | #.+sbcl-transform-arg-lvars-from-lambda-list-form+) 102 | (%sbcl-transform-arg-lvars-from-lambda-list-form 103 | #.+sbcl-transform-arg-lvars-from-lambda-list-form+) 104 | (progn 105 | (assert (untyped-lambda-list-p *lambda-list*)) 106 | (%sbcl-transform-arg-lvars-from-lambda-list-form *potential-type* *lambda-list*))) 107 | 108 | ;; TYPE-LIST-COMPATIBLE-P ====================================================== 109 | 110 | (defun type-list-compatible-p (lambda-list-type type-list effective-untyped-lambda-list) 111 | "Returns T if the given TYPE-LIST is compatible with the given UNTYPED-LAMBDA-LIST." 112 | (declare (type type-list type-list)) 113 | (let ((*lambda-list-typed-p* nil) 114 | (*potential-type* lambda-list-type)) 115 | (%type-list-compatible-p *potential-type* type-list effective-untyped-lambda-list))) 116 | 117 | (defgeneric %type-list-compatible-p 118 | (potential-lambda-list-type type-list untyped-lambda-list)) 119 | 120 | (defmethod %type-list-compatible-p ((type t) 121 | (type-list t) 122 | (untyped-lambda-list t)) 123 | (assert (typep type 'lambda-list-type) nil 124 | "Expected LAMBDA-LIST-TYPE to be one of ~% ~a~%but is ~a" 125 | +lambda-list-types+ type) 126 | (assert (typep type-list 'type-list) nil 127 | "Expected TYPE-LIST to be a TYPE-LIST but is ~a" type-list) 128 | (assert (typep untyped-lambda-list 'untyped-lambda-list) nil 129 | "Expected ~A to be a UNTYPED-LAMBDA-LIST" untyped-lambda-list) 130 | (error "This code shouldn't have reached here; perhaps file a bug report!")) 131 | 132 | (def-test type-list-compatible-p (:suite lambda-list) 133 | (5am:is-true (type-list-compatible-p 'required '(string string) '(c d))) 134 | (5am:is-false (type-list-compatible-p 'required '(string) '(c d))) 135 | (5am:is-true (type-list-compatible-p 'required-optional 136 | '(string number &optional t) '(c d &optional e))) 137 | (5am:is-false (type-list-compatible-p 'required-optional 138 | '(number) '(c d &optional d))) 139 | (5am:is-false (type-list-compatible-p 'required-key 140 | '(string &key (:d number)) 141 | '(c &rest args &key (d nil dp) (e nil ep)))) 142 | (5am:is-true (type-list-compatible-p 'required-key 143 | '(string &key (:d number) (:e string)) 144 | '(c &rest args &key (d nil dp) (e nil ep)))) 145 | (5am:is-false (type-list-compatible-p 'required-key 146 | '(string &key (:d number)) 147 | '(c &rest args &key (d nil dp) (e nil ep)))) 148 | (5am:is-true (type-list-compatible-p 'rest 149 | '(string) '(c &rest e))) 150 | (5am:is-true (type-list-compatible-p 'rest 151 | '(number string) '(c &rest e))) 152 | (5am:is-false (type-list-compatible-p 'rest 153 | '(&rest) '(c &rest e)))) 154 | 155 | (defvar *name*) 156 | (defvar *environment*) 157 | 158 | 159 | ;; TYPE-LIST-MORE-SPECIFIC-P ========================================================= 160 | 161 | (defun type-list-more-specific-p (type-list-1 type-list-2) 162 | #.+type-list-more-specific-p+ 163 | (declare (type type-list type-list-1 type-list-2)) 164 | (let ((*lambda-list-typed-p* nil)) 165 | (if (equal type-list-1 type-list-2) 166 | t 167 | (%type-list-more-specific-p (potential-type-of-lambda-list type-list-1) 168 | (potential-type-of-lambda-list type-list-2) 169 | type-list-1 170 | type-list-2)))) 171 | 172 | (defgeneric %type-list-more-specific-p (type-1 type-2 type-list-1 type-list-2) 173 | (:documentation #.+type-list-more-specific-p+)) 174 | 175 | (5am:def-suite type-list-more-specific-p :in lambda-list) 176 | 177 | ;; TYPE-LIST-INTERSECTION-NULL-P =============================================== 178 | 179 | (defun intersection-null-p (env &rest types) 180 | (subtypep `(and ,@types) nil env)) 181 | 182 | (defun definitive-intersection-null-p (type1 type2 &optional env) 183 | (multiple-value-bind (intersection-null-p knownp) 184 | (intersection-null-p env type1 type2) 185 | (cond ((not knownp) 186 | (cerror "Retry" 187 | "Please use PELTADOT:DEFINE-SUBTYPEP-LAMBDA and 188 | PELTADOT:DEFINE-INTERSECT-TYPE-P-LAMBDA to define the intersection 189 | of the following types:~% ~S~% ~S" 190 | type1 type2) 191 | (definitive-intersection-null-p type1 type2 env)) 192 | (t 193 | intersection-null-p)))) 194 | 195 | (defun type-list-intersection-null-p (type-list-1 type-list-2) 196 | #.+type-list-intersection-null-p+ 197 | (declare (type type-list type-list-1 type-list-2)) 198 | (let ((*lambda-list-typed-p* nil)) 199 | (%type-list-intersection-null-p (potential-type-of-lambda-list type-list-1) 200 | (potential-type-of-lambda-list type-list-2) 201 | type-list-1 202 | type-list-2))) 203 | 204 | (defgeneric %type-list-intersection-null-p 205 | (type-1 type-2 type-list-1 type-list-2) 206 | (:documentation #.+type-list-intersection-null-p+)) 207 | 208 | (5am:def-suite type-list-intersection-null-p :in lambda-list) 209 | 210 | ;; FTYPE-FOR-STATIC-DISPATCH ================================================ 211 | 212 | (defun ftype-for-static-dispatch (static-dispatch-name effective-type-list return-type env) 213 | (declare (ignorable env)) 214 | `(ftype (function ,(let ((type-list (loop :with state := :required 215 | :for type-spec :in effective-type-list 216 | :with processed-type-spec := nil 217 | :do (setq processed-type-spec 218 | (if (member type-spec lambda-list-keywords) 219 | (setq state type-spec) 220 | (ecase state 221 | ((:required &optional) 222 | type-spec) 223 | (&key 224 | `(,(first type-spec) 225 | ,(second type-spec)))))) 226 | :collect processed-type-spec))) 227 | (if (eq '&rest (lastcar effective-type-list)) 228 | (append type-list '(t)) 229 | type-list)) 230 | ,return-type) 231 | ,static-dispatch-name)) 232 | 233 | (defun ftype-proclaimation 234 | (static-dispatch-name effective-type-list return-type env) 235 | (let* ((ftype (ftype-for-static-dispatch 236 | static-dispatch-name effective-type-list return-type env)) 237 | (proclaimation 238 | `(proclaim ',ftype))) 239 | (if optim-debug 240 | proclaimation 241 | `(handler-bind ((warning #'muffle-warning)) 242 | ,proclaimation)))) 243 | -------------------------------------------------------------------------------- /src/dispatch.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defun recursive-function-p (name body) 4 | (flet ((%recursive-p (node) 5 | (if (listp node) 6 | (if (eq name (first node)) 7 | (return-from recursive-function-p t) 8 | node) 9 | nil))) 10 | (traverse-tree body #'%recursive-p) 11 | nil)) 12 | 13 | ;;; - run-time correctness requires 14 | ;;; - DEFINE-POLYMORPH-FUNCTION -> DEFUN 15 | ;;; - DEFPOLYMORPH 16 | ;;; - compile-time correctness requires 17 | ;;; - DEFINE-POLYMORPH-FUNCTION -> DEFINE-COMPILER-MACRO 18 | ;;; - GET-TYPE-LIST 19 | ;;; - DEFPOLYMORPH-COMPILER-MACRO 20 | 21 | (defmacro define-polymorphic-function (name untyped-lambda-list 22 | &key overwrite 23 | (documentation nil docp) 24 | (default '(function no-applicable-polymorph)) 25 | (dispatch-declaration 26 | ''#.+optimize-speed-or-compilation-speed+) 27 | &environment env) 28 | "Define a function named NAME that can then be used for DEFPOLYMORPH 29 | for specializing on various argument types. 30 | 31 | If OVERWRITE is T, all the existing polymorphs associated with NAME are deleted, 32 | and new polymorphs will be ready to be installed. 33 | If OVERWRITE is NIL, a continuable error is raised if the LAMBDA-LIST has changed. 34 | 35 | DEFAULT should be a FUNCTION that can be called with two arguments at run-time 36 | and compile-time in case no polymorph is applicable. 37 | - the first of these arguments is the NAME, while 38 | - the second argument is the argument list with which the polymorphic-function 39 | was called or compiled. 40 | At compile-time *COMPILER-MACRO-EXPANDING-P* is bound to non-NIL." 41 | (declare (type function-name name) 42 | (type untyped-lambda-list untyped-lambda-list)) 43 | (when (and docp (symbolp documentation) (constantp documentation)) 44 | (setq documentation (constant-form-value documentation env))) 45 | (when docp (check-type documentation string)) 46 | (let* ((*name* name) 47 | (untyped-lambda-list (normalize-untyped-lambda-list untyped-lambda-list)) 48 | (untyped-lambda-list (sort-untyped-lambda-list untyped-lambda-list))) 49 | `(progn 50 | (eval-when (:compile-toplevel :load-toplevel :execute) 51 | ,(when overwrite `(undefine-polymorphic-function ',name)) 52 | (register-polymorphic-function ',name ',untyped-lambda-list ,documentation 53 | ,default 54 | :source #+sbcl (sb-c:source-location) #-sbcl nil 55 | :declaration ,dispatch-declaration) 56 | #+sbcl (sb-c:defknown ,name * * nil :overwrite-fndb-silently t) 57 | ,(when (fboundp 'pf-compiler-macro) 58 | `(setf (compiler-macro-function ',name) #'pf-compiler-macro)) 59 | (fdefinition ',name))))) 60 | 61 | (defun extract-declarations (body &key documentation) 62 | "Returns two values: DECLARATIONS and remaining BODY 63 | If DOCUMENTATION is non-NIL, returns three values: DECLARATIONS and remaining BODY and DOC-STRING" 64 | (labels ((%extract-declarations (body) 65 | (cond ((null body) 66 | (values `(declare) nil)) 67 | ((and (listp (car body)) 68 | (eq 'declare (caar body))) 69 | (multiple-value-bind (declarations rest-body) 70 | (%extract-declarations (rest body)) 71 | (values (nconc (cons 'declare (cdar body)) 72 | (rest declarations)) 73 | rest-body))) 74 | (t 75 | (values `(declare) body))))) 76 | (multiple-value-bind (declarations rest-body) 77 | (if (and documentation 78 | (stringp (first body))) 79 | (%extract-declarations (rest body)) 80 | (%extract-declarations body)) 81 | (if (and documentation 82 | (stringp (first body))) 83 | (values declarations rest-body (first body)) 84 | (values declarations rest-body))))) 85 | 86 | (defun ensure-unambiguous-call (name type-list effective-type-list) 87 | (declare (optimize debug)) 88 | (loop :for polymorph :in (polymorphic-function-polymorphs (fdefinition name)) 89 | :for existing-type-list := (polymorph-type-list polymorph) 90 | :for existing-effective-type-list := (polymorph-effective-type-list polymorph) 91 | :for new-specific-p 92 | := (type-list-more-specific-p effective-type-list existing-effective-type-list) 93 | :for existing-specific-p 94 | := (type-list-more-specific-p existing-effective-type-list effective-type-list) 95 | :do (when (or (and new-specific-p 96 | existing-specific-p 97 | (not (equalp type-list existing-type-list))) 98 | (and (not new-specific-p) 99 | (not existing-specific-p) 100 | (not (type-list-intersection-null-p effective-type-list 101 | existing-effective-type-list)))) 102 | (cerror "Undefine existing polymorph" 103 | "The given TYPE-LIST ~% ~S~%effectively~% ~S~%will cause ambiguous call with an existing polymorph with type list ~% ~S~%and effective type list~% ~S~%" 104 | type-list 105 | effective-type-list 106 | existing-type-list 107 | existing-effective-type-list) 108 | (undefpolymorph name existing-type-list)))) 109 | 110 | (defun expand-defpolymorph-lite 111 | (name typed-lambda-list return-type body env) 112 | (destructuring-bind 113 | (name &rest keys 114 | &key invalidate-pf (static-dispatch-name nil static-dispatch-name-p) 115 | &allow-other-keys) 116 | (if (typep name 'function-name) 117 | (list name) 118 | name) 119 | (declare (type function-name name) 120 | (optimize debug)) 121 | (remf keys :invalidate-pf) 122 | (remf keys :static-dispatch-name) 123 | (assert (null keys) () 124 | "The only legal options for DEFPOLYMORPH are:~% STATIC-DISPATCH-NAME and INVALIDATE-PF~%Did you intend to polymorphic-functions instead of polymorphic-functions-lite?") 125 | (let+ ((block-name (blockify-name name)) 126 | (*environment* env) 127 | ((&values unsorted-typed-lambda-list ignorable-list) 128 | (normalize-typed-lambda-list typed-lambda-list)) 129 | (typed-lambda-list (sort-typed-lambda-list unsorted-typed-lambda-list)) 130 | (untyped-lambda-list (untyped-lambda-list typed-lambda-list)) 131 | (pf-lambda-list (may-be-pf-lambda-list name untyped-lambda-list)) 132 | (parameters (make-polymorph-parameters-from-lambda-lists 133 | pf-lambda-list typed-lambda-list)) 134 | (lambda-list-type (lambda-list-type typed-lambda-list :typed t)) 135 | ((&values param-list type-list effective-type-list) 136 | (polymorph-effective-lambda-list parameters)) 137 | ((&values declarations body doc) 138 | (extract-declarations body :documentation t)) 139 | (static-dispatch-name 140 | (if static-dispatch-name-p 141 | static-dispatch-name 142 | (make-or-retrieve-static-dispatch-name name type-list))) 143 | (lambda-declarations (lambda-declarations parameters)) 144 | ((&values ensure-type-form return-type) 145 | (ensure-type-form return-type block-name body 146 | :variable 147 | (remove-duplicates 148 | (remove-if 149 | #'null 150 | (mapcar #'third 151 | (rest lambda-declarations)))) 152 | :declare 153 | (remove-duplicates 154 | (rest lambda-declarations) 155 | :test #'equal))) 156 | (lambda-body 157 | `(list-named-lambda (polymorph ,name ,type-list) 158 | ,(symbol-package block-name) 159 | ,param-list 160 | (declare (ignorable ,@ignorable-list)) 161 | ,lambda-declarations 162 | ,declarations 163 | ,ensure-type-form)) 164 | ;; LAMBDA-BODY contains the ENSURE-TYPE-FORM that performs 165 | ;; run time checks on the return types. 166 | (ftype-proclaimation 167 | (ftype-proclaimation 168 | static-dispatch-name effective-type-list return-type env))) 169 | 170 | `(progn 171 | (eval-when (:compile-toplevel :load-toplevel :execute) 172 | 173 | (unless (and (fboundp ',name) 174 | (typep (function ,name) 'polymorphic-function)) 175 | (define-polymorphic-function ,name ,untyped-lambda-list))) 176 | (eval-when (:load-toplevel :execute) 177 | ,ftype-proclaimation 178 | (setf (fdefinition ',static-dispatch-name) ,lambda-body)) 179 | (eval-when (:compile-toplevel :load-toplevel :execute) 180 | (register-polymorph ',name nil 181 | ',doc 182 | ',typed-lambda-list 183 | ',type-list 184 | ',effective-type-list 185 | nil 186 | nil 187 | ',return-type 188 | nil 189 | ',static-dispatch-name 190 | ',lambda-list-type 191 | ',(run-time-applicable-p-form parameters) 192 | nil 193 | #+sbcl (sb-c:source-location)) 194 | ,(when invalidate-pf 195 | `(invalidate-polymorphic-function-lambda (fdefinition ',name))) 196 | ',name))))) 197 | 198 | ;;; CLHS recommends that 199 | ;;; Macros intended for use in top level forms should be written so that 200 | ;;; side-effects are done by the forms in the macro expansion. The 201 | ;;; macro-expander itself should not do the side-effects. 202 | ;;; Reference: http://clhs.lisp.se/Body/s_eval_w.htm 203 | 204 | (defmacro defpolymorph (&whole whole name typed-lambda-list return-type 205 | &body body &environment env) 206 | " Expects OPTIONAL or KEY args to be in the form 207 | 208 | ((A TYPE) DEFAULT-VALUE) or ((A TYPE) DEFAULT-VALUE AP). 209 | 210 | - NAME could also be 211 | (NAME 212 | &KEY 213 | STATIC-DISPATCH-NAME 214 | INVALIDATE-PF) 215 | 216 | - STATIC-DISPATCH-NAME could be useful for tracing or profiling 217 | 218 | - If INVALIDATE-PF is non-NIL then the associated polymorphic-function 219 | is forced to recompute its dispatching after this polymorph is defined. 220 | " 221 | (if (fboundp 'pf-compiler-macro) 222 | (uiop:symbol-call '#:polymorphic-functions 223 | '#:expand-defpolymorph-full 224 | whole name typed-lambda-list return-type body env) 225 | (expand-defpolymorph-lite name typed-lambda-list return-type body env))) 226 | 227 | (defun undefpolymorph (name type-list) 228 | "Remove the POLYMORPH associated with NAME with TYPE-LIST" 229 | ;; FIXME: Undefining polymorphs can also lead to polymorph call ambiguity. 230 | ;; One (expensive) solution is to insert afresh the type lists of all polymorphs 231 | ;; to resolve it. 232 | #+sbcl 233 | (let ((info (sb-c::fun-info-or-lose name)) 234 | (ctype (sb-c::specifier-type (list 'function type-list '*)))) 235 | (setf (sb-c::fun-info-transforms info) 236 | (remove-if (curry #'sb-c::type= ctype) 237 | (sb-c::fun-info-transforms info) 238 | :key #'sb-c::transform-type))) 239 | (remove-polymorph name type-list) 240 | (update-polymorphic-function-lambda (fdefinition name) t)) 241 | 242 | (defun undefine-polymorphic-function (name) 243 | "Remove the POLYMORPH(-WRAPPER) defined by DEFINE-POLYMORPH" 244 | (fmakunbound name) 245 | #+sbcl (sb-c::undefine-fun-name name) 246 | (setf (compiler-macro-function name) nil)) 247 | -------------------------------------------------------------------------------- /src/lambda-lists/required-optional.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmethod %lambda-list-type ((type (eql 'required-optional)) (lambda-list list)) 4 | (let ((state :required)) 5 | (dolist (elt lambda-list) 6 | (ecase state 7 | (:required (cond ((eq elt '&optional) 8 | (setf state '&optional)) 9 | ((and *lambda-list-typed-p* (listp elt) 10 | (valid-parameter-name-p (first elt))) 11 | t) 12 | ((and (not *lambda-list-typed-p*) 13 | (valid-parameter-name-p elt)) 14 | t) 15 | (t 16 | (return-from %lambda-list-type nil)))) 17 | (&optional (cond ((and *lambda-list-typed-p* (listp elt) 18 | (let ((elt (first elt))) 19 | (and (listp elt) 20 | (valid-parameter-name-p (first elt)))) 21 | (if (null (third elt)) 22 | t 23 | (valid-parameter-name-p (third elt))) 24 | (null (fourth elt))) 25 | t) 26 | ((and (not *lambda-list-typed-p*) 27 | (or (valid-parameter-name-p elt) 28 | (and (listp elt) 29 | (valid-parameter-name-p (first elt))))) 30 | t) 31 | (t 32 | (return-from %lambda-list-type nil)))))) 33 | (eq state '&optional))) 34 | 35 | (def-test type-identification-optional (:suite lambda-list) 36 | (is (eq 'required-optional (lambda-list-type '(&optional))) 37 | "(defun foo (&optional)) does compile") 38 | (is (eq 'required-optional (lambda-list-type '(a &optional))) 39 | "(defun foo (a &optional)) does compile") 40 | (is (eq 'required-optional (lambda-list-type '(a &optional b)))) 41 | (is-error (lambda-list-type '(a &optional 5))) 42 | (is-error (lambda-list-type '(a &optional b &rest))) 43 | (is (eq 'required-optional 44 | (lambda-list-type '((a string) (b number) &optional 45 | ((c number))) ; say if it actually is a null-type? 46 | :typed t))) 47 | (is (eq 'required-optional 48 | (lambda-list-type '((a string) (b number) &optional 49 | ((c number) 5 c)) 50 | :typed t))) 51 | (is (eq 'required-optional 52 | (lambda-list-type '((a string) (b number) &optional 53 | ((c number) 5 c)) 54 | :typed t))) 55 | (is (eq 'required-optional 56 | (lambda-list-type '((a string) (b number) &optional 57 | ((c number) b c)) 58 | :typed t))) 59 | (is-error (lambda-list-type '((a string) (b number) &optional 60 | ((c number) 5 6)) 61 | :typed t)) 62 | (is-error (lambda-list-type '((a string) (b number) &optional 63 | ((c number) 5 6 7)) 64 | :typed t)) 65 | (is-error (lambda-list-type '((a string) (b number) &optional 66 | (c number)) 67 | :typed t))) 68 | 69 | (def-test effective-lambda-list-optional (:suite effective-lambda-list) 70 | (flet ((effective-typed-lambda-list (typed-lambda-list) 71 | (let ((typed-lambda-list (normalize-typed-lambda-list typed-lambda-list))) 72 | (polymorph-effective-lambda-list 73 | (make-polymorph-parameters-from-lambda-lists 74 | (untyped-lambda-list typed-lambda-list) 75 | typed-lambda-list))))) 76 | (destructuring-bind ((first second third fourth) type-list effective-type-list) 77 | (multiple-value-list (effective-typed-lambda-list '((a string) (b number) &optional 78 | ((c number) 5)))) 79 | (is (eq first 'a)) 80 | (is (eq second 'b)) 81 | (is (eq third '&optional)) 82 | (is (equalp '(c 5) fourth)) 83 | (is (equalp type-list '(string number &optional number))) 84 | (is (equalp effective-type-list '(string number &optional (or null number))))))) 85 | 86 | (defmethod compute-polymorphic-function-lambda-body 87 | ((type (eql 'required-optional)) (effective-lambda-list list) declaration 88 | &optional invalidated-p) 89 | (let* ((optional-position (position '&optional effective-lambda-list)) 90 | (required-parameters (subseq effective-lambda-list 0 optional-position)) 91 | (optional-parameters (subseq effective-lambda-list (1+ optional-position))) 92 | (args `(nconc (list ,@required-parameters) 93 | ,@(loop :for (op default op-p) :in optional-parameters 94 | :collect `(when ,op-p (list ,op))))) 95 | (block-name (blockify-name *name*))) 96 | (with-gensyms (static-dispatch-fn) 97 | `((declare ,declaration 98 | (ignorable ,@(mapcar #'first optional-parameters) 99 | ,@(mapcar #'third optional-parameters))) 100 | (block ,block-name 101 | ,(if invalidated-p 102 | `(progn 103 | (update-polymorphic-function-lambda (fdefinition ',*name*)) 104 | (cond ,@(loop :for (name default supplied-p) :in (reverse optional-parameters) 105 | :for optional-idx :downfrom (length optional-parameters) :above 0 106 | :for parameters := (append required-parameters 107 | (mapcar #'first 108 | (subseq optional-parameters 109 | 0 optional-idx))) 110 | :collect `(,supplied-p 111 | (funcall (fdefinition ',*name*) ,@parameters))) 112 | (t 113 | (funcall (fdefinition ',*name*) ,@required-parameters)))) 114 | `(let ((,static-dispatch-fn 115 | (locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 116 | (cond 117 | ,@(loop 118 | :for i :from 0 119 | :for polymorph 120 | :in (polymorphic-function-polymorphs (fdefinition *name*)) 121 | :for static-dispatch-name 122 | := (polymorph-static-dispatch-name polymorph) 123 | :for runtime-applicable-p-form 124 | := (polymorph-runtime-applicable-p-form polymorph) 125 | :collect 126 | `(,runtime-applicable-p-form #',static-dispatch-name)) 127 | (t 128 | (return-from ,block-name 129 | (funcall ,(polymorphic-function-default (fdefinition *name*)) 130 | ',*name* nil ,args))))))) 131 | (cond ,@(loop :for (name default supplied-p) :in (reverse optional-parameters) 132 | :for optional-idx :downfrom (length optional-parameters) :above 0 133 | :for parameters := (append required-parameters 134 | (mapcar #'first 135 | (subseq optional-parameters 136 | 0 optional-idx))) 137 | :collect `(,supplied-p 138 | (funcall 139 | (cl:the cl:function ,static-dispatch-fn) 140 | ,@parameters))) 141 | (t 142 | (funcall (cl:the cl:function ,static-dispatch-fn) 143 | ,@required-parameters)))))))))) 144 | 145 | (defmethod %sbcl-transform-arg-lvars-from-lambda-list-form ((type (eql 'required-optional)) 146 | (untyped-lambda-list list)) 147 | (assert (not *lambda-list-typed-p*)) 148 | (let ((optional-position (position '&optional untyped-lambda-list))) 149 | `(append ,@(loop :for arg :in (subseq untyped-lambda-list 0 optional-position) 150 | :collect `(list (cons ',arg ,arg))) 151 | ,@(loop :for param-name :in (subseq untyped-lambda-list 152 | (1+ optional-position)) 153 | :collect `(if ,param-name 154 | (list (cons ',param-name ,param-name)) 155 | nil))))) 156 | 157 | (defmethod %type-list-compatible-p ((type (eql 'required-optional)) 158 | (type-list list) 159 | (untyped-lambda-list list)) 160 | (and (length= type-list untyped-lambda-list) 161 | (if-let ((pos-1 (position '&optional type-list)) 162 | (pos-2 (position '&optional untyped-lambda-list))) 163 | (= pos-1 pos-2)))) 164 | 165 | (defmethod %type-list-more-specific-p ((type-1 (eql 'required-optional)) 166 | (type-2 (eql 'required-optional)) 167 | list-1 list-2) 168 | (declare (type list list-1 list-2)) 169 | (let ((optional-position-1 (position '&optional list-1)) 170 | (optional-position-2 (position '&optional list-2))) 171 | (if (= optional-position-1 optional-position-2) 172 | (loop :for type-1 :in list-1 173 | :for type-2 :in list-2 174 | ;; Return T the moment we find a SUBTYPEP with not TYPE= 175 | ;; The ones before this point should be TYPE= 176 | :do (cond ((eq '&optional type-1) 177 | t) 178 | ((type= type-1 type-2) 179 | t) 180 | ((subtypep type-1 type-2) 181 | (return-from %type-list-more-specific-p t)) 182 | (t 183 | (return-from %type-list-more-specific-p nil))) 184 | :finally (return t)) 185 | ;; Let's hope that this case will be caught by the ambiguous-call-p 186 | ;; functionality. Let's have this hope for the second part of and above 187 | ;; as well. 188 | (error "This case has not been handled!")))) 189 | 190 | (def-test type-list-subtype-optional (:suite type-list-more-specific-p) 191 | (5am:is-true (type-list-more-specific-p '(string &optional string) 192 | '(string &optional array))) 193 | (5am:is-true (type-list-more-specific-p '(&optional string) 194 | '(&optional string number))) 195 | (5am:is-false (type-list-more-specific-p '(string &optional string) 196 | '(string &optional number))) 197 | (5am:is-false (type-list-more-specific-p '(string &optional string) 198 | '(number &optional string)))) 199 | 200 | (defmethod %type-list-intersection-null-p 201 | ((type-1 (eql 'required-optional)) 202 | (type-2 (eql 'required-optional)) 203 | list-1 list-2) 204 | (let ((optional-position-1 (position '&optional list-1)) 205 | (optional-position-2 (position '&optional list-2))) 206 | ;; FIXME: What if position of optional arguments is not same? Or if lengths are different? 207 | ;; Eg. '(&optional string) and '(&optional string number) have a non-NULL intersection 208 | ;; Well, yes, but then, any type-list with 0 required arguments would cause a "non-NULL" intersection 209 | (or (/= optional-position-1 optional-position-2) 210 | (loop :for type-1 :in list-1 211 | :for type-2 :in list-2 212 | ;; Return T the moment we have a non-null intersection 213 | ;; without a definite direction of SUBTYPEP 214 | :do (unless (and (eq type-1 '&optional) 215 | (eq type-2 '&optional)) 216 | (if (type= type-1 type-2) 217 | t 218 | (return-from %type-list-intersection-null-p 219 | (definitive-intersection-null-p type-1 type-2 220 | (when (boundp '*environment*) 221 | *environment*))))) 222 | :finally (return t))))) 223 | 224 | (def-test type-list-intersection-null-optional 225 | (:suite type-list-intersection-null-p) 226 | (5am:is-false (type-list-intersection-null-p '(string &optional string) 227 | '(string &optional array))) 228 | (5am:is-true (type-list-intersection-null-p '(&optional string) 229 | '(&optional string number))) 230 | (5am:is-true (type-list-intersection-null-p '(string &optional string) 231 | '(string &optional number))) 232 | (5am:is-true (type-list-intersection-null-p '(string &optional string) 233 | '(number &optional string))) 234 | (5am:is-false (type-list-intersection-null-p '(string array &optional string) 235 | '(array string &optional number))) 236 | ) 237 | -------------------------------------------------------------------------------- /src/nonlite/dispatch.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmacro with-muffled-compilation-warnings (&body body) 4 | `(locally (declare #+sbcl (sb-ext:muffle-conditions warning)) 5 | (let ((*error-output* (make-string-output-stream))) 6 | (let (#+sbcl (sb-c::*in-compilation-unit* nil) 7 | (*compile-verbose* nil)) 8 | (#+sbcl progn 9 | #-sbcl with-compilation-unit #-sbcl (:override t) 10 | ;; TODO: Improve error reporting on other systems 11 | ;; This works on SBCL and CCL 12 | ,@body))))) 13 | 14 | (defun null-env-compilation-warnings (lambda-form) 15 | (let* ((warnings)) 16 | (with-muffled-compilation-warnings 17 | (handler-bind ((warning (lambda (c) 18 | (push c warnings) 19 | (muffle-warning c)))) 20 | (compile nil (ecase (first lambda-form) 21 | (cl:lambda 22 | lambda-form))))) 23 | (if warnings 24 | (format nil "~{~A~^~%~}" (nreverse warnings)) 25 | nil))) 26 | 27 | (defmacro with-safe-inline ((inline-safe-lambda-body-var inline-note-var 28 | &key whole name inlinep inline inline-lambda-body) 29 | &body body) 30 | (assert (every #'symbolp 31 | (list inline-safe-lambda-body-var inline-note-var 32 | inlinep inline))) 33 | `(multiple-value-bind (,inline-safe-lambda-body-var ,inline-note-var) 34 | (cond ((and ,inlinep ,inline) 35 | (values ,inline-lambda-body 36 | (if-let (null-env-compilation-warnings 37 | (null-env-compilation-warnings ,inline-lambda-body)) 38 | (with-output-to-string (*error-output*) 39 | (note-null-env inline-lambda-body 40 | null-env-compilation-warnings)) 41 | nil))) 42 | ((and ,inlinep (not ,inline)) 43 | (values nil nil)) 44 | ((and (not ,inlinep) 45 | (recursive-function-p ,name ,inline-lambda-body)) 46 | (values nil 47 | (with-output-to-string (*error-output*) 48 | (note-no-inline ,whole "it is suspected to result in infinite recursive expansion;~% supply :INLINE T option to override and proceed at your own risk")))) 49 | (t 50 | (if-let (null-env-compilation-warnings 51 | (null-env-compilation-warnings ,inline-lambda-body)) 52 | (values nil 53 | (with-output-to-string (*error-output*) 54 | (note-no-inline ,whole "~%") 55 | (pprint-logical-block (*error-output* nil 56 | :per-line-prefix " ") 57 | (note-null-env ,inline-lambda-body 58 | null-env-compilation-warnings)) 59 | (format *error-output* "~&PROCEED AT YOUR OWN RISK!~%~%"))) 60 | (values ,inline-lambda-body 61 | nil)))) 62 | 63 | ,@body)) 64 | 65 | ;;; Earlier (until commit e7f11394023cf06075459ea4baa735ec8bda89f3 of polymorphic-functions), 66 | ;;; we attempted to use a code-walker to determine if there are 67 | ;;; free variables in the form, and accordingly decline to inline 68 | ;;; the polymorph. However, cases such as this (and while this is nonsense): 69 | ;;; (define-polymorphic-function foo (a) :overwrite t) 70 | ;;; (let ((a 5)) 71 | ;;; (defpolymorph foo ((symbol (eql a))) t 72 | ;;; (declare (ignore symbol)) 73 | ;;; a) 74 | ;;; (defun bar () (foo 'a))) 75 | ;;; demand a user supplied value for INLINE. We put the same to use and avoid 76 | ;;; depending on the code-walker altogether. 77 | 78 | ;;; The BODY of the DEFPOLYMORPH FORM may contain macro calls referenced to the 79 | ;;; null lexenv. When this BODY gets substituted in order to INLINE the PF, 80 | ;;; we want to avoid MACROLET (and FLET, LABELS) from overriding the elements 81 | ;;; of the null lexenv. That is what the behavior of INLINE-d functions defined 82 | ;;; by DEFUN is. (Does the spec say that?) 83 | ;;; The MACROLET can be taken care of by MACROEXPAND-ALL. However, because 84 | ;;; compiling to support SUBTYPE and PARAMETRIC polymorphism requires type 85 | ;;; information that is only available at the call-compilation site rather than 86 | ;;; at the defpolymorph-definition site. Thus, the MACROEXPAND-ALL must happen 87 | ;;; within the pf-compiler-macro rather than DEFPOLYMORPH below. 88 | ;;; That still leaves FLET and LABELS though. And that does form a limitation 89 | ;;; of polymorphic functions at the time of this writing. 90 | 91 | ;;; Do minimal work at macro-expansion time? 92 | ;;; 1. Well, to be able to handle closures, the compilation phase of the lambda 93 | ;;; needs the env. However, env objects cannot be dumped; nor does it seem like 94 | ;;; a wise idea to do so. 95 | ;;; 2. That means, the minimum work that we need to do during macroexpansion time 96 | ;;; involves the emission of the lambda-body. 97 | 98 | (setf (documentation 'defpolymorph 'cl:function) 99 | " Expects OPTIONAL or KEY args to be in the form 100 | 101 | ((A TYPE) DEFAULT-VALUE) or ((A TYPE) DEFAULT-VALUE AP). 102 | 103 | - NAME could also be 104 | (NAME 105 | &KEY (INLINE T) 106 | STATIC-DISPATCH-NAME 107 | INVALIDATE-PF 108 | MORE-OPTIMAL-TYPE-LIST 109 | SUBOPTIMAL-NOTE) 110 | 111 | - Possible values for INLINE are T, NIL and :MAYBE 112 | 113 | - STATIC-DISPATCH-NAME could be useful for tracing or profiling 114 | 115 | - If INVALIDATE-PF is non-NIL then the associated polymorphic-function 116 | is forced to recompute its dispatching after this polymorph is defined. 117 | 118 | - SUBOPTIMAL-NOTE and MORE-OPTIMAL-TYPE-LIST are useful for signalling that the 119 | POLYMORPH chosen for static-dispatch, inlining, or compiler-macro is 120 | not the most optimal. 121 | It is recommended that SUBOPTIMAL-NOTE should be the name of a subclass of 122 | SUBOPTIMAL-POLYMORPH-NOTE - the condition class should have a slot to 123 | accept the TYPE-LIST of the currently chosen POLYMORPH 124 | 125 | **Note**: 126 | - INLINE T or :MAYBE can result in infinite expansions for recursive polymorphs. 127 | Proceed at your own risk. 128 | - Also, because inlining results in type declaration upgradation for purposes 129 | of subtype polymorphism, it is recommended to not mutate the variables used 130 | in the lambda list; the consequences of mutation are undefined. 131 | ") 132 | 133 | (defun expand-defpolymorph-full 134 | (whole name typed-lambda-list return-type body env) 135 | (destructuring-bind 136 | (name 137 | &key (inline t ip) 138 | (static-dispatch-name nil static-dispatch-name-p) 139 | invalidate-pf 140 | more-optimal-type-list 141 | suboptimal-note) 142 | (if (typep name 'function-name) 143 | (list name) 144 | name) 145 | (declare (type function-name name) 146 | (optimize debug)) 147 | (let+ ((block-name (blockify-name name)) 148 | (*environment* env) 149 | ((&values unsorted-typed-lambda-list ignorable-list) 150 | (normalize-typed-lambda-list typed-lambda-list)) 151 | (typed-lambda-list (sort-typed-lambda-list unsorted-typed-lambda-list)) 152 | (untyped-lambda-list (untyped-lambda-list typed-lambda-list)) 153 | (pf-lambda-list (may-be-pf-lambda-list name untyped-lambda-list)) 154 | (parameters (make-polymorph-parameters-from-lambda-lists 155 | pf-lambda-list typed-lambda-list)) 156 | (lambda-list-type (lambda-list-type typed-lambda-list :typed t)) 157 | ((&values param-list type-list effective-type-list) 158 | (polymorph-effective-lambda-list parameters)) 159 | ((&values declarations body doc) 160 | (extract-declarations body :documentation t)) 161 | (static-dispatch-name 162 | (if static-dispatch-name-p 163 | static-dispatch-name 164 | (make-or-retrieve-static-dispatch-name name type-list))) 165 | (lambda-declarations (lambda-declarations parameters)) 166 | ((&values ensure-type-form return-type) 167 | (ensure-type-form return-type block-name body 168 | :variable 169 | (remove-duplicates 170 | (remove-if 171 | #'null 172 | (mapcar #'third 173 | (rest lambda-declarations)))) 174 | :declare 175 | (remove-duplicates 176 | (rest lambda-declarations) 177 | :test #'equal))) 178 | (lambda-body 179 | `(list-named-lambda (polymorph ,name ,type-list) 180 | ,(symbol-package block-name) 181 | ,param-list 182 | (declare (ignorable ,@ignorable-list)) 183 | ,lambda-declarations 184 | ,declarations 185 | ,ensure-type-form)) 186 | ;; LAMBDA-BODY contains the ENSURE-TYPE-FORM that performs 187 | ;; run time checks on the return types. 188 | ;; INLINE-LAMBDA-BODY performs no such run time checks. 189 | ;; It is used for generating DEFTRANSFORM as well as 190 | ;; by PF-COMPILER-MACRO to generate minimal overhead code. 191 | (inline-lambda-body 192 | (when inline 193 | `(lambda ,param-list 194 | (declare (ignorable ,@ignorable-list)) 195 | ,lambda-declarations 196 | ,declarations 197 | ;; The RETURN-TYPE here would be augmented by 198 | ;; PF-COMPILER-MACRO 199 | (block ,block-name 200 | (locally ,@body))))) 201 | #+sbcl 202 | (sbcl-deftransform-form 203 | (when inline 204 | (make-and-wrap-sbcl-deftransform-form 205 | env name typed-lambda-list inline-lambda-body parameters))) 206 | (ftype-proclaimation 207 | (ftype-proclaimation 208 | static-dispatch-name effective-type-list return-type env))) 209 | 210 | (with-safe-inline (inline-safe-lambda-body inline-notes 211 | :whole whole :name name :inlinep ip :inline inline 212 | :inline-lambda-body inline-lambda-body) 213 | 214 | (setq inline (case inline 215 | ((t) (cond (ip inline) 216 | (inline-notes nil) 217 | (t t))) 218 | (otherwise inline))) 219 | 220 | ;; NOTE: We need the LAMBDA-BODY due to compiler macros, 221 | ;; and "objects of type FUNCTION can't be dumped into fasl files" 222 | `(progn 223 | 224 | (eval-when (:compile-toplevel :load-toplevel :execute) 225 | (unless (and (fboundp ',name) 226 | (typep (function ,name) 'polymorphic-function)) 227 | (define-polymorphic-function ,name ,untyped-lambda-list))) 228 | 229 | #+sbcl ,sbcl-deftransform-form 230 | 231 | (eval-when (:load-toplevel :execute) 232 | 233 | ,(when inline-notes 234 | ;; Even STYLE-WARNING isn't appropriate to this, because we want to 235 | ;; inform the user of the warnings even when INLINE option is supplied. 236 | `(compiler-macro-notes:with-notes 237 | (',whole nil :unwind-on-signal nil) 238 | (signal 'defpolymorph-note :datum ,inline-notes) 239 | t)) 240 | 241 | ;; We have implemented inlining through the PF-COMPILER-MACRO. 242 | ;; In addition to inlining, it also propagates the type declarations 243 | ;; so that further compiler/macroexpansions can make use of this info. 244 | 245 | ;; This type declaration is not handled by the implementation 246 | ;; provided inlining of DEFUN-defined functions. 247 | 248 | ,ftype-proclaimation 249 | ,(if inline-notes 250 | ;; If there are issues related to INLINING, 251 | ;; suppress the other warnings and let the user 252 | ;; deal with them first. 253 | `(with-muffled-compilation-warnings 254 | (setf (fdefinition ',static-dispatch-name) ,lambda-body)) 255 | `(setf (fdefinition ',static-dispatch-name) ,lambda-body))) 256 | 257 | (eval-when (:compile-toplevel :load-toplevel :execute) 258 | (register-polymorph ',name ',inline 259 | ',doc 260 | ',typed-lambda-list 261 | ',type-list 262 | ',effective-type-list 263 | ',more-optimal-type-list 264 | ',suboptimal-note 265 | ',return-type 266 | ',inline-safe-lambda-body 267 | ',static-dispatch-name 268 | ',lambda-list-type 269 | ',(run-time-applicable-p-form parameters) 270 | ,(compiler-applicable-p-lambda-body parameters) 271 | #+sbcl (sb-c:source-location)) 272 | ,(when invalidate-pf 273 | `(invalidate-polymorphic-function-lambda (fdefinition ',name))) 274 | ',name)))))) 275 | 276 | (setf (cl:documentation 'undefine-polymorphic-function 'cl:function) 277 | "Remove the POLYMORPH(-WRAPPER) defined by DEFINE-POLYMORPH 278 | CL:FMAKUNBOUND will be insufficient, because polymorphic-functions 279 | also have a compiler macro defined for them. Additionally, on SBCL, 280 | they may also have transforms associated with them.") 281 | -------------------------------------------------------------------------------- /src/nonlite/compiler-macro.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | ;;; TODO: Allow user to specify custom optim-speed etc 4 | 5 | (defun pf-compiler-macro-function 6 | (name original-form polymorph unexpanded-args expanded-args arg-types env) 7 | 8 | (with-slots (inline-p return-type type-list 9 | more-optimal-type-list suboptimal-note 10 | compiler-macro-lambda lambda-list-type 11 | static-dispatch-name parameters) 12 | 13 | polymorph 14 | 15 | (let ((inline-lambda-body (polymorph-inline-lambda-body polymorph)) 16 | (return-type return-type)) ; we will be setq-ing the return-type 17 | 18 | (when inline-lambda-body 19 | (setq inline-lambda-body 20 | ;; The only thing we want to preserve from the ENV are the OPTIMIZE 21 | ;; declarations. 22 | ;; Otherwise, the other information must be excluded 23 | ;; because the POLYMORPH was originally expected to be defined in 24 | ;; null env; see the discussion preceding DEFPOLYMORPH macro for 25 | ;; more details 26 | (let* ((augmented-env 27 | (augment-environment 28 | env 29 | :declare (list 30 | (cons 'optimize 31 | (declaration-information 'optimize env))))) 32 | (notes nil) 33 | ;; The source of compile-time subtype-polymorphism 34 | (compiler-macro-notes:*muffled-notes-type* 35 | `(or ,compiler-macro-notes:*muffled-notes-type* 36 | ,@(declaration-information 37 | 'compiler-macro-notes:muffle 38 | env))) 39 | (lambda-with-enhanced-declarations 40 | (optima:ematch inline-lambda-body 41 | ((list lambda params ignorable-decl _ more-decl 42 | (list* 'block block-name body)) 43 | `(,lambda ,params 44 | ;; The source of compile-time subtype-polymorphism 45 | ,ignorable-decl 46 | ,(enhanced-lambda-declarations parameters arg-types) 47 | ,more-decl 48 | (block ,block-name ,@body))))) 49 | (augmented-env 50 | (augment-environment 51 | augmented-env 52 | :symbol-macro (list 53 | (list 'compiler-macro-notes:parent-form 54 | lambda-with-enhanced-declarations) 55 | (list 'compiler-macro-notes:root-form 56 | (let ((exp (macroexpand-1 'compiler-macro-notes:root-form env))) 57 | (if (eq exp 'compiler-macro-notes:root-form) 58 | original-form 59 | exp))))))) 60 | 61 | ;; We need to expand here, because we want to report 62 | ;; that the notes generated from the result of this expansion 63 | ;; were actually generated from THIS PARTICULAR TOP-LEVEL FORM 64 | ;; But even besides compiler notes, this expansion is also 65 | ;; required so that the type parameters above are considered appropriately. 66 | ;; Though, it might be possible to supply this information through 67 | ;; SYMBOL-MACROLET as we do below for TOP-LEVEL-P 68 | 69 | (when compiler-macro-lambda 70 | (let* ((compiler-macro-form 71 | (cons lambda-with-enhanced-declarations unexpanded-args)) 72 | (expansion 73 | (handler-bind 74 | ((compiler-macro-notes:note 75 | (lambda (note) 76 | (unless 77 | (typep note *muffled-notes-type*) 78 | (compiler-macro-notes::swank-signal note env) 79 | (push note notes))))) 80 | (funcall compiler-macro-lambda 81 | compiler-macro-form 82 | (augment-environment 83 | augmented-env 84 | :symbol-macro (list (list 'compiler-macro-notes:parent-form 85 | compiler-macro-form))))))) 86 | (unless (equal expansion original-form) 87 | (when more-optimal-type-list 88 | (signal 'more-optimal-polymorph-inapplicable 89 | :more-optimal-type-list 90 | more-optimal-type-list)) 91 | (when suboptimal-note 92 | (signal suboptimal-note :type-list type-list)) 93 | (return-from pf-compiler-macro-function 94 | expansion)))) 95 | 96 | (let ((macroexpanded-form 97 | (handler-bind 98 | ((compiler-macro-notes:note 99 | (lambda (note) 100 | (unless 101 | (typep note *muffled-notes-type*) 102 | (compiler-macro-notes::swank-signal note env) 103 | (push note notes))))) 104 | (lastcar 105 | (macroexpand-all 106 | lambda-with-enhanced-declarations 107 | augmented-env))))) 108 | ;; MUFFLE because they would already have been reported! 109 | (mapc #'compiler-macro-notes:muffle notes) 110 | (let ((enhanced-return-type 111 | (lastcar 112 | ;; returns a function type 113 | (form-type macroexpanded-form augmented-env)))) 114 | ;; We can't just substitute the enhanced-return-type 115 | ;; because it is possible that the originally specified 116 | ;; return-type was more specific than what a derivation 117 | ;; could tell us. 118 | (setq return-type 119 | (cond ((subtypep enhanced-return-type return-type) 120 | enhanced-return-type) 121 | ((subtypep `(and ,enhanced-return-type 122 | ,return-type) 123 | nil) 124 | (signal 'compile-time-return-type-mismatch 125 | :derived enhanced-return-type 126 | :declared return-type 127 | :form lambda-with-enhanced-declarations) 128 | (return-from pf-compiler-macro-function 129 | original-form)) 130 | (t 131 | (combine-values-types 132 | 'and return-type enhanced-return-type))))) 133 | ;; Some macroexpand-all can produce a (function (lambda ...)) from (lambda ...) 134 | ;; Some others do not 135 | (if (eq 'cl:function (first macroexpanded-form)) 136 | (second macroexpanded-form) 137 | macroexpanded-form))))) 138 | 139 | (cond (optim-speed 140 | (when more-optimal-type-list 141 | (signal 'more-optimal-polymorph-inapplicable 142 | :more-optimal-type-list more-optimal-type-list)) 143 | (when suboptimal-note (signal suboptimal-note :type-list type-list)) 144 | (return-from pf-compiler-macro-function 145 | (let ((inline-pf 146 | (assoc 'inline-pf 147 | (nth-value 2 (function-information name env)))) 148 | (inline-dispatch-form 149 | `(the ,return-type 150 | (symbol-macrolet ((top-level-p nil)) 151 | (,inline-lambda-body ,@expanded-args)))) 152 | (non-inline-dispatch-form 153 | `(the ,return-type 154 | (symbol-macrolet ((top-level-p nil)) 155 | (,static-dispatch-name ,@expanded-args))))) 156 | (ecase inline-p 157 | ((t) 158 | (assert inline-lambda-body) 159 | (if (eq 'notinline-pf (cdr inline-pf)) 160 | non-inline-dispatch-form 161 | inline-dispatch-form)) 162 | ((nil) 163 | (when (eq 'inline-pf (cdr inline-pf)) 164 | (signal 'polymorph-has-no-inline-lambda-body 165 | :name name :type-list type-list)) 166 | non-inline-dispatch-form) 167 | ((:maybe) 168 | (cond ((null inline-pf) 169 | non-inline-dispatch-form) 170 | ((eq 'inline-pf (cdr inline-pf)) 171 | (assert inline-lambda-body) 172 | inline-dispatch-form) 173 | ((eq 'notinline-pf (cdr inline-pf)) 174 | non-inline-dispatch-form) 175 | (t 176 | (error "Unexpected case in pf-compiler-macro!")))))))) 177 | (t 178 | (return-from pf-compiler-macro-function original-form)))))) 179 | 180 | (defun pf-compiler-macro-function/with-checks (form &optional env) 181 | (when (eq 'apply (first form)) 182 | (format *error-output* "~A can optimize cases other than FUNCALL and raw call!~%Ask the maintainer of POLYMORPHIC-FUNCTIONS to provide support for this case!" 183 | (lisp-implementation-type)) 184 | (return-from pf-compiler-macro-function/with-checks form)) 185 | 186 | (let* ((*environment* env) 187 | (*compiler-macro-expanding-p* t) 188 | (original-form form)) 189 | 190 | (multiple-value-bind (name unexpanded-args) 191 | (if (eq 'funcall (car form)) 192 | (values (optima:match (second form) 193 | ((list 'cl:function name) 194 | name) 195 | (variable 196 | variable)) 197 | (rest (rest form))) 198 | (values (first form) 199 | (rest form))) 200 | 201 | (compiler-macro-notes:with-notes 202 | (original-form env :name (fdefinition name) 203 | :unwind-on-signal nil 204 | :optimization-note-condition 205 | (and optim-speed 206 | (not *disable-static-dispatch*))) 207 | 208 | (unless (macroexpand 'top-level-p env) 209 | (return-from pf-compiler-macro-function/with-checks form)) 210 | 211 | (let* ((expanded-args (mapcar (lambda (form) 212 | (with-output-to-string (*error-output*) 213 | (setq form (macroexpand-all form env))) 214 | form) 215 | unexpanded-args)) 216 | ;; Expanding things here results in O(n) calls to this function 217 | ;; rather than O(n^2); although the actual effects of this are 218 | ;; insignificant for day-to-day compilations 219 | (arg-types (mapcar (lambda (form) 220 | (let (form-type) 221 | ;; We already have the expanded forms 222 | (with-output-to-string (*error-output*) 223 | (setq form-type (nth-form-type form env 0 nil nil))) 224 | form-type)) 225 | expanded-args)) 226 | ;; FORM-TYPE-FAILURE: We not only want to inform the user that there 227 | ;; was a failure, but also inform them what the failure-ing form was. 228 | ;; However, even if there was what appeared to be a failure on an 229 | ;; earlier polymorph (because its type list was more specific than T), 230 | ;; the possibility that there exists a later polymorph remains. 231 | ;; Therefore, we first muffle the duplicated FORM-TYPE-FAILUREs; 232 | ;; then, if a polymorph was found (see COND below), we further muffle 233 | ;; the non-duplicated failures as well. 234 | (form-type-failures nil) 235 | (polymorph (handler-bind ((form-type-failure 236 | (lambda (c) 237 | (if (find c form-type-failures 238 | :test (lambda (c1 c2) 239 | (equalp (form c1) 240 | (form c2)))) 241 | (compiler-macro-notes:muffle c) 242 | (push c form-type-failures))))) 243 | (apply #'compiler-retrieve-polymorph 244 | name (mapcar #'cons (rest form) arg-types))))) 245 | 246 | (when (and optim-debug 247 | (not (declaration-information 'pf-defined-before-use env))) 248 | (return-from pf-compiler-macro-function/with-checks original-form)) 249 | (cond ((and (null polymorph) 250 | optim-speed 251 | ;; We can be sure that *something* will be printed 252 | ;; However, if there were no failures, and no polymorphs 253 | ;; *nothing* will be shown! And then we rely on the 254 | ;; NO-APPLICABLE-POLYMORPH/COMPILER-NOTE below. 255 | form-type-failures) 256 | (return-from pf-compiler-macro-function/with-checks original-form)) 257 | (polymorph 258 | ;; We muffle, because unsuccessful searches could have resulted 259 | ;; in compiler notes 260 | (mapc #'compiler-macro-notes:muffle form-type-failures))) 261 | (when (and (null polymorph) 262 | (or optim-speed optim-safety 263 | (declaration-information 'pf-defined-before-use env))) 264 | (handler-case (funcall (polymorphic-function-default (fdefinition name)) 265 | name env expanded-args arg-types) 266 | (condition (c) 267 | (if (declaration-information 'pf-defined-before-use env) 268 | (error c) 269 | (signal c))))) 270 | (when (or (null polymorph) 271 | (not optim-speed) 272 | *disable-static-dispatch*) 273 | (return-from pf-compiler-macro-function/with-checks original-form)) 274 | 275 | (pf-compiler-macro-function name original-form polymorph unexpanded-args 276 | expanded-args arg-types env)))))) 277 | 278 | ;; Separate into a function and macro-function so that redefinitions during 279 | ;; development are caught easily 280 | (defun pf-compiler-macro (form &optional env) 281 | (pf-compiler-macro-function/with-checks form env)) 282 | -------------------------------------------------------------------------------- /src/lambda-lists/required-key.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defmethod %lambda-list-type ((type (eql 'required-key)) (lambda-list list)) 4 | (let ((state :required)) 5 | (dolist (elt lambda-list) 6 | (ecase state 7 | (:required (cond ((eq elt '&rest) 8 | (setf state '&rest)) 9 | ((eq elt '&key) 10 | (setf state '&key)) 11 | ((and *lambda-list-typed-p* (listp elt) 12 | (valid-parameter-name-p (first elt))) 13 | t) 14 | ((and (not *lambda-list-typed-p*) 15 | (valid-parameter-name-p elt)) 16 | t) 17 | (t 18 | (return-from %lambda-list-type nil)))) 19 | (&rest (cond ((eq elt '&key) 20 | (setf state '&key)) 21 | ((valid-parameter-name-p elt) 22 | t) 23 | (t 24 | (return-from %lambda-list-type nil)))) 25 | (&key (cond ((and *lambda-list-typed-p* 26 | (listp elt) 27 | (let ((elt (first elt))) 28 | (and (listp elt) 29 | (valid-parameter-name-p (first elt)))) 30 | (if (null (third elt)) 31 | t 32 | (valid-parameter-name-p (third elt))) 33 | (null (fourth elt))) 34 | t) 35 | ((and (not *lambda-list-typed-p*) 36 | (or (valid-parameter-name-p elt) 37 | (and (listp elt) 38 | (valid-parameter-name-p (first elt))))) 39 | t) 40 | (t 41 | (return-from %lambda-list-type nil)))))) 42 | (eq state '&key))) 43 | 44 | (def-test type-identification-key (:suite lambda-list) 45 | (is (eq 'required-key (lambda-list-type '(&key))) 46 | "(defun foo (&key)) does compile") 47 | (is (eq 'required-key (lambda-list-type '(a &key))) 48 | "(defun foo (a &key)) does compile") 49 | (is (eq 'required-key (lambda-list-type '(a &key b)))) 50 | (is-error (lambda-list-type '(a &key 5))) 51 | (is-error (lambda-list-type '(a &key b &rest))) 52 | (is (eq 'required-key 53 | (lambda-list-type '((a string) (b number) &key 54 | ((c number))) ; say if it actually is a null-type? 55 | :typed t))) 56 | (is (eq 'required-key 57 | (lambda-list-type '((a string) (b number) &key 58 | ((c number) 5 c)) 59 | :typed t))) 60 | (is (eq 'required-key 61 | (lambda-list-type '((a string) (b number) &key 62 | ((c number) 5 c)) 63 | :typed t))) 64 | (is (eq 'required-key 65 | (lambda-list-type '((a string) (b number) &key 66 | ((c number) b c)) 67 | :typed t))) 68 | (is-error (lambda-list-type '((a string) (b number) &key 69 | ((c number) 5 6)) 70 | :typed t)) 71 | (is-error (lambda-list-type '((a string) (b number) &key 72 | ((c number) 5 6 7)) 73 | :typed t)) 74 | (is-error (lambda-list-type '((a string) (b number) &key 75 | (c number)) 76 | :typed t))) 77 | 78 | (def-test effective-lambda-list-key (:suite effective-lambda-list) 79 | (flet ((effective-typed-lambda-list (typed-lambda-list) 80 | (let ((typed-lambda-list (normalize-typed-lambda-list typed-lambda-list))) 81 | (polymorph-effective-lambda-list 82 | (make-polymorph-parameters-from-lambda-lists 83 | (untyped-lambda-list typed-lambda-list) 84 | typed-lambda-list))))) 85 | (destructuring-bind ((first second third fourth) type-list effective-type-list) 86 | (multiple-value-list (effective-typed-lambda-list '((a string) (b number) &key 87 | ((c number) 5)))) 88 | (is (eq first 'a)) 89 | (is (eq second 'b)) 90 | (is (eq third '&key)) 91 | (is (equalp '(c 5) fourth)) 92 | (is (equalp type-list 93 | '(string number &key (:c number)))) 94 | (is (equalp effective-type-list 95 | '(string number &key (:c (or null number)))))))) 96 | 97 | (defmethod compute-polymorphic-function-lambda-body 98 | ((type (eql 'required-key)) (untyped-lambda-list list) declaration 99 | &optional invalidated-p) 100 | (let* ((rest-position (position '&rest untyped-lambda-list)) 101 | (required-parameters (subseq untyped-lambda-list 0 rest-position)) 102 | (keyword-parameters (subseq untyped-lambda-list (+ 3 rest-position))) 103 | (rest-args (nth (1+ rest-position) untyped-lambda-list)) 104 | (block-name (blockify-name *name*))) 105 | `((declare (ignorable ,@(mapcar #'first keyword-parameters) 106 | ,@(mapcar #'third keyword-parameters)) 107 | (dynamic-extent ,rest-args) 108 | ,declaration) 109 | (block ,block-name 110 | ,(if invalidated-p 111 | `(progn 112 | (update-polymorphic-function-lambda (fdefinition ',*name*)) 113 | (apply (fdefinition ',*name*) ,@required-parameters ,rest-args)) 114 | `(apply 115 | (cl:the cl:function 116 | (locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 117 | (cond 118 | ,@(loop 119 | :for i :from 0 120 | :for polymorph :in (polymorphic-function-polymorphs 121 | (fdefinition *name*)) 122 | :for static-dispatch-name 123 | := (polymorph-static-dispatch-name polymorph) 124 | :for runtime-applicable-p-form 125 | := (polymorph-runtime-applicable-p-form polymorph) 126 | :collect 127 | `(,runtime-applicable-p-form #',static-dispatch-name)) 128 | (t 129 | (return-from ,*name* 130 | (funcall ,(polymorphic-function-default (fdefinition *name*)) 131 | ',*name* nil (list* ,@required-parameters ,rest-args))))))) 132 | ,@required-parameters ,rest-args)))))) 133 | 134 | (defmethod %sbcl-transform-arg-lvars-from-lambda-list-form ((type (eql 'required-key)) 135 | (untyped-lambda-list list)) 136 | (assert (not *lambda-list-typed-p*)) 137 | (let ((key-position (position '&key untyped-lambda-list))) 138 | `(append ,@(loop :for arg :in (subseq untyped-lambda-list 0 key-position) 139 | :collect `(list (cons ',arg ,arg))) 140 | ,@(loop :for param-name :in (subseq untyped-lambda-list 141 | (1+ key-position)) 142 | :collect `(if ,param-name 143 | ,(let ((keyword (intern (symbol-name param-name) :keyword))) 144 | `(list (cons ,keyword ,keyword) 145 | (cons ',param-name ,param-name))) 146 | nil))))) 147 | 148 | (defmethod %type-list-compatible-p ((type (eql 'required-key)) 149 | (type-list list) 150 | (untyped-lambda-list list)) 151 | (let ((pos-key (position '&key type-list)) 152 | (pos-rest (or (position '&rest untyped-lambda-list) 153 | (position '&key untyped-lambda-list)))) 154 | (unless (and (numberp pos-key) 155 | (numberp pos-rest) 156 | (= pos-key pos-rest)) 157 | (return-from %type-list-compatible-p nil)) 158 | (let ((assoc-list (subseq type-list (1+ pos-key)))) 159 | (loop :for (param default paramp) :in (subseq untyped-lambda-list (+ pos-key 3)) 160 | :do (unless (assoc-value assoc-list (intern (symbol-name param) :keyword)) 161 | (return-from %type-list-compatible-p nil)))) 162 | (let ((key-list (mapcar #'first (subseq untyped-lambda-list (+ pos-key 3))))) 163 | (loop :for (key . rest) :in (subseq type-list (1+ pos-key)) 164 | :do (unless (find (intern (symbol-name key) :keyword) key-list :test #'string=) 165 | (return-from %type-list-compatible-p nil)))) 166 | t)) 167 | 168 | (defmethod %type-list-more-specific-p ((type-1 (eql 'required-key)) 169 | (type-2 (eql 'required-key)) 170 | list-1 list-2) 171 | (declare (optimize speed) 172 | (type list list-1 list-2)) 173 | (let ((key-position-1 (position '&key list-1)) 174 | (key-position-2 (position '&key list-2))) 175 | (if (= key-position-1 key-position-2) 176 | (and (loop :for type-1 :in (subseq list-1 0 key-position-1) 177 | :for type-2 :in (subseq list-2 0 key-position-2) 178 | ;; Return T the moment we find a SUBTYPEP with not TYPE= 179 | ;; The ones before this point should be TYPE= 180 | :do (cond ((type= type-1 type-2) 181 | t) 182 | ((subtypep type-1 type-2) 183 | (return-from %type-list-more-specific-p t)) 184 | (t 185 | (return nil))) 186 | :finally (return t)) 187 | ;; Assume the type-lists are ordered in the lexical order 188 | (loop :for (param-1 type-1) :in (subseq list-1 (1+ key-position-1)) 189 | :for (param-2 type-2) :in (subseq list-2 (1+ key-position-2)) 190 | :do (cond ((not (eq param-1 param-2)) 191 | (return-from %type-list-more-specific-p nil)) 192 | ((type= type-1 type-2) 193 | t) 194 | ((subtypep type-1 type-2) 195 | (return-from %type-list-more-specific-p t)) 196 | (t 197 | (return nil))) 198 | :finally (return t))) 199 | nil))) 200 | 201 | (def-test type-list-subtype-key (:suite type-list-more-specific-p) 202 | (5am:is-true (type-list-more-specific-p '(string &key (:a string)) 203 | '(string &key (:a array)))) 204 | (5am:is-true (type-list-more-specific-p '(string &key (:a string)) 205 | '(array &key (:a string)))) 206 | (5am:is-true (type-list-more-specific-p '(string &key (:a string)) 207 | '(string &key (:a string) (:b number)))) 208 | (5am:is-false (type-list-more-specific-p '(string &key (:a string)) 209 | '(string &key (:a number)))) 210 | (5am:is-false (type-list-more-specific-p '(string &key (:a string)) 211 | '(number &key (:a string)))) 212 | (5am:is-false (type-list-more-specific-p '(&key (:a string) (:b number)) 213 | '(string &key (:a string) (:b number))))) 214 | 215 | (defmethod %type-list-intersection-null-p 216 | ((type-1 (eql 'required-key)) 217 | (type-2 (eql 'required-key)) 218 | list-1 list-2) 219 | (declare (optimize debug) 220 | (type list list-1 list-2)) 221 | (let ((key-position-1 (position '&key list-1)) 222 | (key-position-2 (position '&key list-2))) 223 | (or (/= key-position-1 key-position-2) 224 | (loop :for type-1 :in (subseq list-1 0 key-position-1) 225 | :for type-2 :in (subseq list-2 0 key-position-2) 226 | ;; Return T the moment we have a non-null intersection 227 | ;; without a definite direction of SUBTYPEP 228 | :do (if (type= type-1 type-2) 229 | t 230 | (when (definitive-intersection-null-p type-1 type-2 231 | (when (boundp '*environment*) 232 | *environment*)) 233 | (return-from %type-list-intersection-null-p t))) 234 | :finally (return nil)) 235 | (let ((list-1 (subseq list-1 (1+ key-position-1))) 236 | (list-2 (subseq list-2 (1+ key-position-2)))) 237 | (loop :while (and list-1 list-2) 238 | :for (key-1 type-1) := (first list-1) 239 | :for (key-2 type-2) := (first list-2) 240 | :do (cond ((not (eq key-1 key-2)) 241 | ;; FIXME: This might not be correct 242 | (return-from %type-list-intersection-null-p t)) 243 | ((type= type-1 type-2) 244 | t) 245 | (t 246 | (let ((subtypep (definitive-subtypep 'null `(and ,type-1 ,type-2)))) 247 | (if subtypep 248 | ;; Both can accept NIL; the arguments are optional 249 | () 250 | ;; At least one argument is compulsory 251 | ;; If there exist at least one &KEY argument which need 252 | ;; to be compulsorily supplied, and both types are different, 253 | ;; then there intersection is NULL 254 | (when (definitive-intersection-null-p 255 | type-1 type-2 (when (boundp '*environment*) 256 | *environment*)) 257 | (return-from %type-list-intersection-null-p t)))))) 258 | (setq list-1 (rest list-1) 259 | list-2 (rest list-2)) 260 | :finally 261 | (return 262 | (cond ((and (null list-1) 263 | (null list-2)) 264 | nil) 265 | (list-1 266 | ;; All accept a NIL => intersection is non-NULL 267 | (not (loop :for (key type) :in list-1 268 | :always (typep nil type)))) 269 | (list-2 270 | (not (loop :for (key type) :in list-2 271 | :always (typep nil type)))) 272 | (t 273 | (error "Unhandled case!"))))))))) 274 | 275 | (def-test type-list-intersection-null-key 276 | (:suite type-list-intersection-null-p) 277 | (5am:is-false (type-list-intersection-null-p '(string &key (:a (or null string))) 278 | '(string &key (:a (or null array))))) 279 | (5am:is-false (type-list-intersection-null-p '(string &key (:a string)) 280 | `(string &key (:a string) 281 | (:b (or null number))))) 282 | (5am:is-true (type-list-intersection-null-p '(string &key (:a string)) 283 | '(string &key (:a string) (:b number)))) 284 | (5am:is-true (type-list-intersection-null-p '(string &key (:a string)) 285 | '(string &key (:a number)))) 286 | (5am:is-false (type-list-intersection-null-p '(string &key (:a string)) 287 | '(string &key (:a array)))) 288 | (5am:is-true (type-list-intersection-null-p '(string &key (:a string)) 289 | '(number &key (:a string)))) 290 | (5am:is-true (type-list-intersection-null-p '(&key (:a string) (:b number)) 291 | '(string &key (:a string) (:b number)))) 292 | (5am:is-false (type-list-intersection-null-p '(string array &key (:a string)) 293 | '(array string &key (:a string)))) 294 | (5am:is-false (type-list-intersection-null-p '(string string &key (:a string)) 295 | '(array array &key (:a string)))) 296 | (5am:is-false (type-list-intersection-null-p '((or string number) &key (:a string)) 297 | '((or string symbol) &key (:a string)))) 298 | ) 299 | -------------------------------------------------------------------------------- /src/polymorphic-function.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:polymorphic-functions) 2 | 3 | (defvar *disable-static-dispatch* nil 4 | "If value at the time of compilation of the call-site is non-NIL, 5 | the polymorphic-function being called at the call-site is dispatched dynamically.") 6 | 7 | (defun blockify-name (name) 8 | (etypecase name 9 | (symbol name) 10 | (list 11 | (assert (and (eq 'setf (first name)) 12 | (second name) 13 | (null (nthcdr 2 name)))) 14 | (second name)))) 15 | 16 | (defun polymorphic-function-type-lists (polymorphic-function) 17 | (mapcar #'polymorph-type-list (polymorphic-function-polymorphs polymorphic-function))) 18 | 19 | (defun polymorphic-function-effective-type-lists (polymorphic-function) 20 | (mapcar #'polymorph-effective-type-list 21 | (polymorphic-function-polymorphs polymorphic-function))) 22 | 23 | (defvar *name*) 24 | (setf (documentation '*name* 'variable) 25 | "NAME of the typed function being compiled. Bound inside DEFINE-POLYMORPH") 26 | 27 | (defvar *environment*) 28 | (setf (documentation '*environment* 'variable) 29 | "Bound inside the DEFINE-COMPILER-MACRO defined in DEFINE-POLYMORPH for 30 | use by functions like TYPE-LIST-APPLICABLE-P") 31 | 32 | (defun register-polymorphic-function 33 | (name untyped-lambda-list documentation default 34 | &key overwrite source declaration) 35 | (declare (type function-name name) 36 | (type function default) 37 | (type (or null string) documentation) 38 | (type untyped-lambda-list untyped-lambda-list)) 39 | (unless overwrite ; so, OVERWRITE is NIL 40 | (when-let (apf (and (fboundp name) (fdefinition name))) 41 | (if (typep apf 'polymorphic-function) 42 | (if (let ((old-lambda-list (polymorphic-function-lambda-list apf)) 43 | (new-lambda-list untyped-lambda-list)) 44 | (let ((optional-pos-old (position '&optional old-lambda-list)) 45 | (optional-pos-new (position '&optional new-lambda-list)) 46 | (key-pos-old (position '&key old-lambda-list)) 47 | (key-pos-new (position '&key new-lambda-list)) 48 | (rest-pos-old (position '&rest old-lambda-list)) 49 | (rest-pos-new (position '&rest new-lambda-list))) 50 | ;; lambda-lists are compatible and don't need to be changed 51 | (and (eql optional-pos-old optional-pos-new) 52 | (eql key-pos-old key-pos-new) 53 | (eql rest-pos-old rest-pos-new) 54 | (if (and key-pos-old key-pos-new) 55 | (equal (subseq new-lambda-list key-pos-new) 56 | (subseq old-lambda-list key-pos-old)) 57 | t)))) 58 | (progn 59 | (setf (polymorphic-function-documentation apf) documentation) 60 | (update-polymorphic-function-documentation name) 61 | (setf (polymorphic-function-dispatch-declaration apf) declaration) 62 | (invalidate-polymorphic-function-lambda apf) 63 | (return-from register-polymorphic-function name)) 64 | (cerror "Yes, delete existing POLYMORPHs to associate new ones" 65 | 'lambda-list-has-changed 66 | :name name 67 | :new-lambda-list untyped-lambda-list)) 68 | (cerror (format nil 69 | "Yes, delete existing FUNCTION associated with ~S and associate an POLYMORPHIC-FUNCTION" name) 70 | 'not-a-ahp :name name)))) 71 | (let* ((*name* name) 72 | (effective-lambda-list 73 | (polymorphic-function-make-effective-lambda-list untyped-lambda-list))) 74 | ;; We do not call UPDATE-POLYMORPHIC-FUNCTION-LAMBDA because 75 | ;; the first call is an exception: the LAMBDA-LIST received here should be used 76 | ;; to construct apf 77 | (let ((apf (make-instance 'polymorphic-function 78 | :name name 79 | :dispatch-declaration declaration 80 | :source source 81 | :documentation documentation 82 | :lambda-list untyped-lambda-list 83 | :effective-lambda-list effective-lambda-list 84 | :default default 85 | :lambda-list-type (lambda-list-type untyped-lambda-list)))) 86 | (invalidate-polymorphic-function-lambda apf) 87 | (setf (fdefinition name) apf) 88 | (update-polymorphic-function-documentation name) 89 | #+ccl (setf (ccl:arglist name) effective-lambda-list) 90 | apf))) 91 | 92 | (defun update-polymorphic-function-documentation (name) 93 | (setf (documentation name 'cl:function) 94 | (let* ((pf (fdefinition name)) 95 | (pf-doc (polymorphic-function-documentation pf)) 96 | (polymorphs (polymorphic-function-polymorphs pf))) 97 | (when (or pf-doc polymorphs) 98 | (with-output-to-string (*standard-output*) 99 | (pprint-logical-block (nil nil) 100 | (when pf-doc 101 | (write-string pf-doc) 102 | (pprint-newline :mandatory)) 103 | (when polymorphs 104 | (write-string "Polymorphs:") 105 | (pprint-indent :block 2) 106 | (pprint-newline :mandatory) 107 | (loop :for polymorph :in polymorphs 108 | :do (with-slots (effective-type-list documentation) polymorph 109 | (write (cons name effective-type-list)) 110 | (when documentation 111 | (pprint-newline :mandatory) 112 | (write-string " Documentation:") 113 | (pprint-newline :mandatory) 114 | (pprint-logical-block (nil nil :per-line-prefix " ") 115 | (write-string documentation))) 116 | (pprint-newline :mandatory))) 117 | (pprint-indent :block -2)))))))) 118 | 119 | (defun update-polymorphic-function-lambda (polymorphic-function &optional invalidate) 120 | (when (and invalidate (polymorphic-function-invalidated-p polymorphic-function)) 121 | (return-from update-polymorphic-function-lambda polymorphic-function)) 122 | (let* ((apf polymorphic-function) 123 | (*name* (polymorphic-function-name apf)) 124 | (effective-lambda-list (polymorphic-function-effective-lambda-list apf)) 125 | (lambda-list-type (polymorphic-function-lambda-list-type apf)) 126 | (declaration (polymorphic-function-dispatch-declaration apf)) 127 | (lambda-body (if invalidate 128 | (compute-polymorphic-function-lambda-body lambda-list-type 129 | effective-lambda-list 130 | declaration 131 | t) 132 | (compute-polymorphic-function-lambda-body lambda-list-type 133 | effective-lambda-list 134 | declaration))) 135 | ;; FIXME: Should we COMPILE this? 136 | (function (eval `(list-named-lambda (polymorphic-function ,*name*) 137 | ,(symbol-package (if (atom *name*) *name* (second *name*))) 138 | ,effective-lambda-list 139 | ,@lambda-body)))) 140 | (closer-mop:set-funcallable-instance-function apf function) 141 | ;; Relevant issue: https://github.com/Clozure/ccl/issues/361 142 | #+ccl (ccl::lfun-bits apf 143 | (logior (ccl::lfun-bits apf) 144 | (logand (ccl::lfun-bits function) (1- (expt 2 16))))) 145 | (setf (polymorphic-function-invalidated-p apf) invalidate) 146 | apf)) 147 | 148 | (defun invalidate-polymorphic-function-lambda (polymorphic-function) 149 | (update-polymorphic-function-lambda polymorphic-function t)) 150 | 151 | (defun add-or-update-polymorph (polymorphic-function polymorph) 152 | "Returns T if the POLYMOMRPH with identical effective-type-list existed, otherwise returns NIL." 153 | (declare (type polymorphic-function polymorphic-function) 154 | (type polymorph polymorph)) 155 | (let* ((apf polymorphic-function) 156 | (p-new polymorph) 157 | (polymorphs (polymorphic-function-polymorphs apf)) 158 | (type-list (polymorph-type-list p-new)) 159 | (p-old (find type-list polymorphs :test #'equalp 160 | :key #'polymorph-type-list)) 161 | (p-pos (when p-old (position p-old polymorphs)))) 162 | ;; FIXME: Use a type-list equality check, not EQUALP 163 | ;; FIXME: A trivial fix for &key args is to sort them lexically 164 | (cond ((and p-old (numberp p-pos)) 165 | (unless (slot-value p-new 'compiler-macro-lambda) 166 | (setf (slot-value p-new 'compiler-macro-lambda) 167 | (slot-value p-old 'compiler-macro-lambda)) 168 | (setf (slot-value p-new 'compiler-macro-source) 169 | (slot-value p-old 'compiler-macro-source))) 170 | ;; We replace p-old with p-new in the list POLYMORPHS 171 | ;; In doing so, the only thing we might need to preserve is the COMPILER-MACRO-LAMBDA 172 | (setf (nth p-pos polymorphs) p-new) 173 | (setf (polymorphic-function-polymorphs apf) polymorphs) ; do we need this? 174 | (equalp (slot-value p-new 'effective-type-list) 175 | (slot-value p-old 'effective-type-list))) 176 | (t 177 | (labels ((add-polymorph (polymorph polymorphs) 178 | (cond ((null polymorphs) 179 | (list polymorph)) 180 | ((type-list-more-specific-p 181 | (polymorph-type-list polymorph) 182 | (polymorph-type-list (first polymorphs))) 183 | (cons polymorph polymorphs)) 184 | (t 185 | (setf (cdr polymorphs) 186 | (add-polymorph polymorph (rest polymorphs))) 187 | polymorphs)))) 188 | (setf (polymorphic-function-polymorphs apf) 189 | (add-polymorph p-new polymorphs))) 190 | nil)))) 191 | 192 | (defun register-polymorph (name inline-p documentation typed-lambda-list type-list 193 | effective-type-list more-optimal-type-list suboptimal-note 194 | return-type inline-lambda-body static-dispatch-name 195 | lambda-list-type runtime-applicable-p-form 196 | compiler-applicable-p-lambda &optional source-location) 197 | (declare (type function-name name) 198 | (type (member t nil :maybe) inline-p) 199 | (type (or null string) documentation) 200 | (type typed-lambda-list typed-lambda-list) 201 | (type function-name static-dispatch-name) 202 | (type type-list type-list) 203 | (type type-list effective-type-list) 204 | (type type-list more-optimal-type-list) 205 | (type symbol suboptimal-note) 206 | (type list inline-lambda-body)) 207 | (let* ((apf (fdefinition name)) 208 | (apf-lambda-list-type (polymorphic-function-lambda-list-type apf)) 209 | (untyped-lambda-list (polymorphic-function-effective-lambda-list apf))) 210 | (when (eq apf-lambda-list-type 'rest) 211 | ;; required-optional can simply be split up into multiple required or required-key 212 | (assert (member lambda-list-type '(rest required required-key)) 213 | nil 214 | "&OPTIONAL keyword is not allowed for LAMBDA-LIST~% ~S~%of the POLYMORPHIC-FUNCTION associated with ~S" 215 | untyped-lambda-list name)) 216 | (assert (type-list-compatible-p apf-lambda-list-type type-list untyped-lambda-list) 217 | nil 218 | "TYPE-LIST~% ~S~%is not compatible with the LAMBDA-LIST~% ~S~%of the POLYMORPHs associated with ~S" 219 | type-list untyped-lambda-list name) 220 | (ensure-unambiguous-call name type-list effective-type-list) 221 | (let ((polymorph (make-polymorph :name name 222 | :documentation documentation 223 | :source source-location 224 | :inline-p inline-p 225 | :type-list type-list 226 | :return-type return-type 227 | :typed-lambda-list typed-lambda-list 228 | :lambda-list-type lambda-list-type 229 | :effective-type-list effective-type-list 230 | :more-optimal-type-list more-optimal-type-list 231 | :suboptimal-note suboptimal-note 232 | :compiler-applicable-p-lambda 233 | compiler-applicable-p-lambda 234 | :runtime-applicable-p-form 235 | runtime-applicable-p-form 236 | :inline-lambda-body inline-lambda-body 237 | :static-dispatch-name static-dispatch-name 238 | :compiler-macro-lambda nil 239 | :parameters 240 | (make-polymorph-parameters-from-lambda-lists 241 | untyped-lambda-list typed-lambda-list)))) 242 | (unless (add-or-update-polymorph apf polymorph) 243 | (invalidate-polymorphic-function-lambda apf)) 244 | (update-polymorphic-function-documentation name) 245 | polymorph))) 246 | 247 | (defun remove-polymorph (name type-list) 248 | (let ((apf (fdefinition name))) 249 | (when apf 250 | (removef (polymorphic-function-polymorphs apf) type-list 251 | :test #'equalp :key #'polymorph-type-list)))) 252 | 253 | (defun find-polymorph (name type-list) 254 | "Returns two values: 255 | If a POLYMORPHIC-FUNCTION by NAME does not exist, returns NIL NIL. 256 | If it exists, the second value is T and the first value is a possibly empty 257 | list of POLYMORPHs associated with NAME." 258 | (declare (type function-name name)) 259 | (let* ((apf (and (fboundp name) (fdefinition name))) 260 | (polymorphs (when (typep apf 'polymorphic-function) 261 | (polymorphic-function-polymorphs apf))) 262 | (type-list (type-list-order-keywords type-list))) 263 | (cond ((null (typep apf 'polymorphic-function)) 264 | (values nil nil)) 265 | (t 266 | (loop :for polymorph :in polymorphs 267 | :do (when (and (type-list-more-specific-p type-list 268 | (polymorph-type-list polymorph)) 269 | (type-list-more-specific-p (polymorph-type-list polymorph) 270 | type-list)) 271 | (return-from find-polymorph 272 | (values polymorph t)))) 273 | (values nil t))))) 274 | 275 | (defun polymorph-apropos-list-type (type &key (name nil namep) 276 | (package nil packagep)) 277 | (assert (not (and namep packagep)) 278 | () 279 | "NAME and PACKAGE must not be supplied together!") 280 | (flet ((apropos-pf (name) 281 | (let* ((apf (and (fboundp name) (fdefinition name))) 282 | (polymorphs (when (typep apf 'polymorphic-function) 283 | (polymorphic-function-polymorphs apf)))) 284 | (cond ((null (typep apf 'polymorphic-function)) 285 | (values nil nil)) 286 | (t 287 | ;; FIXME: Use a type-list equality check, not EQUALP 288 | (values 289 | (loop :for polymorph :in polymorphs 290 | :when (accepts-argument-of-type-p 291 | (polymorph-parameters polymorph) 292 | type) 293 | :collect polymorph) 294 | t)))))) 295 | (cond (namep 296 | (apropos-pf name)) 297 | (packagep 298 | (let ((names 299 | (let (l) 300 | (do-symbols (s package) 301 | (when (and (fboundp s) 302 | (typep (fdefinition s) 'polymorphic-function)) 303 | (push s l))) 304 | l))) 305 | (mappend #'apropos-pf names))) 306 | (t 307 | (let ((names 308 | (let (l) 309 | (do-all-symbols (s) 310 | (when (and (fboundp s) 311 | (typep (fdefinition s) 'polymorphic-function)) 312 | (push s l))) 313 | l))) 314 | (mappend #'apropos-pf names)))))) 315 | 316 | (defvar *compiler-macro-expanding-p* nil 317 | "Bound to T inside the DEFINE-COMPILER-MACRO defined in DEFINE-POLYMORPH") 318 | 319 | (defun may-be-pf-lambda-list (name untyped-lambda-list) 320 | (if (and (fboundp name) 321 | (typep (fdefinition name) 'polymorphic-function)) 322 | (mapcar (lambda (elt) 323 | (if (atom elt) elt (first elt))) 324 | (polymorphic-function-lambda-list 325 | (fdefinition name))) 326 | untyped-lambda-list)) 327 | 328 | ;; USE OF INTERN BELOW: 329 | ;; We do want STATIC-DISPATCH-NAME symbol collision to actually take place 330 | ;; when type lists of two polymorphs are "equivalent". 331 | ;; (Credits to phoe for pointing out in the issue at 332 | ;; https://github.com/digikar99/polymorphic-functions/issues/3) 333 | ;; Consider a file A to be 334 | ;; compiled before restarting a lisp image, and file B after the 335 | ;; restart. The use of GENTEMP meant that two "separate" compilations of 336 | ;; the same polymorph in the two files, could result in different 337 | ;; STATIC-DISPATCH-NAMEs. If the two files were then loaded 338 | ;; simultaneously, and the polymorphs static-dispatched at some point, 339 | ;; then there remained the possibility that different static-dispatches 340 | ;; could be using "different versions" of the polymorph. 341 | ;; Thus, we actually do want collisions to take place so that a same 342 | ;; deterministic/latest version of the polymorph is called; therefore we 343 | ;; use INTERN. 344 | (defun make-or-retrieve-static-dispatch-name (name type-list) 345 | (let* ((p-old (and (fboundp name) 346 | (typep (fdefinition name) 347 | 'polymorphic-function) 348 | (find-polymorph name type-list))) 349 | (old-name (when p-old 350 | (polymorph-static-dispatch-name 351 | p-old)))) 352 | (if old-name 353 | old-name 354 | (let ((*package* (find-package 355 | '#:polymorphic-functions.nonuser))) 356 | (intern (write-to-string 357 | `(polymorph ,name ,type-list)) 358 | '#:polymorphic-functions.nonuser))))) 359 | --------------------------------------------------------------------------------