mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 13:52:16 -08:00
80 lines
2.6 KiB
Common Lisp
80 lines
2.6 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; CMPFUN Library functions.
|
|
|
|
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi and William F. Schelter.
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun c1apply (args)
|
|
(check-args-number 'APPLY args 2)
|
|
(let* ((fun (first args))
|
|
(arguments (rest args)))
|
|
(cond ((and (consp fun)
|
|
(eq (first fun) 'LAMBDA))
|
|
(optimize-funcall/apply-lambda (cdr fun) arguments t))
|
|
((and (consp fun)
|
|
(eq (first fun) 'EXT::LAMBDA-BLOCK))
|
|
(setf fun (macroexpand-1 fun))
|
|
(optimize-funcall/apply-lambda (cdr fun) arguments t))
|
|
((and (consp fun)
|
|
(eq (first fun) 'FUNCTION)
|
|
(consp (second fun))
|
|
(member (caadr fun) '(LAMBDA EXT::LAMBDA-BLOCK)))
|
|
(c1apply (list* (second fun) arguments)))
|
|
(t
|
|
(let ((form (c1funcall (list* '#'APPLY args))))
|
|
(when (and (consp fun) (eq (first fun) 'FUNCTION))
|
|
(let* ((fname (second fun))
|
|
(type (get-return-type fname)))
|
|
(when type
|
|
(setf (c1form-type form) type))))
|
|
form)))))
|
|
|
|
;;----------------------------------------------------------------------
|
|
;; We transform BOOLE into the individual operations, which have
|
|
;; inliners
|
|
;;
|
|
|
|
(define-compiler-macro boole (&whole form op-code op1 op2)
|
|
(or (and (constantp op-code)
|
|
(case (eval op-code)
|
|
(#. boole-clr `(progn ,op1 ,op2 0))
|
|
(#. boole-set `(progn ,op1 ,op2 -1))
|
|
(#. boole-1 `(prog1 ,op1 ,op2))
|
|
(#. boole-2 `(progn ,op1 ,op2))
|
|
(#. boole-c1 `(prog1 (lognot ,op1) ,op2))
|
|
(#. boole-c2 `(progn ,op1 (lognot ,op2)))
|
|
(#. boole-and `(logand ,op1 ,op2))
|
|
(#. boole-ior `(logior ,op1 ,op2))
|
|
(#. boole-xor `(logxor ,op1 ,op2))
|
|
(#. boole-eqv `(logeqv ,op1 ,op2))
|
|
(#. boole-nand `(lognand ,op1 ,op2))
|
|
(#. boole-nor `(lognor ,op1 ,op2))
|
|
(#. boole-andc1 `(logandc1 ,op1 ,op2))
|
|
(#. boole-andc2 `(logandc2 ,op1 ,op2))
|
|
(#. boole-orc1 `(logorc1 ,op1 ,op2))
|
|
(#. boole-orc2 `(logorc2 ,op1 ,op2))))
|
|
form))
|
|
|
|
;----------------------------------------------------------------------
|
|
|
|
;; Return the most particular type we can EASILY obtain from x.
|
|
(defun result-type (x)
|
|
(cond ((symbolp x)
|
|
(c1form-primary-type (c1expr x)))
|
|
((constantp x)
|
|
(type-of x))
|
|
((and (consp x) (eq (car x) 'the))
|
|
(second x))
|
|
(t t)))
|
|
|