Changeset 15040
 Timestamp:
 Oct 24, 2011, 11:13:57 AM (9 years ago)
 Location:
 trunk/source/compiler
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

trunk/source/compiler/nx0.lisp
r14989 r15040 275 275 def) 276 276 277 278 ;;; Note that all lexical variables bound at this time are live across 279 ;;; a nontail call by setting a bit in each such var. This may not 280 ;;; be exactt (for many reasons), but it may help the register allocator: 281 ;;; if a variable is unlikely to be live across a call, there's less 282 ;;; reason to keep it in a register that's preserved across calls. 283 284 (defun nxnoteboundvarsliveacrosscall () 285 (dolist (var *nxboundvars*) 286 (let* ((localbits (varlocalbits var))) 287 (declare (fixnum localbits)) 288 (unless (logbitp $vbitspecial (nxvarbits var)) 289 (setf (varlocalbits var) (logior (ash 1 $vlocalbitiveacrosscall) localbits)))))) 290 277 291 (defsetf compilermacrofunction setcompilermacrofunction) 278 292 … … 409 423 410 424 411 (defun nx1typedvarinitform (pending sym form &optional (env *nxlexicalenvironment*)) 412 (let* ((type t) 413 (*nxformtype* (if (nxtrustdeclarations env) 414 (dolist (decl (pendingdeclarationsvdecls pending) type) 415 (when (and (eq (car decl) sym) (eq (cadr decl) 'type)) 416 (setq type (nx1typeintersect sym (nxtargettype type) (cddr decl))))) 417 t))) 418 (nx1typedform form env))) 425 419 426 420 427 ; Guess. … … 1295 1302 1296 1303 1297 (defun nxblockinfo (blockname &optional (afunc *nxcurrentfunction*) &aux 1298 blocks 1299 parent 1300 (toplevel (eq afunc *nxcurrentfunction*)) 1301 blockinfo) 1302 (when afunc 1303 (setq 1304 blocks (if toplevel *nxblocks* (afuncblocks afunc)) 1305 blockinfo (assq blockname blocks) 1306 parent (afuncparent afunc)) 1307 (if blockinfo 1308 (values blockinfo nil) 1309 (when parent 1310 (when (setq blockinfo (nxblockinfo blockname parent)) 1311 (values blockinfo t)))))) 1304 (defun nxblockinfo (blockname) 1305 (do* ((toplevel t nil) 1306 (afunc *nxcurrentfunction*(afuncparent afunc))) 1307 ((null afunc) (values nil nil)) 1308 (let* ((info (assq blockname (if toplevel *nxblocks* (afuncblocks afunc))))) 1309 (if info 1310 (returnfrom nxblockinfo (values info (not toplevel))))))) 1311 1312 1312 1313 1313 (defun nxtaginfo (tagname &optional (afunc *nxcurrentfunction*) &aux … … 1504 1504 nil 1505 1505 nil 1506 (nx1envbody body oldenv)1506 (nx1envbody :value body oldenv) 1507 1507 *nxnewp2decls*)))) 1508 1508 (when (eq (car l) '&method) … … 1524 1524 (nxparsesimplelambdalist pending ll) 1525 1525 (nxeffectotherdecls pending *nxlexicalenvironment*) 1526 (setq body (nx1envbody body oldenv))1526 (setq body (nx1envbody :return body oldenv)) 1527 1527 (nx1puntbindings (%car auxen) (%cdr auxen)) 1528 1528 (when methvar … … 1660 1660 (when (consp var) 1661 1661 (setq sym (pop var) initform (pop var) spvar (%car var))) 1662 (push (if noacode initform (nx1form initform)) optinits)1662 (push (if noacode initform (nx1form :value initform)) optinits) 1663 1663 (push (if (symbolp sym) 1664 1664 (nxnewstructuredvar pending sym) … … 1698 1698 (setq kvar (%car sym)) 1699 1699 (setq kkey (makekeyword kvar)))) 1700 (setq kinit (if noacode (%cadr sym) (nx1form (%cadr sym))))1700 (setq kinit (if noacode (%cadr sym) (nx1form :value (%cadr sym)))) 1701 1701 (setq ksupp (%caddr sym)))) 1702 1702 (push (if (symbolp kvar) … … 1719 1719 (let ((auxvar (nxpairname pair)) 1720 1720 (auxval (nxpairinitform pair))) 1721 (push (if noacode auxval (nx1form auxval)) auxvals)1721 (push (if noacode auxval (nx1form :value auxval)) auxvals) 1722 1722 (push (nxnewvar pending auxvar) auxvars))) 1723 1723 (values … … 1734 1734 (list (%nx1operator lambdalist) whole req opt rest keys auxen))) 1735 1735 1736 (defun nx1form (form &optional (*nxlexicalenvironment* *nxlexicalenvironment*)) 1737 (let* ((*nxformtype* (if (and (consp form) (eq (car form) 'the)) 1738 (nxtargettype (cadr form)) 1739 t))) 1740 (nx1typedform form *nxlexicalenvironment*))) 1741 1742 (defun nx1typedform (original env) 1743 (withprogramerrorhandler 1744 (lambda (c) 1745 (let ((replacement (runtimeprogramerrorform c))) 1746 (nxnotesourcetransformation original replacement) 1747 (nx1transformedform (nxtransform replacement env) env))) 1748 (multiplevaluebind (form changed source) (nxtransform original env) 1749 (declare (ignore changed)) 1750 ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from. 1751 (let ((*nxcurrentnote* (or source *nxcurrentnote*))) 1752 (nx1transformedform form env))))) 1753 1754 (defun nx1transformedform (form env) 1755 (let* ((*nxcurrentnote* (or (nxsourcenote form) *nxcurrentnote*)) 1756 (*nxcurrentcodenote* (and *nxcurrentcodenote* 1757 (or (nxensurecodenote form *nxcurrentcodenote*) 1758 (compilerbug "No source note for ~s" form)))) 1759 (acode (if (consp form) 1760 (nx1combination form env) 1761 (let* ((symbolp (nonnilsymbolp form)) 1762 (constantvalue (unless symbolp form)) 1763 (constantsymbolp nil)) 1764 (if symbolp 1765 (multiplevaluesetq (constantvalue constantsymbolp) 1766 (nxtransformdefinedconstant form env))) 1767 (if (and symbolp (not constantsymbolp)) 1768 (nx1symbol form env) 1769 (nx1immediate (nxunquote constantvalue))))))) 1770 (unless (acodenote acode) ;; leave it with most specific note 1771 (cond (*nxcurrentcodenote* 1772 (setf (acodenote acode) *nxcurrentcodenote*)) 1773 (*recordpcmapping* 1774 (setf (acodenote acode) (nxsourcenote form))))) 1775 acode)) 1776 1777 (defun nx1preferareg (form env) 1778 (nx1form form env)) 1779 1780 (defun nx1targetfixnump (form) 1781 (when (typep form 'integer) 1782 (let* ((target (backendtargetarch *targetbackend*))) 1783 (and 1784 (>= form (arch::targetmostnegativefixnum target)) 1785 (<= form (arch::targetmostpositivefixnum target)))))) 1786 1787 1788 (defun nx1immediate (form) 1736 1737 (defun nx1immediate (context form) 1738 (declare (ignorable context)) 1789 1739 (cond ((eq form t) (makeacode (%nx1operator t))) 1790 ((null form) (makeacode (%nx1operator nil))) 1791 ((nx1targetfixnump form) 1792 (makeacode (%nx1operator fixnum) form)) 1793 (t (makeacode (%nx1operator immediate) form)))) 1794 1795 (defun nx2constantformvalue (form) 1796 (setq form (nxuntypedform form)) 1797 (and (or (nxnull form) 1798 (nxt form) 1799 (and (acodep form) 1800 (or (eq (acodeoperator form) (%nx1operator immediate)) 1801 (eq (acodeoperator form) (%nx1operator fixnum)) 1802 (eq (acodeoperator form) (%nx1operator simplefunction))))) 1803 form)) 1804 1805 (defun nxnaturalconstantp (form) 1806 (setq form (nxuntypedform form)) 1807 (if (consp form) 1808 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1809 (eq (acodeoperator form) (%nx1operator immediate))) 1810 (cadr form)))) 1811 (and (typep val *nxtargetnaturaltype*) val)))) 1812 1813 (defun nxu32constantp (form) 1814 (setq form (nxuntypedform form)) 1815 (if (consp form) 1816 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1817 (eq (acodeoperator form) (%nx1operator immediate))) 1818 (cadr form)))) 1819 (and (typep val '(unsignedbyte 32)) val)))) 1820 1821 (defun nxu31constantp (form) 1822 (setq form (nxuntypedform form)) 1823 (if (consp form) 1824 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1825 (eq (acodeoperator form) (%nx1operator immediate))) 1826 (cadr form)))) 1827 (and (typep val '(unsignedbyte 31)) val)))) 1828 1829 1830 ;;; Referencecount vcell, fcell refs. 1831 (defun nx1notevcellref (sym) 1832 (let* ((there (assq sym *nx1vcells*)) 1833 (count (expt 4 *nxloopnestinglevel*))) 1834 (if there 1835 (%rplacd there (%i+ (%cdr there) count)) 1836 (push (cons sym count) *nx1vcells*))) 1837 sym) 1838 1839 (defun nx1notefcellref (sym) 1840 (let* ((there (assq sym *nx1fcells*)) 1841 (count (expt 4 *nxloopnestinglevel*))) 1842 (if there 1843 (%rplacd there (%i+ (%cdr there) count)) 1844 (push (cons sym count) *nx1fcells*)) 1845 sym)) 1846 1847 ; Note that "simple lexical refs" may not be; that's the whole problem ... 1848 (defun nx1symbol (form &optional (env *nxlexicalenvironment*)) 1740 ((null form) (makeacode (%nx1operator nil))) 1741 ((nx1targetfixnump form) 1742 (makeacode (%nx1operator fixnum) form)) 1743 (t (makeacode (%nx1operator immediate) form)))) 1744 1745 ;;; Note that "simple lexical refs" may not be; that's the whole problem ... 1746 (defun nx1symbol (context form &optional (env *nxlexicalenvironment*)) 1849 1747 (let* ((type (nxdeclaredtype form)) 1850 1748 (form … … 1856 1754 (nxsetvarbits more (%ilogior (%ilsl $vbitreffed 1) (nxvarbits more))) 1857 1755 (if (eq type t) 1858 (nx1form inheritedp)1859 (nx1form `(the ,(prog1 type (setq type t)) ,inheritedp))))1756 (nx1form context inheritedp) 1757 (nx1form context `(the ,(prog1 type (setq type t)) ,inheritedp)))) 1860 1758 (progn 1861 1759 (when (not inheritedp) 1862 1760 (nxsetvarbits info (%ilogior2 (%ilsl $vbitreffed 1) (nxvarbits info)))) 1863 (nxadjustrefcount info) 1761 (when context 1762 (nxadjustrefcount info)) 1864 1763 (nxmakelexicalreference info))) 1865 1764 (makeacode … … 1882 1781 (makeacode (%nx1operator typedform) type form)))) 1883 1782 1783 (defun nx1combination (context form env) 1784 (destructuringbind (sym &rest args) form 1785 (if (symbolp sym) 1786 (let* ((*nxsfname* sym) special) 1787 (if (and (setq special (gethash sym *nx1alphatizers*)) 1788 (or (not (functionp (fboundp sym))) 1789 (memq sym '(apply funcall ;; see bug #285 1790 %defun ;; see bug #295 1791 )) 1792 (< (safetyoptimizequantity env) 3)) 1793 ;;(not (nxlexicalfinfo sym env)) 1794 (not (nxdeclarednotinlinep sym *nxlexicalenvironment*))) 1795 (funcall special context form env) ; pass environment arg ... 1796 (progn 1797 (nx1typedcall context sym args)))) 1798 (if (lambdaexpressionp sym) 1799 (nx1lambdabind context (%cadr sym) args (%cddr sym)) 1800 (nxerror "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) 1801 1802 (defun nx1transformedform (context form env) 1803 (let* ((*nxcurrentnote* (or (nxsourcenote form) *nxcurrentnote*)) 1804 (*nxcurrentcodenote* (and *nxcurrentcodenote* 1805 (or (nxensurecodenote form *nxcurrentcodenote*) 1806 (compilerbug "No source note for ~s" form)))) 1807 (acode (if (consp form) 1808 (nx1combination context form env) 1809 (let* ((symbolp (nonnilsymbolp form)) 1810 (constantvalue (unless symbolp form)) 1811 (constantsymbolp nil)) 1812 (if symbolp 1813 (multiplevaluesetq (constantvalue constantsymbolp) 1814 (nxtransformdefinedconstant form env))) 1815 (if (and symbolp (not constantsymbolp)) 1816 (nx1symbol context form env) 1817 (nx1immediate context (nxunquote constantvalue))))))) 1818 (unless (acodenote acode) ;; leave it with most specific note 1819 (cond (*nxcurrentcodenote* 1820 (setf (acodenote acode) *nxcurrentcodenote*)) 1821 (*recordpcmapping* 1822 (setf (acodenote acode) (nxsourcenote form))))) 1823 acode)) 1824 1825 (defun nx1typedform (context original env) 1826 (withprogramerrorhandler 1827 (lambda (c) 1828 (let ((replacement (runtimeprogramerrorform c))) 1829 (nxnotesourcetransformation original replacement) 1830 (nx1transformedform context (nxtransform replacement env) env))) 1831 (multiplevaluebind (form changed source) (nxtransform original env) 1832 (declare (ignore changed)) 1833 ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from. 1834 (let ((*nxcurrentnote* (or source *nxcurrentnote*))) 1835 (nx1transformedform context form env))))) 1836 1837 (defun nx1form (context form &optional (*nxlexicalenvironment* *nxlexicalenvironment*)) 1838 #bootstrapped 1839 (unless (member context '(nil :return :value)) 1840 (break "bad context ~s" context)) 1841 (let* ((*nxformtype* (if (and (consp form) (eq (car form) 'the)) 1842 (nxtargettype (cadr form)) 1843 t))) 1844 (nx1typedform context form *nxlexicalenvironment*))) 1845 1846 (defun nx1typedvarinitform (pending sym form &optional (env *nxlexicalenvironment*)) 1847 (let* ((type t) 1848 (*nxformtype* (if (nxtrustdeclarations env) 1849 (dolist (decl (pendingdeclarationsvdecls pending) type) 1850 (when (and (eq (car decl) sym) (eq (cadr decl) 'type)) 1851 (setq type (nx1typeintersect sym (nxtargettype type) (cddr decl))))) 1852 t))) 1853 (nx1typedform :value form env))) 1854 1855 1856 1857 1858 1859 (defun nx1targetfixnump (form) 1860 (when (typep form 'integer) 1861 (let* ((target (backendtargetarch *targetbackend*))) 1862 (and 1863 (>= form (arch::targetmostnegativefixnum target)) 1864 (<= form (arch::targetmostpositivefixnum target)))))) 1865 1866 1867 1868 1869 (defun nx2constantformvalue (form) 1870 (setq form (nxuntypedform form)) 1871 (and (or (nxnull form) 1872 (nxt form) 1873 (and (acodep form) 1874 (or (eq (acodeoperator form) (%nx1operator immediate)) 1875 (eq (acodeoperator form) (%nx1operator fixnum)) 1876 (eq (acodeoperator form) (%nx1operator simplefunction))))) 1877 form)) 1878 1879 (defun nxnaturalconstantp (form) 1880 (setq form (nxuntypedform form)) 1881 (if (consp form) 1882 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1883 (eq (acodeoperator form) (%nx1operator immediate))) 1884 (cadr form)))) 1885 (and (typep val *nxtargetnaturaltype*) val)))) 1886 1887 (defun nxu32constantp (form) 1888 (setq form (nxuntypedform form)) 1889 (if (consp form) 1890 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1891 (eq (acodeoperator form) (%nx1operator immediate))) 1892 (cadr form)))) 1893 (and (typep val '(unsignedbyte 32)) val)))) 1894 1895 (defun nxu31constantp (form) 1896 (setq form (nxuntypedform form)) 1897 (if (consp form) 1898 (let* ((val (if (or (eq (acodeoperator form) (%nx1operator fixnum)) 1899 (eq (acodeoperator form) (%nx1operator immediate))) 1900 (cadr form)))) 1901 (and (typep val '(unsignedbyte 31)) val)))) 1902 1903 1904 ;;; Referencecount vcell, fcell refs. 1905 (defun nx1notevcellref (sym) 1906 (let* ((there (assq sym *nx1vcells*)) 1907 (count (expt 4 *nxloopnestinglevel*))) 1908 (if there 1909 (%rplacd there (%i+ (%cdr there) count)) 1910 (push (cons sym count) *nx1vcells*))) 1911 sym) 1912 1913 (defun nx1notefcellref (sym) 1914 (let* ((there (assq sym *nx1fcells*)) 1915 (count (expt 4 *nxloopnestinglevel*))) 1916 (if there 1917 (%rplacd there (%i+ (%cdr there) count)) 1918 (push (cons sym count) *nx1fcells*)) 1919 sym)) 1920 1921 1922 1884 1923 (defun nx1checkspecialref (form auxinfo) 1885 1924 (or (eq auxinfo :special) … … 1944 1983 1945 1984 1946 (defun nx1combination (form env) 1947 (destructuringbind (sym &rest args) form 1948 (if (symbolp sym) 1949 (let* ((*nxsfname* sym) special) 1950 (if (and (setq special (gethash sym *nx1alphatizers*)) 1951 (or (not (functionp (fboundp sym))) 1952 (memq sym '(apply funcall ;; see bug #285 1953 %defun ;; see bug #295 1954 )) 1955 (< (safetyoptimizequantity env) 3)) 1956 ;;(not (nxlexicalfinfo sym env)) 1957 (not (nxdeclarednotinlinep sym *nxlexicalenvironment*))) 1958 (funcall special form env) ; pass environment arg ... 1959 (progn 1960 (nx1typedcall sym args)))) 1961 (if (lambdaexpressionp sym) 1962 (nx1lambdabind (%cadr sym) args (%cddr sym)) 1963 (nxerror "In the form ~S, ~S is not a symbol or lambda expression." form sym))))) 1964 1965 (defun nx1treatascall (args) 1966 (nx1typedcall (car args) (%cdr args))) 1967 1968 (defun nx1typedcall (fn args &optional spreadp) 1985 ;;; If "sym" is an expression (not a symbol which names a function), 1986 ;;; the caller has already alphatized it. 1987 (defun nx1call (context sym args &optional spreadp globalonly inhibitinline) 1988 (nx1verifylength args 0 nil) 1989 (when (and (acodep sym) (eq (acodeoperator sym) (%nx1operator immediate))) 1990 (multiplevaluebind (valid name) (validfunctionnamep (%cadr sym)) 1991 (when valid 1992 (setq globalonly t sym name)))) 1993 (let ((argsinregs (if spreadp 1 (backendnumargregs *targetbackend*)))) 1994 (if (nxselfcallp sym globalonly) 1995 ;; Should check for downward functions here as well. 1996 (multiplevaluebind (deftype reason) 1997 (nx1checkcallargs *nxcurrentfunction* args spreadp) 1998 (when deftype 1999 (nx1whine deftype sym reason args spreadp)) 2000 (if (eq context :return) 2001 ;; Could check policy, note things that interfere with 2002 ;; tail call, and try to better estimate whether or not 2003 ;; this will be a real tail call. 2004 (setf (afuncbits *nxcurrentfunction*) 2005 (logior (ash 1 $fbittailcallsself) (afuncbits *nxcurrentfunction*))) 2006 (nxnoteboundvarsliveacrosscall)) 2007 (makeacode (%nx1operator selfcall) (nx1arglist args argsinregs) spreadp)) 2008 (multiplevaluebind (lambdaform containingenv token) (nxinlineexpansion sym *nxlexicalenvironment* globalonly) 2009 (or (and (not inhibitinline) 2010 (nx1expandinlinecall context lambdaform containingenv token args spreadp *nxlexicalenvironment*)) 2011 (multiplevaluebind (info afunc) (if (and (symbolp sym) (not globalonly)) (nxlexicalfinfo sym)) 2012 (when (eq 'macro (car info)) 2013 (nxerror "Can't call macro function ~s" sym)) 2014 (nxrecordxrefinfo :directcalls sym) 2015 (if (and afunc (%ilogbitp $fbitruntimedef (afuncbits afunc))) 2016 (let ((sym (varname (afunclfun afunc)))) 2017 (nx1form 2018 context 2019 (if spreadp 2020 `(,(if (eql spreadp 0) 'applyv 'apply) ,sym ,args) 2021 `(funcall ,sym ,@args)))) 2022 (let* ((val (nx1callform context sym afunc args spreadp))) 2023 (when afunc 2024 (let ((callers (afunccallers afunc)) 2025 (self *nxcurrentfunction*)) 2026 (unless (or (eq self afunc) (memq self callers)) 2027 (setf (afunccallers afunc) (cons self callers))))) 2028 (if (and (null afunc) (memq sym *nxnevertailcall*)) 2029 (makeacode (%nx1operator values) (list val)) 2030 val))))))))) 2031 2032 2033 (defun nx1treatascall (context args) 2034 (nx1typedcall context (car args) (%cdr args))) 2035 2036 (defun nx1typedcall (context fn args &optional spreadp) 1969 2037 (let ((globalonly nil) 1970 2038 (errorsp nil) … … 1978 2046 (nx1checktypedcall fn args spreadp globalonly))) 1979 2047 (setq resulttype (nx1typeintersect fn *nxformtype* resulttype)) 1980 (let ((form (nx1call fn args spreadp globalonly errorsp)))2048 (let ((form (nx1call context fn args spreadp globalonly errorsp))) 1981 2049 (if (eq resulttype t) 1982 2050 form … … 2274 2342 (arch::builtinfunctionnameoffset name)) 2275 2343 2276 (defun nx1callform (globalname afunc arglist spreadp &optional (env *nxlexicalenvironment*)) 2344 (defun nx1callform (context globalname afunc arglist spreadp &optional (env *nxlexicalenvironment*)) 2345 (unless (eq context :return) 2346 (nxnoteboundvarsliveacrosscall)) 2277 2347 (if afunc 2278 2348 (makeacode (%nx1operator lexicalfunctioncall) afunc (nx1arglist arglist (if spreadp 1 (backendnumargregs *targetbackend*))) spreadp) … … 2291 2361 (makeacode (%nx1operator call) 2292 2362 (if (symbolp globalname) 2293 (nx1immediate (nx1notefcellrefglobalname))2363 (nx1immediate context (if context (nx1notefcellref globalname) globalname)) 2294 2364 globalname) 2295 2365 (nx1arglist arglist (if spreadp 1 (backendnumargregs *targetbackend*))) 2296 2366 spreadp))))) 2297 2367 2298 ;;; If "sym" is an expression (not a symbol which names a function), 2299 ;;; the caller has already alphatized it. 2300 (defun nx1call (sym args &optional spreadp globalonly inhibitinline) 2301 (nx1verifylength args 0 nil) 2302 (when (and (acodep sym) (eq (acodeoperator sym) (%nx1operator immediate))) 2303 (multiplevaluebind (valid name) (validfunctionnamep (%cadr sym)) 2304 (when valid 2305 (setq globalonly t sym name)))) 2306 (let ((argsinregs (if spreadp 1 (backendnumargregs *targetbackend*)))) 2307 (if (nxselfcallp sym globalonly) 2308 ;; Should check for downward functions here as well. 2309 (multiplevaluebind (deftype reason) 2310 (nx1checkcallargs *nxcurrentfunction* args spreadp) 2311 (when deftype 2312 (nx1whine deftype sym reason args spreadp)) 2313 (makeacode (%nx1operator selfcall) (nx1arglist args argsinregs) spreadp)) 2314 (multiplevaluebind (lambdaform containingenv token) (nxinlineexpansion sym *nxlexicalenvironment* globalonly) 2315 (or (and (not inhibitinline) 2316 (nx1expandinlinecall lambdaform containingenv token args spreadp *nxlexicalenvironment*)) 2317 (multiplevaluebind (info afunc) (if (and (symbolp sym) (not globalonly)) (nxlexicalfinfo sym)) 2318 (when (eq 'macro (car info)) 2319 (nxerror "Can't call macro function ~s" sym)) 2320 (nxrecordxrefinfo :directcalls sym) 2321 (if (and afunc (%ilogbitp $fbitruntimedef (afuncbits afunc))) 2322 (let ((sym (varname (afunclfun afunc)))) 2323 (nx1form 2324 (if spreadp 2325 `(,(if (eql spreadp 0) 'applyv 'apply) ,sym ,args) 2326 `(funcall ,sym ,@args)))) 2327 (let* ((val (nx1callform sym afunc args spreadp))) 2328 (when afunc 2329 (let ((callers (afunccallers afunc)) 2330 (self *nxcurrentfunction*)) 2331 (unless (or (eq self afunc) (memq self callers)) 2332 (setf (afunccallers afunc) (cons self callers))))) 2333 (if (and (null afunc) (memq sym *nxnevertailcall*)) 2334 (makeacode (%nx1operator values) (list val)) 2335 val))))))))) 2336 2337 (defun nx1expandinlinecall (lambdaform env token args spreadp oldenv) 2368 2369 2370 (defun nx1expandinlinecall (context lambdaform env token args spreadp oldenv) 2338 2371 (if (and (or (null spreadp) (eq (length args) 1))) 2339 2372 (if (and token (not (memq token *nxinlineexpansions*))) … … 2350 2383 (debug . ,(debugoptimizequantity oldenv)))) 2351 2384 (if spreadp 2352 (nx1destructure lambdalist (car args) nil nil body newenv)2353 (nx1lambdabind lambdalist args body newenv)))))))2385 (nx1destructure context lambdalist (car args) nil nil body newenv) 2386 (nx1lambdabind context lambdalist args body newenv))))))) 2354 2387 2355 2388 ; note that regforms are reversed: arg_z is always in the car … … 2363 2396 (dotimes (i nstkargs (nreverse stkforms)) 2364 2397 (declare (fixnum i)) 2365 (push (nx1form (%car args)) stkforms)2398 (push (nx1form :value (%car args)) stkforms) 2366 2399 (setq args (%cdr args))) 2367 2400 (dolist (arg args regforms) 2368 (push (nx1form arg) regforms)))))2369 2370 (defun nx1formlist ( args)2401 (push (nx1form :value arg) regforms))))) 2402 2403 (defun nx1formlist (context args) 2371 2404 (let* ((a nil)) 2372 2405 (dolist (arg args) 2373 (push (nx1form arg) a))2406 (push (nx1form (if context :value) arg) a)) 2374 2407 (nreverse a))) 2375 2408 … … 2779 2812 (subtypep *nxformtype* *nxtargetnaturaltype*))))) 2780 2813 2781 (defun nxbinarybooleop ( whole env arg1 arg2 fixop intop naturalop)2814 (defun nxbinarybooleop (context whole env arg1 arg2 fixop intop naturalop) 2782 2815 (let* ((usefixop (nxbinaryfixnumopp arg1 arg2 env t)) 2783 2816 (usenaturalop (nxbinarynaturalopp arg1 arg2 env))) … … 2787 2820 (if usenaturalop *nxtargetnaturaltype* 'integer)) 2788 2821 (makeacode (if usefixop fixop (if usenaturalop naturalop intop)) 2789 (nx1form arg1)2790 (nx1form arg2)))2791 (nx1treatascall whole))))2822 (nx1form :value arg1) 2823 (nx1form :value arg2))) 2824 (nx1treatascall context whole)))) 2792 2825 2793 2826 (defun nxglobalp (sym &optional (env *nxlexicalenvironment*)) 
trunk/source/compiler/nx1.lisp
r14983 r15040 17 17 18 18 (inpackage "CCL") 19 20 21 (defmacro defnx1 (name sym contextvar arglist &body forms &environment env) 22 (unless (verifylambdalist arglist t t t) 23 (error "Invalid lambda list ~s" arglist)) 24 (multiplevaluebind (lambdalist whole environment) 25 (normalizelambdalist arglist t t) 26 (multiplevaluebind (body localdecs) (parsebody forms env) 27 (let ((wholevar (gensym "WHOLE")) 28 (envvar (gensym "ENVIRONMENT"))) 29 (multiplevaluebind (bindings bindingdecls) 30 (%destructurelambdalist lambdalist wholevar nil nil 31 :cdrp t 32 :wholep nil 33 :usewholevar t 34 :defaultinitialvalue nil) 35 (when environment 36 (setq bindings (nconc bindings (list `(,environment ,envvar))))) 37 (when whole 38 (setq bindings (nconc bindings (list `(,whole ,wholevar))))) 39 (let ((fn `(nfunction ,name 40 (lambda (,contextvar ,wholevar ,envvar) 41 (declare (ignorable ,contextvar ,wholevar ,envvar)) 42 (block ,name 43 (let* ,(nreverse bindings) 44 ,@(when bindingdecls `((declare ,@bindingdecls))) 45 ,@localdecs 46 ,@body))))) 47 (theprogn ()) 48 (ysym (gensym))) 49 `(let ((,ysym ,fn)) 50 ,(if (symbolp sym) 51 `(progn 52 (setf (gethash ',sym *nx1alphatizers*) ,ysym) 53 ;(proclaim '(inline ,sym)) 54 (pushnew ',sym *nx1compilerspecialforms*)) 55 (dolist (x sym `(progn ,@(nreverse theprogn))) 56 (if (consp x) 57 (setq x (%car x)) 58 (push `(pushnew ',x *nx1compilerspecialforms*) theprogn)) 59 ;(push `(proclaim '(inline ,x)) theprogn) 60 (push `(setf (gethash ',x *nx1alphatizers*) ,ysym) theprogn))) 61 (recordsourcefile ',name 'function) 62 ,ysym))))))) 19 63 20 64 (defun nx1typespecfortypep (typespec env &key (whine t)) … … 67 111 (nxtargettype (typespecifier (if new (specifiertype new) ctype)))))) 68 112 69 (defnx1 nx1the the (&whole call typespec form &environment env)113 (defnx1 nx1the the context (&whole call typespec form &environment env) 70 114 (let* ((typespec (nx1typespecfortypep typespec env)) 71 115 (*nxformtype* typespec) … … 108 152 typespec 109 153 (let* ((*nxformtype* typespec)) 110 (nx1transformedform transformed env))154 (nx1transformedform context transformed env)) 111 155 (nxdeclarationstypecheck env))))) 112 156 113 (defnx1 nx1structref structref (&whole whole structure offset)157 (defnx1 nx1structref structref context (&whole whole structure offset) 114 158 (if (not (fixnump (setq offset (nxgetfixnum offset)))) 115 (nx1treatascall whole)159 (nx1treatascall context whole) 116 160 (makeacode (%nx1operator structref) 117 (nx1form structure)118 (nx1form offset))))119 120 (defnx1 nx1structset structset (&whole whole structure offset newval)161 (nx1form :value structure) 162 (nx1form :value offset)))) 163 164 (defnx1 nx1structset structset context (&whole whole structure offset newval) 121 165 (if (not (fixnump (setq offset (nxgetfixnum offset)))) 122 (nx1treatascall whole)166 (nx1treatascall context whole) 123 167 (makeacode 124 168 (%nx1operator structset) 125 (nx1form structure)126 (nx1form offset)127 (nx1form newval))))128 129 (defnx1 nx1istructtypep ((istructtypep)) (&whole whole thing type &environment env)169 (nx1form :value structure) 170 (nx1form :value offset) 171 (nx1form :value newval)))) 172 173 (defnx1 nx1istructtypep ((istructtypep)) context (&whole whole thing type &environment env) 130 174 (if (and (nxformconstantp type env) (nonnilsymbolp (nxformconstantvalue type env))) 131 (makeacode (%nx1operator istructtypep) 132 (nx1immediate :eq) 133 (nx1form thing) 134 (nx1form `(registeristructcell ,type))) 135 (nx1treatascall whole))) 136 137 (defnx1 nx1makelist makelist (&whole whole size &rest keys &environment env) 175 (let* ((inner :value)) 176 (makeacode (%nx1operator istructtypep) 177 (nx1immediate inner :eq) 178 (nx1form inner thing) 179 (nx1form inner `(registeristructcell ,type)))) 180 (nx1treatascall context whole))) 181 182 (defnx1 nx1makelist makelist context (&whole whole size &rest keys &environment env) 138 183 (if (and keys 139 184 (or 140 185 (neq (listlength keys) 2) 141 186 (neq (nxtransform (%car keys) env) :initialelement))) 142 (nx1treatascall whole)187 (nx1treatascall context whole) 143 188 (makeacode 144 189 (%nx1operator makelist) 145 (nx1form size) 146 (nx1form (%cadr keys))))) 190 (nx1form :value size) 191 (nx1form :value (%cadr keys))))) 192 193 (defun nx1prognbody (context args) 194 (if (null (cdr args)) 195 (nx1form context (%car args)) 196 (makeacode (%nx1operator progn) 197 (collect ((forms)) 198 (do* () 199 ((null (cdr args)) 200 (forms (nx1form context (car args))) 201 (forms)) 202 (forms (nx1form nil (car args))) 203 (setq args (cdr args))))))) 147 204 148 205 ;;; New semantics: expansion functions are defined in current lexical environment 149 206 ;;; vice null environment. May be meaningless ... 150 (defnx1 nx1macrolet macrolet (defs &body body)207 (defnx1 nx1macrolet macrolet context (defs &body body) 151 208 (let* ((oldenv *nxlexicalenvironment*) 152 209 (newenv (newlexicalenvironment oldenv))) … … 167 224 (multiplevaluebind (body decls) (parsebody body newenv) 168 225 (nxprocessdeclarations pending decls) 169 (nx1prognbody body))))))226 (nx1prognbody context body)))))) 170 227 171 228 ;;; Does SYMBOLMACROLET allow declarations ? Yes ... 172 (defnx1 nx1symbolmacrolet symbolmacrolet (defs &body forms)229 (defnx1 nx1symbolmacrolet symbolmacrolet context (defs &body forms) 173 230 (let* ((oldenv *nxlexicalenvironment*)) 174 231 (withnxdeclarations (pending) … … 187 244 (setf (varea var) (cons :symbolmacro expansion))))) 188 245 (nxeffectotherdecls pending env) 189 (nx1envbody body oldenv))))))190 191 (defnx1 nx1progn progn (&body args)192 (nx1prognbody args))193 194 (defnx1 nx1withcframe withcframe (var &body body)246 (nx1envbody context body oldenv)))))) 247 248 (defnx1 nx1progn progn context (&body args) 249 (nx1prognbody context args)) 250 251 (defnx1 nx1withcframe withcframe context (var &body body) 195 252 (makeacode (%nx1operator withcframe) 196 (nx1form `(let* ((,var (%foreignstackpointer)))253 (nx1form context `(let* ((,var (%foreignstackpointer))) 197 254 ,@body)))) 198 255 199 (defnx1 nx1withvariablecframe withvariablecframe (size var &body body)256 (defnx1 nx1withvariablecframe withvariablecframe context (size var &body body) 200 257 (makeacode (%nx1operator withvariablecframe) 201 (nx1form size) 202 (nx1form `(let* ((,var (%foreignstackpointer))) 203 ,@body)))) 204 205 206 (defun nx1prognbody (args) 207 (if (null (cdr args)) 208 (nx1form (%car args)) 209 (makeacode (%nx1operator progn) (nx1formlist args)))) 258 (nx1form :value size) 259 (nx1form context `(let* ((,var (%foreignstackpointer))) 260 ,@body)))) 261 262 263 210 264 211 265 (defnx1 nx1unaryop ((%wordtoint) (uvsize) (%referenceexternalentrypoint) 212 (%symbol>symptr)) 266 (%symbol>symptr)) context 213 267 (arg) 214 268 (makeacode 215 (%nx1defaultoperator) (nx1form arg)))216 217 (defnx1 nx1nullaryop ((%currenttcr) (%interruptpoll) (%foreignstackpointer) (%currentframeptr)) ()269 (%nx1defaultoperator) (nx1form :value arg))) 270 271 (defnx1 nx1nullaryop ((%currenttcr) (%interruptpoll) (%foreignstackpointer) (%currentframeptr)) context () 218 272 (makeacode (%nx1defaultoperator))) 219 273 220 (defnx1 nx1fixnumref ((%fixnumref) (%fixnumrefnatural)) (base &optional (offset 0))274 (defnx1 nx1fixnumref ((%fixnumref) (%fixnumrefnatural)) context (base &optional (offset 0)) 221 275 (makeacode (%nx1defaultoperator) 222 (nx1form base)223 (nx1form offset)))224 225 (defnx1 nx1fixnumrefdoublefloat ((%fixnumrefdoublefloat)) (base &optional (index 0))276 (nx1form :value base) 277 (nx1form :value offset))) 278 279 (defnx1 nx1fixnumrefdoublefloat ((%fixnumrefdoublefloat)) context (base &optional (index 0)) 226 280 (makeacode (%nx1operator typedform) 227 281 'doublefloat 228 282 (makeacode (%nx1operator %fixnumrefdoublefloat) 229 (nx1form base)230 (nx1form index))))231 232 (defnx1 nx2fixnumsetdoublefloat ((%fixnumsetdoublefloat)) (base indexorval &optional (val nil valp))283 (nx1form :value base) 284 (nx1form :value index)))) 285 286 (defnx1 nx2fixnumsetdoublefloat ((%fixnumsetdoublefloat)) context (base indexorval &optional (val nil valp)) 233 287 (unless valp 234 288 (setq val indexorval indexorval 0)) … … 236 290 'doublefloat 237 291 (makeacode (%nx1operator %fixnumsetdoublefloat) 238 (nx1form base)239 (nx1form indexorval)240 (nx1form val))))292 (nx1form :value base) 293 (nx1form :value indexorval) 294 (nx1form :value val)))) 241 295 242 296 243 (defnx1 nx1typeunaryop ((typecode) (lisptag) (fulltag)) 297 (defnx1 nx1typeunaryop ((typecode) (lisptag) (fulltag)) context 244 298 (arg) 245 299 (let* ((operator … … 249 303 (( fulltag) (%nx1operator fulltag))))) 250 304 (makeacode 251 operator (nx1form arg))))305 operator (nx1form :value arg)))) 252 306 253 307 254 (defnx1 nx1codechar ((codechar)) (arg &environment env)308 (defnx1 nx1codechar ((codechar)) context (arg &environment env) 255 309 (makeacode (if (nxformtypep arg '(unsignedbyte 8) env) 256 310 (%nx1operator %codechar) … … 258 312 (%nx1operator %validcodechar) 259 313 (%nx1operator codechar))) 260 (nx1form arg)))261 262 (defnx1 nx1charcode ((charcode)) (arg &environment env)314 (nx1form :value arg))) 315 316 (defnx1 nx1charcode ((charcode)) context (arg &environment env) 263 317 (makeacode (if (nxformtypep arg 'character env) 264 318 (%nx1operator %charcode) 265 319 (%nx1operator charcode)) 266 (nx1form arg)))267 268 (defnx1 nx1cXr ((car) (cdr)) (arg &environment env)320 (nx1form :value arg))) 321 322 (defnx1 nx1cXr ((car) (cdr)) context (arg &environment env) 269 323 (let* ((op (if (eq *nxsfname* 'car) (%nx1operator car) (%nx1operator cdr))) 270 324 (inlineop (if (eq op (%nx1operator car)) (%nx1operator %car) (%nx1operator %cdr)))) … … 272 326 inlineop 273 327 op) 274 (nx1 preferaregarg env))))275 276 (defnx1 nx1rplacX ((rplaca) (rplacd)) (pairform valform &environment env)328 (nx1form :value arg env)))) 329 330 (defnx1 nx1rplacX ((rplaca) (rplacd)) context (pairform valform &environment env) 277 331 (let* ((op (if (eq *nxsfname* 'rplaca) (%nx1operator rplaca) (%nx1operator rplacd))) 278 332 (inlineop (if (eq op (%nx1operator rplaca)) (%nx1operator %rplaca) (%nx1operator %rplacd)))) … … 283 337 inlineop 284 338 op) 285 (nx1 preferaregpairform env)286 (nx1form valform))))287 288 (defnx1 nx1setcXr ((setcar) (setcdr)) (pairform valform &environment env)339 (nx1form :value pairform env) 340 (nx1form :value valform env)))) 341 342 (defnx1 nx1setcXr ((setcar) (setcdr)) context (pairform valform &environment env) 289 343 (let* ((op (if (eq *nxsfname* 'setcar) (%nx1operator setcar) (%nx1operator setcdr))) 290 344 (inlineop (if (eq op (%nx1operator setcar)) (%nx1operator %rplaca) (%nx1operator %rplacd))) … … 294 348 (nxformtypep pairform 'cons env))))) 295 349 (acode (makeacode (if inlinep inlineop op) 296 (nx1 preferaregpairform env)297 (nx1form valform))))350 (nx1form :value pairform env) 351 (nx1form :value valform)))) 298 352 (if inlinep 299 353 (makeacode (if (eq op (%nx1operator setcar)) (%nx1operator %car) (%nx1operator %cdr)) acode) 300 354 acode))) 301 355 302 (defun nx1ccbinaryop (op cc form1 form2) 303 (makeacode op (nx1immediate cc) (nx1form form1) (nx1form form2))) 304 305 (defnx1 nx1ccEQunaryop ((characterp) (endp) (consp) (basecharp)) (arg) 306 (makeacode (%nx1defaultoperator) (nx1immediate :EQ) (nx1form arg))) 307 308 309 310 (defnx1 nx1ccEQbinaryop ( (%ptreql) (eq)) 356 (defun nx1ccbinaryop (context op cc form1 form2) 357 (declare (ignorable context)) 358 (makeacode op 359 (nx1immediate :value cc) 360 (nx1form :value form1) (nx1form :value form2))) 361 362 (defnx1 nx1ccEQunaryop ((characterp) (endp) (consp) (basecharp)) context (arg) 363 (makeacode (%nx1defaultoperator) 364 (nx1immediate :value :EQ) 365 (nx1form :value arg))) 366 367 368 369 (defnx1 nx1ccEQbinaryop ( (%ptreql) (eq)) context 311 370 (form1 form2) 312 (nx1ccbinaryop (%nx1defaultoperator) :eq form1 form2))313 314 315 (defnx1 nx1ccNEbinaryop ((neq)) 371 (nx1ccbinaryop context (%nx1defaultoperator) :eq form1 form2)) 372 373 374 (defnx1 nx1ccNEbinaryop ((neq)) context 316 375 (form1 form2) 317 (nx1ccbinaryop (%nx1defaultoperator) :ne form1 form2))318 319 (defnx1 nx1logbitp ((logbitp)) (bitnum int &environment env)376 (nx1ccbinaryop context (%nx1defaultoperator) :ne form1 form2)) 377 378 (defnx1 nx1logbitp ((logbitp)) context (bitnum int &environment env) 320 379 (if (and (nxformtypep bitnum 321 380 (targetwordsizecase (32 '(integer 0 29)) 322 381 (64 '(integer 0 60))) env) 323 382 (nxformtypep int 'fixnum env)) 324 (nx1ccbinaryop (%nx1operator %ilogbitp) :ne bitnum int) 325 (makeacode (%nx1operator logbitp) (nx1form bitnum) (nx1form int)))) 383 (nx1ccbinaryop context (%nx1operator %ilogbitp) :ne bitnum int) 384 (makeacode (%nx1operator logbitp) 385 (nx1form :value bitnum) 386 (nx1form :value int)))) 326 387 327 388 328 389 329 (defnx1 nx1ccGTunaryop ((int>0p)) (arg) 330 (makeacode (%nx1defaultoperator) (nx1immediate :gt) (nx1form arg))) 331 332 (defnx1 nx1macrounaryop (multiplevaluelist) (arg) 390 (defnx1 nx1ccGTunaryop ((int>0p)) context (arg) 391 (makeacode (%nx1defaultoperator) 392 (nx1immediate :value :gt) 393 (nx1form :value arg))) 394 395 (defnx1 nx1macrounaryop (multiplevaluelist) context (arg) 333 396 (makeacode 334 (%nx1defaultoperator) (nx1form arg)))335 336 (defnx1 nx1atom ((atom)) (arg)337 (nx1form `(not (consp ,arg))))338 339 (defnx1 nx1locally locally (&body forms)397 (%nx1defaultoperator) (nx1form :value arg))) 398 399 (defnx1 nx1atom ((atom)) context (arg) 400 (nx1form context `(not (consp ,arg)))) 401 402 (defnx1 nx1locally locally context (&body forms) 340 403 (withnxdeclarations (pending) 341 404 (let ((env *nxlexicalenvironment*)) … … 343 406 (nxprocessdeclarations pending decls) 344 407 (nxeffectotherdecls pending env) 345 (setq body (nx1prognbody body))408 (setq body (nx1prognbody context body)) 346 409 (if decls 347 410 (makeacode (%nx1operator %declsbody) body *nxnewp2decls*) 348 411 body))))) 349 412 350 (defnx1 nx1%newptr (%newptr) (size &optional clearp) 351 (makeacode (%nx1operator %newptr) (nx1form size) (nx1form clearp))) 413 (defnx1 nx1%newptr (%newptr) context (size &optional clearp) 414 (makeacode (%nx1operator %newptr) 415 (nx1form :value size) 416 (nx1form :value clearp))) 352 417 353 418 ;;; This might also want to look at, e.g., the last form in a progn: 354 419 ;;; (not (progn ... x)) => (progn ... (not x)), etc. 355 (defnx1 nx1negation ((not) (null)) (arg)356 (if (nx1negateform (setq arg (nx1form arg)))420 (defnx1 nx1negation ((not) (null)) context (arg) 421 (if (nx1negateform (setq arg (nx1form context arg))) 357 422 arg 358 (makeacode (%nx1operator not) (nx1immediate :eq) arg)))423 (makeacode (%nx1operator not) (nx1immediate context :eq) arg))) 359 424 360 425 (defun nx1negateform (form) … … 381 446 382 447 383 (defnx1 nx1cxxr ((caar) (cadr) (cdar) (cddr)) (form)448 (defnx1 nx1cxxr ((caar) (cadr) (cdar) (cddr)) context (form) 384 449 (let* ((op *nxsfname*)) 385 450 (let* ((inner (case op … … 389 454 ((cdar cddr) 'cdr) 390 455 (t 'car)))) 391 (nx1form `(,outer (,inner ,form))))))392 393 (defnx1 nx1%inttoptr ((%inttoptr)) (int)456 (nx1form :value `(,outer (,inner ,form)))))) 457 458 (defnx1 nx1%inttoptr ((%inttoptr)) context (int) 394 459 (makeacode 395 460 (%nx1operator %consmacptr%) 396 461 (makeacode (%nx1operator %immediateinttoptr) 397 (nx1form int))))398 399 (defnx1 nx1%ptrtoint ((%ptrtoint)) (ptr)462 (nx1form :value int)))) 463 464 (defnx1 nx1%ptrtoint ((%ptrtoint)) context (ptr) 400 465 (makeacode 401 466 (%nx1operator %immediateptrtoint) 402 467 (makeacode (%nx1operator %macptrptr%) 403 (nx1form ptr))))404 405 (defnx1 nx1%nullptrp ((%nullptrp)) (ptr)406 (nx1form `(%ptreql ,ptr (%inttoptr 0))))468 (nx1form :value ptr)))) 469 470 (defnx1 nx1%nullptrp ((%nullptrp)) context (ptr) 471 (nx1form :value `(%ptreql ,ptr (%inttoptr 0)))) 407 472 408 473 (defnx1 nx1binop ( (%ilsl) (%ilsr) (%iasr) 409 (cons) (%tempcons)) 474 (cons) (%tempcons)) context 410 475 (arg1 arg2) 411 (makeacode (%nx1defaultoperator) (nx1form arg1) (nx1formarg2)))412 413 414 415 (defnx1 nx1%miscref ((%miscref)) (v i)416 (makeacode (%nx1operator uvref) (nx1form v) (nx1formi)))417 418 419 420 421 (defnx1 nx1schar ((schar)) (s i &environment env)422 (makeacode (%nx1operator %sbchar) (nx1form s env) (nx1formi env)))476 (makeacode (%nx1defaultoperator) (nx1form :value arg1) (nx1form :value arg2))) 477 478 479 480 (defnx1 nx1%miscref ((%miscref)) context (v i) 481 (makeacode (%nx1operator uvref) (nx1form :value v) (nx1form :value i))) 482 483 484 485 486 (defnx1 nx1schar ((schar)) context (s i &environment env) 487 (makeacode (%nx1operator %sbchar) (nx1form :value s env) (nx1form :value i env))) 423 488 424 489 425 490 ;;; This has to be ultrabizarre because %schar is a macro. 426 491 ;;; %schar shouldn't be a macro. 427 (defnx1 nx1%schar ((%schar)) (arg idx &environment env) 428 (let* ((arg (nxtransform arg env)) 429 (idx (nxtransform idx env)) 430 (argvar (makesymbol "STRING")) 431 (idxvar (makesymbol "INDEX"))) 432 (nx1form `(let* ((,argvar ,arg) 433 (,idxvar ,idx)) 434 (declare (optimize (speed 3) (safety 0))) 435 (declare (simplebasestring ,argvar)) 436 (schar ,argvar ,idxvar)) env))) 492 (defnx1 nx1%schar ((%schar)) context (arg idx &environment env) 493 (let* ((arg (nxtransform arg env)) 494 (idx (nxtransform idx env)) 495 (argvar (makesymbol "STRING")) 496 (idxvar (makesymbol "INDEX"))) 497 (nx1form context 498 `(let* ((,argvar ,arg) 499 (,idxvar ,idx)) 500 (declare (optimize (speed 3) (safety 0))) 501 (declare (simplebasestring ,argvar)) 502 (schar ,argvar ,idxvar)) env))) 437 503 438 (defnx1 nx1%scharcode ((%scharcode)) (arg idx)439 (makeacode (%nx1operator %scharcode) (nx1form arg)(nx1formidx)))440 441 442 (defnx1 nx1svref ((svref) (%svref)) (&environment env v i)504 (defnx1 nx1%scharcode ((%scharcode)) context (arg idx) 505 (makeacode (%nx1operator %scharcode) (nx1form :value arg)(nx1form :value idx))) 506 507 508 (defnx1 nx1svref ((svref) (%svref)) context (&environment env v i) 443 509 (makeacode (if (nxinhibitsafetychecking env) 444 510 (%nx1operator %svref) 445 511 (%nx1defaultoperator)) 446 (nx1 preferaregv env)447 (nx1form i)))448 449 (defnx1 nx1%slotref ((%slotref)) (instance idx)512 (nx1form :value v env) 513 (nx1form :value i))) 514 515 (defnx1 nx1%slotref ((%slotref)) context (instance idx) 450 516 (makeacode (%nx1defaultoperator) 451 (nx1form instance)452 (nx1form idx)))453 454 455 (defnx1 nx1%errdisp ((%errdisp)) (&rest args)517 (nx1form :value instance) 518 (nx1form :value idx))) 519 520 521 (defnx1 nx1%errdisp ((%errdisp)) context (&rest args) 456 522 (makeacode (%nx1operator %errdisp) 457 523 (nx1arglist args))) 458 524 459 (defnx1 nx1macrobinop ((nthvalue)) (arg1 arg2)460 (makeacode (%nx1defaultoperator) (nx1form arg1) (nx1formarg2)))461 462 (defnx1 nx1%typedmiscref ((%typedmiscref) (%typedmiscref)) (subtype uvector index)525 (defnx1 nx1macrobinop ((nthvalue)) context (arg1 arg2) 526 (makeacode (%nx1defaultoperator) (nx1form :value arg1) (nx1form :value arg2))) 527 528 (defnx1 nx1%typedmiscref ((%typedmiscref) (%typedmiscref)) context (subtype uvector index) 463 529 (makeacode (%nx1operator %typeduvref) 464 (nx1form subtype)465 (nx1form uvector)466 (nx1form index)))467 468 469 470 (defnx1 nx1%typedmiscset ((%typedmiscset) (%typedmiscset)) (subtype uvector index newvalue)530 (nx1form :value subtype) 531 (nx1form :value uvector) 532 (nx1form :value index))) 533 534 535 536 (defnx1 nx1%typedmiscset ((%typedmiscset) (%typedmiscset)) context (subtype uvector index newvalue) 471 537 (makeacode (%nx1operator %typeduvset) 472 (nx1form subtype) 473 (nx1form uvector) 474 (nx1form index) 475 (nx1form newvalue))) 476 477 (defnx1 nx1logior2 ((logior2)) (&whole w &environment env arg1 arg2) 478 (nxbinarybooleop w 538 (nx1form :value subtype) 539 (nx1form :value uvector) 540 (nx1form :value index) 541 (nx1form :value newvalue))) 542 543 (defnx1 nx1logior2 ((logior2)) context (&whole w &environment env arg1 arg2) 544 (nxbinarybooleop context 545 w 479 546 env 480 547 arg1 … … 484 551 (%nx1operator %naturallogior))) 485 552 486 (defnx1 nx1logxor2 ((logxor2)) (&whole w &environment env arg1 arg2) 487 (nxbinarybooleop w 553 (defnx1 nx1logxor2 ((logxor2)) context (&whole w &environment env arg1 arg2) 554 (nxbinarybooleop context 555 w 488 556 env 489 557 arg1 … … 493 561 (%nx1operator %naturallogxor))) 494 562 495 (defnx1 nx1logand2 ((logand2)) (&environment env arg1 arg2)563 (defnx1 nx1logand2 ((logand2)) context (&environment env arg1 arg2) 496 564 (let* ((nat1 (nxformtypep arg1 *nxtargetnaturaltype* env)) 497 565 (nat2 (nxformtypep arg2 *nxtargetnaturaltype* env))) … … 501 569 *nxtargetfixnumtype* 502 570 (makeacode (%nx1operator %ilogand2) 503 (nx1form arg1 env)504 (nx1form arg2 env))))571 (nx1form :value arg1 env) 572 (nx1form :value arg2 env)))) 505 573 ((and nat1 (typep arg2 'integer)) 506 574 (makeacode (%nx1operator typedform) 507 575 *nxtargetnaturaltype* 508 576 (makeacode (%nx1operator %naturallogand) 509 (nx1form arg1 env)510 (nx1form (logand arg2577 (nx1form :value arg1 env) 578 (nx1form :value (logand arg2 511 579 (1 (ash 1 (targetwordsizecase 512 580 (32 32) … … 517 585 *nxtargetnaturaltype* 518 586 (makeacode (%nx1operator %naturallogand) 519 (nx1form arg2 env)520 (nx1form (logand arg1587 (nx1form :value arg2 env) 588 (nx1form :value (logand arg1 521 589 (1 (ash 1 (targetwordsizecase 522 590 (32 32) … … 527 595 *nxtargetnaturaltype* 528 596 (makeacode (%nx1operator %naturallogand) 529 (nx1form arg1 env)530 (nx1form arg2 env))))597 (nx1form :value arg1 env) 598 (nx1form :value arg2 env)))) 531 599 (t 532 600 (makeacode (%nx1operator typedform) 533 601 'integer 534 602 (makeacode (%nx1operator logand2) 535 (nx1form arg1 env)536 (nx1form arg2 env)))))))603 (nx1form :value arg1 env) 604 (nx1form :value arg2 env))))))) 537 605 538 606 … … 553 621 (requireu32) 554 622 (requires64) 555 (requireu64)) 623 (requireu64)) context 556 624 (arg &environment env) 557 625 … … 576 644 (requires64 '(signedbyte 64)) 577 645 (requireu64 '(unsignedbyte 64))))) 578 (nx1form `(the ,type ,arg)))579 (makeacode (%nx1defaultoperator) (nx1form arg))))580 581 (defnx1 nx1%markermarker ((%unboundmarker) (%slotunboundmarker) (%illegalmarker)) ()646 (nx1form context `(the ,type ,arg))) 647 (makeacode (%nx1defaultoperator) (nx1form :value arg)))) 648 649 (defnx1 nx1%markermarker ((%unboundmarker) (%slotunboundmarker) (%illegalmarker)) context () 582 650 (makeacode (%nx1defaultoperator))) 583 651 584 (defnx1 nx1throw (throw) (tag valuesform)585 (makeacode (%nx1operator throw) (nx1form tag) (nx1formvaluesform)))652 (defnx1 nx1throw (throw) context (tag valuesform) 653 (makeacode (%nx1operator throw) (nx1form :value tag) (nx1form :value valuesform))) 586 654 587 655 … … 600 668 ;;; contain whatever randomness is floating around at the point of 601 669 ;;; application.) 602 (defun nx1destructure ( lambdalist bindform cdrp &wholeallowedp forms &optional (bodyenv *nxlexicalenvironment*))670 (defun nx1destructure (context lambdalist bindform cdrp &wholeallowedp forms &optional (bodyenv *nxlexicalenvironment*)) 603 671 (let* ((oldenv bodyenv) 604 672 (*nxboundvars* *nxboundvars*) 605 (bindform (nx1form bindform)))673 (bindform (nx1form :value bindform))) 606 674 (if (not (verifylambdalist lambdalist t &wholeallowedp)) 607 675 (nxerror "Invalid lambdalist ~s" lambdalist) … … 624 692 auxen 625 693 whole 626 (nx1envbody body oldenv)694 (nx1envbody context body oldenv) 627 695 *nxnewp2decls* 628 696 cdrp)))))))) … … 630 698 631 699 632 (defnx1 nx1%setfmacptr ((%setfmacptr)) (ptr newval)633 (let* ((arg1 (nx1form ptr))634 (arg2 (nx1form newval)))700 (defnx1 nx1%setfmacptr ((%setfmacptr)) context (ptr newval) 701 (let* ((arg1 (nx1form :value ptr)) 702 (arg2 (nx1form :value newval))) 635 703 (if (and (consp arg1) (eq (%car arg1) (%nx1operator %consmacptr%))) 636 704 ;e.g. (%setfmacptr (%nullptr) <foo>) … … 640 708 (makeacode (%nx1operator %setfmacptr) arg1 arg2)))) 641 709 642 (defnx1 nx1%setfdoublefloat ((%setfdoublefloat)) (doublenode doubleval)643 (makeacode (%nx1operator %setfdoublefloat) (nx1form doublenode) (nx1formdoubleval)))644 645 (defnx1 nx1%setfshortfloat ((%setfshortfloat) (%setfsinglefloat)) (shortnode shortval)710 (defnx1 nx1%setfdoublefloat ((%setfdoublefloat)) context (doublenode doubleval) 711 (makeacode (%nx1operator %setfdoublefloat) (nx1form :value doublenode) (nx1form :value doubleval))) 712 713 (defnx1 nx1%setfshortfloat ((%setfshortfloat) (%setfsinglefloat)) context (shortnode shortval) 646 714 (targetwordsizecase 647 715 (32 648 (makeacode (%nx1operator %setfshortfloat) (nx1form shortnode) (nx1formshortval)))716 (makeacode (%nx1operator %setfshortfloat) (nx1form :value shortnode) (nx1form :value shortval))) 649 717 (64 650 718 (error "%SETFSHORTFLOAT makes no sense on 64bit platforms.")))) 651 719 652 720 653 (defnx1 nx1%incptr ((%incptr)) (ptr &optional (increment 1))721 (defnx1 nx1%incptr ((%incptr)) context (ptr &optional (increment 1)) 654 722 (makeacode (%nx1operator %consmacptr%) 655 723 (makeacode (%nx1operator %immediateincptr) 656 (makeacode (%nx1operator %macptrptr%) (nx1form ptr))657 (nx1form increment))))658 659 (defnx1 nx1svset ((svset) (%svset)) (&environment env vector index value)724 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptr)) 725 (nx1form :value increment)))) 726 727 (defnx1 nx1svset ((svset) (%svset)) context (&environment env vector index value) 660 728 (makeacode (if (nxinhibitsafetychecking env) 661 729 (%nx1operator %svset) 662 730 (%nx1defaultoperator)) 663 (nx1 preferareg vector env) (nx1form index) (nx1formvalue)))664 665 (defnx1 nx1+ ((+2)) (&environment env num1 num2)666 (let* ((f1 (nx1form num1))667 (f2 (nx1form num2)))731 (nx1form :value vector env) (nx1form :value index) (nx1form :value value))) 732 733 (defnx1 nx1+ ((+2)) context (&environment env num1 num2) 734 (let* ((f1 (nx1form :value num1)) 735 (f2 (nx1form :value num2))) 668 736 (if (nxbinaryfixnumopp num1 num2 env t) 669 737 (let* ((fixadd (makeacode (%nx1operator %i+) f1 f2)) … … 678 746 (if (and (nxformtypep num1 'doublefloat env) 679 747 (nxformtypep num2 'doublefloat env)) 680 (nx1form `(%doublefloat+2 ,num1 ,num2))748 (nx1form context `(%doublefloat+2 ,num1 ,num2)) 681 749 (if (and (nxformtypep num1 'shortfloat env) 682 750 (nxformtypep num2 'shortfloat env)) 683 (nx1form `(%shortfloat+2 ,num1 ,num2))751 (nx1form context `(%shortfloat+2 ,num1 ,num2)) 684 752 (if (nxbinarynaturalopp num1 num2 env nil) 685 753 (makeacode (%nx1operator typedform) … … 689 757 (makeacode (%nx1operator add2) f1 f2)))))))) 690 758 691 (defnx1 nx1%doublefloatx2 ((%doublefloat+2) (%doublefloat2) (%doublefloat*2) (%doublefloat/2 )) 759 (defnx1 nx1%doublefloatx2 ((%doublefloat+2) (%doublefloat2) (%doublefloat*2) (%doublefloat/2 )) context 692 760 (f0 f1) 693 761 (makeacode (%nx1operator typedform) 'doublefloat 694 (makeacode (%nx1defaultoperator) (nx1form f0) (nx1formf1))))695 696 697 (defnx1 nx1%shortfloatx2 ((%shortfloat+2) (%shortfloat2) (%shortfloat*2) (%shortfloat/2 )) 762 (makeacode (%nx1defaultoperator) (nx1form :value f0) (nx1form :value f1)))) 763 764 765 (defnx1 nx1%shortfloatx2 ((%shortfloat+2) (%shortfloat2) (%shortfloat*2) (%shortfloat/2 )) context 698 766 (f0 f1) 699 767 (makeacode (%nx1operator typedform) 'shortfloat 700 (makeacode (%nx1defaultoperator) (nx1form f0) (nx1formf1))))701 702 703 (defnx1 nx1*2 ((*2)) (&environment env num1 num2)768 (makeacode (%nx1defaultoperator) (nx1form :value f0) (nx1form :value f1)))) 769 770 771 (defnx1 nx1*2 ((*2)) context (&environment env num1 num2) 704 772 (if (nxbinaryfixnumopp num1 num2 env) 705 (makeacode (%nx1operator %i*) (nx1form num1 env) (nx1formnum2 env))773 (makeacode (%nx1operator %i*) (nx1form :value num1 env) (nx1form :value num2 env)) 706 774 (if (and (nxformtypep num1 'doublefloat env) 707 775 (nxformtypep num2 'doublefloat env)) 708 (nx1form `(%doublefloat*2 ,num1 ,num2))776 (nx1form context `(%doublefloat*2 ,num1 ,num2)) 709 777 (if (and (nxformtypep num1 'shortfloat env) 710 778 (nxformtypep num2 'shortfloat env)) 711 (nx1form `(%shortfloat*2 ,num1 ,num2))712 (makeacode (%nx1operator mul2) (nx1form num1 env) (nx1formnum2 env))))))713 714 (defnx1 nx1%negate ((%negate)) (num &environment env)779 (nx1form context `(%shortfloat*2 ,num1 ,num2)) 780 (makeacode (%nx1operator mul2) (nx1form :value num1 env) (nx1form :value num2 env)))))) 781 782 (defnx1 nx1%negate ((%negate)) context (num &environment env) 715 783 (if (nxformtypep num 'fixnum env) 716 784 (if (subtypep *nxformtype* 'fixnum) 717 (makeacode (%nx1operator %%ineg)(nx1form num))718 (makeacode (%nx1operator %ineg) (nx1form num)))719 (let* ((acode (makeacode (%nx1operator minus1) (nx1form num env))))785 (makeacode (%nx1operator %%ineg)(nx1form :value num)) 786 (makeacode (%nx1operator %ineg) (nx1form :value num))) 787 (let* ((acode (makeacode (%nx1operator minus1) (nx1form :value num env)))) 720 788 (if (nxformtypep num 'doublefloat env) 721 789 (makeacode (%nx1operator typedform) … … 731 799 732 800 733 (defnx1 nx12 ((2)) (&environment env num0 num1)801 (defnx1 nx12 ((2)) context (&environment env num0 num1) 734 802 (if (nxbinaryfixnumopp num0 num1 env t) 735 (let* ((f0 (nx1form num0))736 (f1 (nx1form num1))803 (let* ((f0 (nx1form :value num0)) 804 (f1 (nx1form :value num1)) 737 805 (fixsub (makeacode (%nx1operator %i) f0 f1)) 738 806 (smallenough (targetwordsizecase … … 746 814 (if (and (nxformtypep num0 'doublefloat env) 747 815 (nxformtypep num1 'doublefloat env)) 748 (nx1form `(%doublefloat2 ,num0 ,num1))816 (nx1form context `(%doublefloat2 ,num0 ,num1)) 749 817 (if (and (nxformtypep num0 'shortfloat env) 750 818 (nxformtypep num1 'shortfloat env)) 751 (nx1form `(%shortfloat2 ,num0 ,num1))819 (nx1form context `(%shortfloat2 ,num0 ,num1)) 752 820 (if (nxbinarynaturalopp num0 num1 env nil) 753 821 (makeacode (%nx1operator %natural) 754 (nx1form num0)755 (nx1form num1))822 (nx1form :value num0) 823 (nx1form :value num1)) 756 824 (makeacode (%nx1operator sub2) 757 (nx1form num0)758 (nx1form num1)))))))825 (nx1form :value num0) 826 (nx1form :value num1))))))) 759 827 760 (defnx1 nx1/2 ((/2)) (num0 num1 &environment env)828 (defnx1 nx1/2 ((/2)) context (num0 num1 &environment env) 761 829 (if (and (nxformtypep num0 'doublefloat env) 762 830 (nxformtypep num1 'doublefloat env)) 763 (nx1form `(%doublefloat/2 ,num0 ,num1))831 (nx1form context `(%doublefloat/2 ,num0 ,num1)) 764 832 (if (and (nxformtypep num0 'shortfloat env) 765 833 (nxformtypep num1 'shortfloat env)) 766 (nx1form `(%shortfloat/2 ,num0 ,num1))767 (makeacode (%nx1operator div2) (nx1form num0) (nx1formnum1)))))768 769 770 771 (defnx1 nx1numcmp ((<2) (>2) (<=2) (>=2)) (&environment env num1 num2)834 (nx1form context `(%shortfloat/2 ,num0 ,num1)) 835 (makeacode (%nx1operator div2) (nx1form :value num0) (nx1form :value num1))))) 836 837 838 839 (defnx1 nx1numcmp ((<2) (>2) (<=2) (>=2)) context (&environment env num1 num2) 772 840 (let* ((op *nxsfname*) 773 841 (bothfixnums (nxbinaryfixnumopp num1 num2 env t)) … … 804 872 :LE 805 873 :GT)))) 806 (nx1form num1)807 (nx1form num2))874 (nx1form :value num1) 875 (nx1form :value num2)) 808 876 (makeacode (%nx1operator numcmp) 809 877 (makeacode … … 816 884 :LE 817 885 :GT)))) 818 (nx1form num1)819 (nx1form num2)))))820 821 (defnx1 nx1num= ((=2) (/=2)) (&environment env num1 num2 )886 (nx1form :value num1) 887 (nx1form :value num2))))) 888 889 (defnx1 nx1num= ((=2) (/=2)) context (&environment env num1 num2 ) 822 890 (let* ((op *nxsfname*) 823 891 (2fixnums (nxbinaryfixnumopp num1 num2 env t)) … … 844 912 :EQ 845 913 :NE)) 846 (nx1form num1)847 (nx1form num2))914 (nx1form :value num1) 915 (nx1form :value num2)) 848 916 (if 2rats 849 917 (let* ((form `(,(if 2fixnums 'eq 'eql) ,num1 ,num2))) 850 (nx1form (if (eq op '=2) form `(not ,form))))918 (nx1form context (if (eq op '=2) form `(not ,form)))) 851 919 (if (or 2dfloats 2sfloats) 852 920 (makeacode … … 859 927 :EQ 860 928 :NE)) 861 (nx1form num1)862 (nx1form num2))929 (nx1form :value num1) 930 (nx1form :value num2)) 863 931 (makeacode (%nx1operator numcmp) 864 932 (makeacode … … 867 935 :EQ 868 936 :NE)) 869 (nx1form num1)870 (nx1form num2)))))))937 (nx1form :value num1) 938 (nx1form :value num2))))))) 871 939 872 940 873 (defnx1 nx1uvset ((uvset) (%miscset)) (vector index value)941 (defnx1 nx1uvset ((uvset) (%miscset)) context (vector index value) 874 942 (makeacode (%nx1operator uvset) 875 (nx1form vector)876 (nx1form index)877 (nx1form value)))878 879 (defnx1 nx1setschar ((setschar)) (s i v)880 (makeacode (%nx1operator %setsbchar) (nx1form s) (nx1form i) (nx1formv)))881 882 883 884 (defnx1 nx1%setschar ((%setschar)) (arg idx char &environment env)943 (nx1form :value vector) 944 (nx1form :value index) 945 (nx1form :value value))) 946 947 (defnx1 nx1setschar ((setschar)) context (s i v) 948 (makeacode (%nx1operator %setsbchar) (nx1form :value s) (nx1form :value i) (nx1form :value v))) 949 950 951 952 (defnx1 nx1%setschar ((%setschar)) context (arg idx char &environment env) 885 953 (let* ((arg (nxtransform arg env)) 886 954 (idx (nxtransform idx env)) … … 889 957 (idxvar (makesymbol "IDX")) 890 958 (charvar (makesymbol "CHAR"))) 891 (nx1form `(let* ((,argvar ,arg) 959 (nx1form context 960 `(let* ((,argvar ,arg) 892 961 (,idxvar ,idx) 893 962 (,charvar ,char)) 894 895 896 963 (declare (optimize (speed 3) (safety 0))) 964 (declare (simplebasestring ,argvar)) 965 (setf (schar ,argvar ,idxvar) ,charvar)) 897 966 env))) 898 967 899 (defnx1 nx1%setscharcode ((%setscharcode)) (s i v)968 (defnx1 nx1%setscharcode ((%setscharcode)) context (s i v) 900 969 (makeacode (%nx1operator %setscharcode) 901 (nx1form s)902 (nx1form i)903 (nx1form v)))970 (nx1form :value s) 971 (nx1form :value i) 972 (nx1form :value v))) 904 973 905 974 906 (defnx1 nx1listvectorvalues ((list) (vector) (values) (%templist)) (&rest args)907 (makeacode (%nx1defaultoperator) (nx1formlist args)))908 909 910 911 (defnx1 nx1%gvector ( (%gvector)) (&rest args)975 (defnx1 nx1listvectorvalues ((list) (vector) (values) (%templist)) context (&rest args) 976 (makeacode (%nx1defaultoperator) (nx1formlist context args))) 977 978 979 980 (defnx1 nx1%gvector ( (%gvector)) context (&rest args) 912 981 (makeacode (%nx1operator %gvector) (nx1arglist args))) 913 982 914 (defnx1 nx1quote quote (form)915 (nx1immediate form))916 917 (defnx1 nx1list* ((list*)) (first &rest rest)983 (defnx1 nx1quote quote context (form) 984 (nx1immediate context form)) 985 986 (defnx1 nx1list* ((list*)) context (first &rest rest) 918 987 (makeacode (%nx1operator list*) (nx1arglist (cons first rest) 1))) 919 988 920 989 921 990 # 922 (defnx1 nx1append ((append)) (&rest args)991 (defnx1 nx1append ((append)) context (&rest args) 923 992 (makeacode (%nx1operator append) (nx1arglist args 2))) 924 993 … … 926 995 # 927 996 928 (defnx1 nx1or or (&whole whole &optional (firstform nil firstformp) &rest moreforms)997 (defnx1 nx1or or context (&whole whole &optional (firstform nil firstformp) &rest moreforms) 929 998 (if (not firstformp) 930 (nx1form nil)999 (nx1form context nil) 931 1000 (if (null moreforms) 932 (nx1form firstform)1001 (nx1form context firstform) 933 1002 (progn 934 (makeacode (%nx1operator or) (nx1formlist (%cdr whole)))))))935 936 (defun nx11dvref ( env arr dim0 &optional uvrefp)1003 (makeacode (%nx1operator or) (nx1formlist context (%cdr whole))))))) 1004 1005 (defun nx11dvref (context env arr dim0 &optional uvrefp) 937 1006 (let* ((simplevectorp (nxformtypep arr 'simplevector env)) 938 1007 (stringp (unless simplevectorp 939 1008 (if (nxformtypep arr 'string env) 940 1009 (or (nxformtypep arr 'simplestring env) 941 (returnfrom nx11dvref (nx1form `(char ,arr ,dim0)))))))1010 (returnfrom nx11dvref (nx1form context `(char ,arr ,dim0))))))) 942 1011 (simple1darrayp (unless (or simplevectorp stringp) 943 1012 (nxformtypep arr '(simplearray * (*)) env))) … … 950 1019 (if (and simple1darrayp typekeyword) 951 1020 (makeacode (%nx1operator %typeduvref) 952 (nx1immediate typekeyword)953 (nx1form arr)954 (nx1form dim0))1021 (nx1immediate :value typekeyword) 1022 (nx1form :value arr) 1023 (nx1form :value dim0)) 955 1024 (let* ((op (cond (simple1darrayp (%nx1operator uvref)) 956 1025 (stringp (%nx1operator %sbchar)) … … 959 1028 (uvrefp (%nx1operator uvref)) 960 1029 (t (%nx1operator %aref1))))) 961 (makeacode op (nx1form arr) (nx1formdim0))))))1030 (makeacode op (nx1form :value arr) (nx1form :value dim0)))))) 962 1031 963 (defnx1 nx1aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0p)1032 (defnx1 nx1aref ((aref)) context (&whole whole &environment env arr &optional (dim0 nil dim0p) 964 1033 &rest otherdims) 965 1034 (if (and dim0p (null otherdims)) 966 (nx11dvref env arr dim0)967 (nx1treatascall whole)))968 969 (defnx1 nx1uvref ((uvref)) (&environment env arr dim0)970 (nx11dvref env arr dim0 t))971 972 (defnx1 nx1%aref2 ((%aref2)) (&whole whole &environment env arr i j)1035 (nx11dvref context env arr dim0) 1036 (nx1treatascall context whole))) 1037 1038 (defnx1 nx1uvref ((uvref)) context (&environment env arr dim0) 1039 (nx11dvref context env arr dim0 t)) 1040 1041 (defnx1 nx1%aref2 ((%aref2)) context (&whole whole &environment env arr i j) 973 1042 ;; Bleah. Breaks modularity. Specialize later. 974 1043 (targetarchcase 975 1044 (:x8632 976 (returnfrom nx1%aref2 (nx1treatascall whole))))1045 (returnfrom nx1%aref2 (nx1treatascall context whole)))) 977 1046 978 1047 (let* ((arch (backendtargetarch *targetbackend*)) … … 991 1060 (dim1 (cadr dims))) 992 1061 (makeacode (%nx1operator simpletypedaref2) 993 (nx1form typekeyword)994 (nx1form arr)995 (nx1form i)996 (nx1form j)997 (nx1form (if (typep dim0 'fixnum) dim0))998 (nx1form (if (typep dim1 'fixnum) dim1))))1062 (nx1form :value typekeyword) 1063 (nx1form :value arr) 1064 (nx1form :value i) 1065 (nx1form :value j) 1066 (nx1form :value (if (typep dim0 'fixnum) dim0)) 1067 (nx1form :value (if (typep dim1 'fixnum) dim1)))) 999 1068 (makeacode (%nx1operator generalaref2) 1000 (nx1form arr)1001 (nx1form i)1002 (nx1form j)))))1003 1004 (defnx1 nx1%aref3 ((%aref3)) (&whole whole &environment env arr i j k)1069 (nx1form :value arr) 1070 (nx1form :value i) 1071 (nx1form :value j))))) 1072 1073 (defnx1 nx1%aref3 ((%aref3)) context (&whole whole &environment env arr i j k) 1005 1074 ;; Bleah. Breaks modularity. Specialize later. 1006 1075 (targetarchcase 1007 1076 (:x8632 1008 (returnfrom nx1%aref3 (nx1treatascall whole))))1077 (returnfrom nx1%aref3 (nx1treatascall context whole)))) 1009 1078 1010 1079 (let* ((arch (backendtargetarch *targetbackend*)) … … 1024 1093 (dim2 (caddr dims))) 1025 1094 (makeacode (%nx1operator simpletypedaref3) 1026 (nx1form typekeyword)1027 (nx1form arr)1028 (nx1form i)1029 (nx1form j)1030 (nx1form k)1031 (nx1form (if (typep dim0 'fixnum) dim0))1032 (nx1form (if (typep dim1 'fixnum) dim1))1033 (nx1form (if (typep dim2 'fixnum) dim2))))1095 (nx1form :value typekeyword) 1096 (nx1form :value arr) 1097 (nx1form :value i) 1098 (nx1form :value j) 1099 (nx1form :value k) 1100 (nx1form :value (if (typep dim0 'fixnum) dim0)) 1101 (nx1form :value (if (typep dim1 'fixnum) dim1)) 1102 (nx1form :value (if (typep dim2 'fixnum) dim2)))) 1034 1103 (makeacode (%nx1operator generalaref3) 1035 (nx1form arr)1036 (nx1form i)1037 (nx1form j)1038 (nx1form k)))))1039 1040 (defun nx11dvset ( arr newval dim0 env)1104 (nx1form :value arr) 1105 (nx1form :value i) 1106 (nx1form :value j) 1107 (nx1form :value k))))) 1108 1109 (defun nx11dvset (context arr newval dim0 env) 1041 1110 (let* ((simplevectorp (nxformtypep arr 'simplevector env)) 1042 1111 (stringp (unless simplevectorp 1043 1112 (if (nxformtypep arr 'string env) 1044 1113 (or (nxformtypep arr 'simplestring env) 1045 (returnfrom nx11dvset (nx1form `(setchar ,arr ,newval ,dim0)))))))1114 (returnfrom nx11dvset (nx1form context `(setchar ,arr ,newval ,dim0))))))) 1046 1115 (simple1darrayp (unless (or simplevectorp stringp) 1047 1116 (nxformtypep arr '(simplearray * (*)) env))) … … 1053 1122 (if (and typekeyword simple1darrayp) 1054 1123 (makeacode (%nx1operator %typeduvset) 1055 (nx1immediate typekeyword)1056 (nx1form arr)1057 (nx1form newval)1058 (nx1form dim0))1124 (nx1immediate :value typekeyword) 1125 (nx1form :value arr) 1126 (nx1form :value newval) 1127 (nx1form :value dim0)) 1059 1128 (let* ((op (cond (simple1darrayp (%nx1operator uvset)) 1060 1129 (stringp (%nx1operator %setsbchar)) … … 1064 1133 (makeacode 1065 1134 op 1066 (nx1form arr)1067 (nx1form newval)1068 (nx1form dim0))1069 (nx1form `(,(if stringp 'setschar '%aset1) ,arr ,newval ,dim0)))))))1070 1071 (defnx1 nx1aset ((aset)) (&whole whole1135 (nx1form :value arr) 1136 (nx1form :value newval) 1137 (nx1form :value dim0)) 1138 (nx1form context `(,(if stringp 'setschar '%aset1) ,arr ,newval ,dim0))))))) 1139 1140 (defnx1 nx1aset ((aset)) context (&whole whole 1072 1141 arr newval 1073 1142 &optional (dim0 nil dim0p) … … 1075 1144 &rest otherdims) 1076 1145 (if (and dim0p (null otherdims)) 1077 (nx11dvset arr newval dim0 env)1078 (nx1treatascall whole)))1146 (nx11dvset context arr newval dim0 env) 1147 (nx1treatascall context whole))) 1079 1148 1080 (defnx1 nx1%aset2 ((%aset2)) (&whole whole &environment env arr i j new)1149 (defnx1 nx1%aset2 ((%aset2)) context (&whole whole &environment env arr i j new) 1081 1150 ;; Bleah. Breaks modularity. Specialize later. 1082 1151 (targetarchcase 1083 1152 (:x8632 1084 (returnfrom nx1%aset2 (nx1treatascall whole))))1153 (returnfrom nx1%aset2 (nx1treatascall context whole)))) 1085 1154 1086 1155 (let* ((arch (backendtargetarch *targetbackend*)) … … 1100 1169 (dim1 (cadr dims))) 1101 1170 (makeacode (%nx1operator simpletypedaset2) 1102 (nx1form typekeyword)1103 (nx1form arr)1104 (nx1form i)1105 (nx1form j)1106 (nx1form new)1107 (nx1form (if (typep dim0 'fixnum) dim0))1108 (nx1form (if (typep dim1 'fixnum) dim1))))1171 (nx1form :value typekeyword) 1172 (nx1form :value arr) 1173 (nx1form :value i) 1174 (nx1form :value j) 1175 (nx1form :value new) 1176 (nx1form :value (if (typep dim0 'fixnum) dim0)) 1177 (nx1form :value (if (typep dim1 'fixnum) dim1)))) 1109 1178 (makeacode (%nx1operator generalaset2) 1110 (nx1form arr)1111 (nx1form i)1112 (nx1form j)1113 (nx1form new)))))1114 1115 (defnx1 nx1%aset3 ((%aset3)) (&whole whole &environment env arr i j k new)1179 (nx1form :value arr) 1180 (nx1form :value i) 1181 (nx1form :value j) 1182 (nx1form :value new))))) 1183 1184 (defnx1 nx1%aset3 ((%aset3)) context (&whole whole &environment env arr i j k new) 1116 1185 ;; Bleah. Breaks modularity. Specialize later. 1117 1186 (targetarchcase 1118 1187 (:x8632 1119 (returnfrom nx1%aset3 (nx1treatascall whole))))1188 (returnfrom nx1%aset3 (nx1treatascall context whole)))) 1120 1189 1121 1190 (let* ((arch (backendtargetarch *targetbackend*)) … … 1136 1205 (dim2 (caddr dims))) 1137 1206 (makeacode (%nx1operator simpletypedaset3) 1138 (nx1form typekeyword)1139 (nx1form arr)1140 (nx1form i)1141 (nx1form j)1142 (nx1form k)1143 (nx1form new)1144 (nx1form (if (typep dim0 'fixnum) dim0))1145 (nx1form (if (typep dim1 'fixnum) dim1))1146 (nx1form (if (typep dim2 'fixnum) dim2))))1207 (nx1form :value typekeyword) 1208 (nx1form :value arr) 1209 (nx1form :value i) 1210 (nx1form :value j) 1211 (nx1form :value k) 1212 (nx1form :value new) 1213 (nx1form :value (if (typep dim0 'fixnum) dim0)) 1214 (nx1form :value (if (typep dim1 'fixnum) dim1)) 1215 (nx1form :value (if (typep dim2 'fixnum) dim2)))) 1147 1216 (makeacode (%nx1operator generalaset3) 1148 (nx1form arr)1149 (nx1form i)1150 (nx1form j)1151 (nx1form k)1152 (nx1form new)))))1153 1154 (defnx1 nx1prog1 (prog1 multiplevalueprog1) (save &body args1155 &aux (l (list (nx1formsave))))1156 (makeacode1157 (%nx1defaultoperator)1158 (dolist (arg args (nreverse l))1159 (push (nx1form arg) l))))1160 1161 (defnx1 nx1if if (test true &optional false)1217 (nx1form :value arr) 1218 (nx1form :value i) 1219 (nx1form :value j) 1220 (nx1form :value k) 1221 (nx1form :value new))))) 1222 1223 (defnx1 nx1prog1 (prog1 multiplevalueprog1) context (save &body args) 1224 (let* ((l (list (nx1form :value save)))) 1225 (makeacode 1226 (%nx1defaultoperator) 1227 (dolist (arg args (nreverse l)) 1228 (push (nx1form nil arg) l))))) 1229 1230 (defnx1 nx1if if context (test true &optional false) 1162 1231 (if (null true) 1163 1232 (if (null false) 1164 (returnfrom nx1if (nx1form `(progn ,test nil)))1233 (returnfrom nx1if (nx1form context `(progn ,test nil))) 1165 1234 (psetq test `(not ,test) true false false true))) 1166 (let ((testform (nx1form test))1235 (let ((testform (nx1form :value test)) 1167 1236 ;; Once hit a conditional, no more duplicate warnings 1168 1237 (*compilerwarnonduplicatedefinitions* nil)) 1169 (makeacode (%nx1operator if) testform (nx1form true) (nx1formfalse))))1170 1171 (defnx1 nx1%debugtrap dbg (&optional arg)1172 (makeacode (%nx1operator %debugtrap) (nx1form arg)))1238 (makeacode (%nx1operator if) testform (nx1form context true) (nx1form context false)))) 1239 1240 (defnx1 nx1%debugtrap dbg context (&optional arg) 1241 (makeacode (%nx1operator %debugtrap) (nx1form :value arg))) 1173 1242 1174 (defnx1 nx1setq setq (&whole whole &rest args &environment env &aux res)1243 (defnx1 nx1setq setq context (&whole whole &rest args &environment env &aux res) 1175 1244 (when (%ilogbitp 0 (length args)) 1176 1245 (nxerror "Odd number of forms in ~s ." whole)) … … 1186 1255 (multiplevaluebind (expansion win) (macroexpand1 sym env) 1187 1256 (if win 1188 (push (nx1form `(setf ,expansion ,val)) res)1257 (push (nx1form context `(setf ,expansion ,val)) res) 1189 1258 (multiplevaluebind (info inherited catchp) 1190 1259 (nxlexinfo sym) … … 1197 1266 (%ilsl $vbitreffed 1) 1198 1267 (nxvarbits catchp))) 1199 (nx1form `(setf ,inherited ,val)))1268 (nx1form context `(setf ,inherited ,val))) 1200 1269 (let ((valtype (nxformtype val env))) 1201 1270 (let ((*nxformtype* declaredtype)) 1202 (setq val (nx1typedform val env)))1271 (setq val (nx1typedform context val env))) 1203 1272 (if (and info (neq info :special)) 1204 1273 (progn … … 1256 1325 ;;; in a null lexical environment. 1257 1326 1258 (defnx1 nx1loadtimevalue (loadtimevalue) (&environment env form &optional readonlyp)1327 (defnx1 nx1loadtimevalue (loadtimevalue) context (&environment env form &optional readonlyp) 1259 1328 ;; Validate the "readonlyp" argument 1260 1329 (if (and readonlyp (neq readonlyp t)) (requiretype readonlyp '(member t nil))) … … 1269 1338 :target (backendname *targetbackend*)) 1270 1339 (setq *nxwarnings* (append *nxwarnings* warnings)) 1271 (nx1immediate (list *nxloadtimeevaltoken* `(funcall ,function)))) 1272 (nx1immediate (eval form)))) 1273 1274 (defnx1 nx1catch (catch) (operation &body body) 1275 (makeacode (%nx1operator catch) (nx1form operation) (nx1catchbody body))) 1276 1277 (defnx1 nx1%badarg ((%badarg)) (badthing righttype &environment env) 1278 (makeacode (%nx1operator %badarg2) 1279 (nx1form badthing) 1280 (nx1form (or (if (nxformconstantp righttype env) (%typespecid (nxformconstantvalue righttype env))) 1281 righttype)))) 1282 1283 (defnx1 nx1unwindprotect (unwindprotect) (protectedform &body cleanupform) 1284 (if cleanupform 1285 (makeacode (%nx1operator unwindprotect) 1286 (nx1catchbody (list protectedform)) 1287 (nx1prognbody cleanupform)) 1288 (nx1form protectedform))) 1289 1290 (defnx1 nx1progv progv (symbols values &body body) 1291 (makeacode (%nx1operator progv) 1292 (nx1form `(checksymbollist ,symbols)) 1293 (nx1form values) 1294 (nx1catchbody body))) 1295 1296 (defun nx1catchbody (body) 1340 (nx1immediate context (list *nxloadtimeevaltoken* `(funcall ,function)))) 1341 (nx1immediate context (eval form)))) 1342 1343 (defun nx1catchbody (context body) 1297 1344 (let* ((temp (newlexicalenvironment *nxlexicalenvironment*))) 1298 1345 (setf (lexenv.variables temp) 'catch) 1299 1346 (let* ((*nxlexicalenvironment* (newlexicalenvironment temp))) 1300 (nx1prognbody body)))) 1301 1302 1303 (defnx1 nx1apply ((apply)) (&whole call fn arg &rest args &environment env) 1304 (let ((last (%car (last (push arg args))))) 1305 (if (and (nxformconstantp last env) 1306 (null (nxformconstantvalue last env))) 1307 (nx1form (let ((new `(funcall ,fn ,@(butlast args)))) 1308 (nxnotesourcetransformation call new) 1309 new)) 1310 (nx1applyfn fn args t)))) 1311 1312 (defnx1 nx1%applylexpr ((%applylexpr)) (fn arg &rest args) 1313 (nx1applyfn fn (cons arg args) 0)) 1314 1315 (defun nx1applyfn (fn args spread) 1347 (nx1prognbody context body)))) 1348 1349 (defnx1 nx1catch (catch) context (operation &body body) 1350 (makeacode (%nx1operator catch) (nx1form :value operation) (nx1catchbody context body))) 1351 1352 (defnx1 nx1%badarg ((%badarg)) context (badthing righttype &environment env) 1353 (makeacode (%nx1operator %badarg2) 1354 (nx1form :value badthing) 1355 (nx1form :value (or (if (nxformconstantp righttype env) (%typespecid (nxformconstantvalue righttype env))) 1356 righttype)))) 1357 1358 (defnx1 nx1unwindprotect (unwindprotect) context (protectedform &body cleanupform) 1359 (if cleanupform 1360 (makeacode (%nx1operator unwindprotect) 1361 (nx1catchbody context (list protectedform)) 1362 (nx1prognbody context cleanupform)) 1363 (nx1form context protectedform))) 1364 1365 (defnx1 nx1progv progv context (symbols values &body body) 1366 (makeacode (%nx1operator progv) 1367 (nx1form :value `(checksymbollist ,symbols)) 1368 (nx1form :value values) 1369 (nx1catchbody context body))) 1370 1371 1372 (defun nx1applyfn (context fn args spread) 1316 1373 (let* ((sym (nx1funcname fn)) 1317 1374 (afunc (and (nonnilsymbolp sym) (nthvalue 1 (nxlexicalfinfo sym))))) … … 1324 1381 sym nil 1325 1382 args (cons (varname *nxnextmethodvar*) args))) 1326 (nx1typedcall (if (nonnilsymbolp sym) sym (nx1form fn)) args spread))) 1327 1328 1329 (defnx1 nx1%defun %defun (&whole w def &optional (doc nil docp) &environment env) 1383 (nx1typedcall context (if (nonnilsymbolp sym) sym (nx1form :value fn)) args spread))) 1384 1385 1386 (defnx1 nx1apply ((apply)) context (&whole call fn arg &rest args &environment env) 1387 (let ((last (%car (last (push arg args))))) 1388 (if (and (nxformconstantp last env) 1389 (null (nxformconstantvalue last env))) 1390 (nx1form context (let ((new `(funcall ,fn ,@(butlast args)))) 1391 (nxnotesourcetransformation call new) 1392 new)) 1393 (nx1applyfn context fn args t)))) 1394 1395 (defnx1 nx1%applylexpr ((%applylexpr)) context (fn arg &rest args) 1396 (nx1applyfn context fn (cons arg args) 0)) 1397 1398 1399 1400 1401 (defnx1 nx1%defun %defun context (&whole w def &optional (doc nil docp) &environment env) 1330 1402 (declare (ignorable doc docp)) 1331 ; Pretty bogus.1403 ;; Pretty bogus. 1332 1404 (if (and (consp def) 1333 1405 (eq (%car def) 'nfunction) … … 1335 1407 (or (symbolp (%cadr def)) (setffunctionnamep (%cadr def)))) 1336 1408 (notefunctioninfo (%cadr def) (caddr def) env)) 1337 (nx1treatascall w))1338 1339 (defnx1 nx1function function (arg &aux fn afunc)1409 (nx1treatascall context w)) 1410 1411 (defnx1 nx1function function context (arg &aux fn afunc) 1340 1412 (cond ((symbolp arg) 1341 1413 (when (macrofunction arg *nxlexicalenvironment*) … … 1349 1421 (when (%ilogbitp $fbitbounddownward (afuncbits afunc)) 1350 1422 (incf (afuncfndownwardrefcount afunc)))) 1351 (nx1symbol (%cddr fn)))1423 (nx1symbol context (%cddr fn))) 1352 1424 (progn 1353 1425 (while (setq fn (assq arg *nxsynonyms*)) 1354 1426 (setq arg (%cdr fn))) 1355 (nx1form `(%function ',arg)))))1427 (nx1form context `(%function ',arg))))) 1356 1428 ((setffunctionnamep arg) 1357 (nx1form `(function ,(nxneedfunctionname arg))))1429 (nx1form context `(function ,(nxneedfunctionname arg)))) 1358 1430 ((lambdaexpressionp arg) 1359 1431 (nx1refinnerfunction nil arg)) … … 1361 1433 (nxerror "~S is not a function name or lambda expression" arg)))) 1362 1434 1363 (defnx1 nx1nfunction nfunction (name def)1435 (defnx1 nx1nfunction nfunction context (name def) 1364 1436 (nx1refinnerfunction name def)) 1365 1437 … … 1396 1468 afunc))))) 1397 1469 1398 (defnx1 nx1%function %function (form &aux symbol)1399 (let ((sym (nx1form form)))1470 (defnx1 nx1%function %function context (form &aux symbol) 1471 (let ((sym (nx1form :value form))) 1400 1472 (if (and (eq (car sym) (%nx1operator immediate)) 1401 1473 (setq symbol (cadr sym)) … … 1407 1479 (nx1whine :undefinedfunction symbol)) 1408 1480 (makeacode (%nx1defaultoperator) symbol)) 1409 (makeacode (%nx1operator call) (nx1immediate '%function) (list nil (list sym))))))1410 1411 (defnx1 nx1tagbody tagbody (&rest args)1481 (makeacode (%nx1operator call) (nx1immediate context '%function) (list nil (list sym)))))) 1482 1483 (defnx1 nx1tagbody tagbody context (&rest args) 1412 1484 (let* ((newtags nil) 1413 1485 (*nxlexicalenvironment* (newlexicalenvironment *nxlexicalenvironment*)) … … 1440 1512 (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t) 1441 1513 (cons (%nx1operator taglabel) info)) 1442 (nx1form form))1514 (nx1form nil form)) 1443 1515 body)) 1444 1516 (if (eq 0 (%car counter)) … … 1451 1523 (when (%cadr tag) 1452 1524 (push 1453 (nx1form `(if (eql ,(varname indexvar) ,(%cadr tag)) (go ,(%car tag))))1525 (nx1form context `(if (eql ,(varname indexvar) ,(%cadr tag)) (go ,(%car tag)))) 1454 1526 body))) 1455 1527 (makeacode … … 1469 1541 (makeacode 1470 1542 (%nx1operator catch) 1471 (nx1form (varname catchvar))1543 (nx1form :value (varname catchvar)) 1472 1544 (makeacode 1473 1545 (%nx1operator localtagbody) … … 1480 1552 1481 1553 1482 (defnx1 nx1go go (tag)1554 (defnx1 nx1go go context (tag) 1483 1555 (multiplevaluebind (info closed) 1484 1556 (nxtaginfo tag) … … 1492 1564 1493 1565 (makeacode 1494 (%nx1operator throw) (nx1symbol (varname (cadddr info))) (nx1formclosed))))))1566 (%nx1operator throw) (nx1symbol :value (varname (cadddr info))) (nx1form :value closed)))))) 1495 1567 1496 1568 … … 1512 1584 :hybridintfloat :hybridfloatint :hybridfloatfloat)) 1513 1585 1514 1515 (defnx1 nx1ffcall ((%ffcall)) (addressexpression &rest argspecsandresultspec) 1516 (nx1ffcallinternal 1517 addressexpression argspecsandresultspec 1518 (ecase (backendname *targetbackend*) 1519 ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1operator eabiffcall)) 1520 ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1operator poweropenffcall)) 1521 ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1operator i386ffcall)) 1522 ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1operator ffcall))))) 1523 1524 (defnx1 nx1syscall ((%syscall)) (idx &rest argspecsandresultspec) 1525 (flet ((maptorepresentationtypes (list) 1526 (collect ((out)) 1527 (do* ((l list (cddr l))) 1528 ((null (cdr l)) 1529 (if l 1530 (progn 1531 (out (foreigntypetorepresentationtype (car l))) 1532 (out)) 1533 (error "Missing result type in ~s" list))) 1534 (out (foreigntypetorepresentationtype (car l))) 1535 (out (cadr l)))))) 1536 (nx1ffcallinternal 1537 idx (maptorepresentationtypes argspecsandresultspec) 1538 (ecase (backendname *targetbackend*) 1539 (:linuxppc32 (%nx1operator eabisyscall)) 1540 ((:darwinppc32 :darwinppc64 :linuxppc64) 1541 (%nx1operator poweropensyscall)) 1542 ((:darwinx8632 :linuxx632 :win32) (%nx1operator i386syscall)) 1543 ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1operator syscall)))))) 1544 1545 (defun nx1ffcallinternal (addressexpression argspecsandresultspec operator ) 1586 (defun nx1ffcallinternal (context addressexpression argspecsandresultspec operator ) 1587 (declare (ignorable context)) 1546 1588 (let* ((specs ()) 1547 1589 (vals ()) … … 1586 1628 (t t)) 1587 1629 (makeacode operator 1588 (nx1form addressexpression)1630 (nx1form :value addressexpression) 1589 1631 (nreverse specs) 1590 (mapcar #'nx1form(nreverse vals))1632 (mapcar (lambda (val) (nx1form :value val)) (nreverse vals)) 1591 1633 resultspec 1592 1634 nil) 1593 1635 nil))) 1636 1637 (defnx1 nx1ffcall ((%ffcall)) context (addressexpression &rest argspecsandresultspec) 1638 (nx1ffcallinternal 1639 context addressexpression argspecsandresultspec 1640 (ecase (backendname *targetbackend*) 1641 ((:linuxppc32 :linuxarm :darwinarm :androidarm) (%nx1operator eabiffcall)) 1642 ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1operator poweropenffcall)) 1643 ((:darwinx8632 :linuxx8632 :win32 :solarisx8632 :freebsdx8632) (%nx1operator i386ffcall)) 1644 ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1operator ffcall))))) 1645 1646 (defnx1 nx1syscall ((%syscall)) context (idx &rest argspecsandresultspec) 1647 (flet ((maptorepresentationtypes (list) 1648 (collect ((out)) 1649 (do* ((l list (cddr l))) 1650 ((null (cdr l)) 1651 (if l 1652 (progn 1653 (out (foreigntypetorepresentationtype (car l))) 1654 (out)) 1655 (error "Missing result type in ~s" list))) 1656 (out (foreigntypetorepresentationtype (car l))) 1657 (out (cadr l)))))) 1658 (nx1ffcallinternal 1659 context 1660 idx (maptorepresentationtypes argspecsandresultspec) 1661 (ecase (backendname *targetbackend*) 1662 (:linuxppc32 (%nx1operator eabisyscall)) 1663 ((:darwinppc32 :darwinppc64 :linuxppc64) 1664 (%nx1operator poweropensyscall)) 1665 ((:darwinx8632 :linuxx632 :win32) (%nx1operator i386syscall)) 1666 ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 :win64) (%nx1operator syscall)))))) 1667 1668 1594 1669 1595 (defnx1 nx1block block (blockname &body forms)1670 (defnx1 nx1block block context (blockname &body forms) 1596 1671 (let* ((*nxblocks* *nxblocks*) 1597 1672 (*nxlexicalenvironment* (newlexicalenvironment *nxlexicalenvironment*)) 1598 1673 (*nxboundvars* *nxboundvars*) 1599 1674 (tagvar (nxnewtempvar (makependingdeclarations))) 1600 (thisblock (cons (setq blockname (nxneedsym blockname)) tagvar))1675 (thisblock (cons (setq blockname (nxneedsym blockname)) (cons tagvar context))) 1601 1676 (body nil)) 1602 1677 (push thisblock *nxblocks*) 1603 (setq body (nx1prognbody forms))1678 (setq body (nx1prognbody context forms)) 1604 1679 (%rplacd thisblock nil) 1605 1680 (let ((tagbits (nxvarbits tagvar))) … … 1620 1695 (%nx1operator let) 1621 1696 (list tagvar) 1622 (list (makeacode (%nx1operator cons) (nx1form nil) (nx1formnil)))1697 (list (makeacode (%nx1operator cons) (nx1form :value nil) (nx1form :value nil))) 1623 1698 (makeacode 1624 1699 (%nx1operator catch) … … 1627 1702 0))))))) 1628 1703 1629 (defnx1 nx1returnfrom returnfrom (blockname &optional value)1704 (defnx1 nx1returnfrom returnfrom context (blockname &optional value) 1630 1705 (multiplevaluebind (info closed) 1631 1706 (nxblockinfo (setq blockname (nxneedsym blockname))) 1632 1707 (unless info (nxerror "Can't RETURNFROM block : ~S." blockname)) 1633 (unless closed (nxadjustrefcount (cdr info))) 1634 (makeacode 1635 (if closed 1636 (%nx1operator throw) 1637 (%nx1operator localreturnfrom)) 1638 (if closed 1639 (nx1symbol (varname (cdr info))) 1640 info) 1641 (nx1form value)))) 1642 1643 (defnx1 nx1funcall ((funcall)) (&whole call func &rest args &environment env) 1708 (destructuringbind (var . blockcontext) (cdr info) 1709 (unless closed (nxadjustrefcount var)) 1710 (makeacode 1711 (if closed 1712 (%nx1operator throw) 1713 (%nx1operator localreturnfrom)) 1714 (if closed 1715 (nx1symbol context (varname var )) 1716 info) 1717 (nx1form (if closed :value blockcontext) value))))) 1718 1719 (defnx1 nx1funcall ((funcall)) context (&whole call func &rest args &environment env) 1644 1720 (let ((name (nx1funcname func))) 1645 1721 (if (or (null name) 1646 1722 (and (symbolp name) (macrofunction name env))) 1647 (nx1typedcall (nx1formfunc) args nil)1723 (nx1typedcall context (nx1form :value func) args nil) 1648 1724 (progn 1649 1725 (when (consp name) ;; lambda expression 1650 1726 (nxnotesourcetransformation func name)) 1651 1727 ;; This picks up callnextmethod evil. 1652 (nx1form (let ((newform (cons name args)))1653 1654 1655 1656 (defnx1 nx1multiplevaluecall multiplevaluecall (valueform &rest args)1728 (nx1form context (let ((newform (cons name args))) 1729 (nxnotesourcetransformation call newform) 1730 newform)))))) 1731 1732 (defnx1 nx1multiplevaluecall multiplevaluecall context (valueform &rest args) 1657 1733 (makeacode (%nx1defaultoperator) 1658 (nx1form valueform)1659 (nx1formlist args)))1660 1661 (defnx1 nx1compilerlet compilerlet (bindings &body forms)1734 (nx1form :value valueform) 1735 (nx1formlist context args))) 1736 1737 (defnx1 nx1compilerlet compilerlet context (bindings &body forms) 1662 1738 (let* ((vars nil) 1663 1739 (varinits nil)) … … 1665 1741 (push (nxpairname pair) vars) 1666 1742 (push (eval (nxpairinitform pair)) varinits)) 1667 (progv (nreverse vars) (nreverse varinits) (nx1catchbody forms))))1668 1669 (defnx1 nx1fbind fbind (fnspecs &body body &environment oldenv)1743 (progv (nreverse vars) (nreverse varinits) (nx1catchbody context forms)))) 1744 1745 (defnx1 nx1fbind fbind context (fnspecs &body body &environment oldenv) 1670 1746 (let* ((fnames nil) 1671 1747 (vars nil) … … 1674 1750 (destructuringbind (fname initform) spec 1675 1751 (push (setq fname (nxneedfunctionname fname)) fnames) 1676 (push (nx1form initform) vals)))1752 (push (nx1form :value initform) vals))) 1677 1753 (let* ((newenv (newlexicalenvironment oldenv)) 1678 1754 (*nxboundvars* *nxboundvars*) … … 1692 1768 vars 1693 1769 vals 1694 (nx1envbody body oldenv)1770 (nx1envbody context body oldenv) 1695 1771 *nxnewp2decls*)))) 1696 1772 … … 1700 1776 (nx1whine :specialfbinding funcname))) 1701 1777 1702 (defnx1 nx1flet flet (defs &body forms)1778 (defnx1 nx1flet flet context (defs &body forms) 1703 1779 (withnxdeclarations (pending) 1704 1780 (let* ((env *nxlexicalenvironment*) … … 1744 1820 (setq body (let* ((*nxlexicalenvironment* newenv)) 1745 1821 (nx1dynamicextentfunctions vars newenv) 1746 (nx1envbody body env)))1822 (nx1envbody context body env))) 1747 1823 (dolist (pair pairs) 1748 1824 (let ((afunc (cdr pair)) … … 1784 1860 (nxsetvarbits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nxvarbits varinfo)))))))))) 1785 1861 1786 (defnx1 nx1labels labels (defs &body forms)1862 (defnx1 nx1labels labels context (defs &body forms) 1787 1863 (withnxdeclarations (pending) 1788 1864 (let* ((env *nxlexicalenvironment*) … … 1827 1903 (nxprocessdeclarations pending decls) 1828 1904 (nxeffectotherdecls pending env) 1829 (setq body (nx1envbody body oldenv))1905 (setq body (nx1envbody context body oldenv)) 1830 1906 (nxreconcileinheritedvars funcrefs) 1831 1907 (dolist (f funcrefs) (nx1afuncref f)) … … 1839 1915 1840 1916 1841 (defnx1 nx1setbit ((%setbit)) (ptr offset &optional (newval nil newvalp))1917 (defnx1 nx1setbit ((%setbit)) context (ptr offset &optional (newval nil newvalp)) 1842 1918 (unless newvalp (setq newval offset offset 0)) 1843 1919 (makeacode 1844 1920 (%nx1operator %setbit) 1845 (makeacode (%nx1operator %macptrptr%) (nx1form ptr))1846 (nx1form offset)1847 (nx1form newval)))1921 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptr)) 1922 (nx1form :value offset) 1923 (nx1form :value newval))) 1848 1924 1849 1925 (defnx1 nx1setxxx ((%setptr) (%setlong) (%setword) (%setbyte) 1850 (%setunsignedlong) (%setunsignedword) (%setunsignedbyte)) 1926 (%setunsignedlong) (%setunsignedword) (%setunsignedbyte)) context 1851 1927 (ptr offset &optional (newval nil newvalp) &aux (op *nxsfname*)) 1852 1928 (unless newvalp (setq newval offset offset 0)) … … 1861 1937 (%setunsignedlong (logior 32 4)) 1862 1938 (t 4)) 1863 (makeacode (%nx1operator %macptrptr%) (nx1form ptr))1864 (nx1form offset)1865 (nx1form newval)))1866 1867 (defnx1 nx1set64xxx ((%%setunsignedlonglong) (%%setsignedlonglong)) 1939 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptr)) 1940 (nx1form :value offset) 1941 (nx1form :value newval))) 1942 1943 (defnx1 nx1set64xxx ((%%setunsignedlonglong) (%%setsignedlonglong)) context 1868 1944 (&whole w ptr offset newval &aux (op *nxsfname*)) 1869 1945 (targetwordsizecase 1870 (32 (nx1treatascall w))1946 (32 (nx1treatascall context w)) 1871 1947 (64 1872 1948 (makeacode … … 1875 1951 (%%setsignedlonglong 8) 1876 1952 (t (logior 32 8))) 1877 (makeacode (%nx1operator %macptrptr%) (nx1form ptr))1878 (nx1form offset)1879 (nx1form newval)))))1880 1881 1882 (defnx1 nx1getbit ((%getbit)) (ptrform &optional (offset 0))1953 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptr)) 1954 (nx1form :value offset) 1955 (nx1form :value newval))))) 1956 1957 1958 (defnx1 nx1getbit ((%getbit)) context (ptrform &optional (offset 0)) 1883 1959 (makeacode 1884 1960 (%nx1operator typedform) … … 1886 1962 (makeacode 1887 1963 (%nx1operator %getbit) 1888 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1889 (nx1form offset))))1890 1891 (defnx1 nx1get64xxx ((%%getunsignedlonglong) (%%getsignedlonglong)) 1964 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 1965 (nx1form :value offset)))) 1966 1967 (defnx1 nx1get64xxx ((%%getunsignedlonglong) (%%getsignedlonglong)) context 1892 1968 (&whole w ptrform offsetform) 1893 1969 (targetwordsizecase 1894 (32 (nx1treatascall w))1970 (32 (nx1treatascall context w)) 1895 1971 (64 1896 1972 (let* ((flagbits (case *nxsfname* … … 1905 1981 (%nx1operator immediategetxxx) 1906 1982 flagbits 1907 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1908 (nx1form offsetform)))))))1983 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 1984 (nx1form :value offsetform))))))) 1909 1985 1910 1986 (defnx1 nx1getxxx ((%getlong) (%getfulllong) (%getsignedlong) … … 1914 1990 (%getsignedword) 1915 1991 (%getsignedbyte) 1916 (%getunsignedlong)) 1992 (%getunsignedlong)) context 1917 1993 (ptrform &optional (offset 0)) 1918 1994 (let* ((sfname *nxsfname*) … … 1944 2020 (%nx1operator immediategetxxx) 1945 2021 flagbits 1946 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1947 (nx1form offset)))))1948 1949 (defnx1 nx1%getptr ((%getptr) ) (ptrform &optional (offset 0))2022 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 2023 (nx1form :value offset))))) 2024 2025 (defnx1 nx1%getptr ((%getptr) ) context (ptrform &optional (offset 0)) 1950 2026 (makeacode 1951 2027 (%nx1operator %consmacptr%) 1952 2028 (makeacode 1953 2029 (%nx1operator immediategetptr) 1954 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1955 (nx1form offset))))2030 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 2031 (nx1form :value offset)))) 1956 2032 1957 2033 (defnx1 nx1%getfloat ((%getsinglefloat) 1958 (%getdoublefloat)) (ptrform &optional (offset 0))2034 (%getdoublefloat)) context (ptrform &optional (offset 0)) 1959 2035 (makeacode 1960 2036 (%nx1operator typedform) … … 1964 2040 (makeacode 1965 2041 (%nx1defaultoperator) 1966 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1967 (nx1form offset))))2042 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 2043 (nx1form :value offset)))) 1968 2044 1969 2045 (defnx1 nx1%setfloat ((%setsinglefloat) 1970 (%setdoublefloat)) (ptrform offset &optional (newval nil newvalp))2046 (%setdoublefloat)) context (ptrform offset &optional (newval nil newvalp)) 1971 2047 (unless newvalp 1972 2048 (setq newval offset … … 1979 2055 (makeacode 1980 2056 (%nx1defaultoperator) 1981 (makeacode (%nx1operator %macptrptr%) (nx1form ptrform))1982 (nx1form offset)1983 (nx1form newval))))1984 1985 (defnx1 nx1let let (pairs &body forms &environment oldenv)2057 (makeacode (%nx1operator %macptrptr%) (nx1form :value ptrform)) 2058 (nx1form :value offset) 2059 (nx1form :value newval)))) 2060 2061 (defnx1 nx1let let context (pairs &body forms &environment oldenv) 1986 2062 (collect ((vars) 1987 2063 (vals) … … 2014 2090 (progn 2015 2091 (nxeffectotherdecls pending *nxlexicalenvironment*) 2016 (nx1envbody body oldenv))2092 (nx1envbody context body oldenv)) 2017 2093 *nxnewp2decls*))) 2018 2094 (nx1checkvarbindings varbindings) … … 2023 2099 2024 2100 ;((lambda (lambdalist) . body) . args) 2025 (defun nx1lambdabind ( lambdalist args body &optional (bodyenvironment *nxlexicalenvironment*))2101 (defun nx1lambdabind (context lambdalist args body &optional (bodyenvironment *nxlexicalenvironment*)) 2026 2102 (let* ((oldenv bodyenvironment) 2027 2103 (argenv *nxlexicalenvironment*) … … 2033 2109 (declare (ignore req opttail)) 2034 2110 (when (and ok (eq (%car resttail) '&lexpr)) 2035 (returnfrom nx1lambdabind (nx1call (nx1form`(lambda ,lambdalist ,@body)) args))))2111 (returnfrom nx1lambdabind (nx1call context (nx1form context `(lambda ,lambdalist ,@body)) args)))) 2036 2112 (let* ((*nxlexicalenvironment* bodyenvironment) 2037 2113 (*nxboundvars* *nxboundvars*)) … … 2042 2118 (nxparsesimplelambdalist pending lambdalist) 2043 2119 (let* ((*nxlexicalenvironment* argenv)) 2044 (setq arglist (nx1formlist args)))2120 (setq arglist (nx1formlist context args))) 2045 2121 (nxeffectotherdecls pending *nxlexicalenvironment*) 2046 (setq body (nx1envbody body oldenv))2122 (setq body (nx1envbody context body oldenv)) 2047 2123 (while req 2048 2124 (when (null arglist) … … 2152 2228 2153 2229 2154 (defnx1 nx1lapfunction (ppclapfunction) (name bindings &body body)2230 (defnx1 nx1lapfunction (ppclapfunction) context (name bindings &body body) 2155 2231 (declare (ftype (function (t t t)) %defineppclapfunction)) 2156 2232 (require "PPCLAP" "ccl:compiler;ppc;ppclap") … … 2159 2235 (dpb (length bindings) $lfbitsnumreq 0)))) 2160 2236 2161 (defnx1 nx1x86lapfunction (x86lapfunction) (name bindings &body body)2237 (defnx1 nx1x86lapfunction (x86lapfunction) context (name bindings &body body) 2162 2238 (declare (ftype (function (t t t)) %definex86lapfunction)) 2163 2239 (require "X86LAP") … … 2166 2242 (dpb (length bindings) $lfbitsnumreq 0)))) 2167 2243 2168 (defnx1 nx1armlapfunction (armlapfunction) (name bindings &body body)2244 (defnx1 nx1armlapfunction (armlapfunction) context (name bindings &body body) 2169 2245 (declare (ftype (function (t t t)) %definearmlapfunction)) 2170 2246 (require "ARMLAP") … … 2177 2253 2178 2254 2179 (defun nx1envbody ( body oldenv &optional (typecheck (nxdeclarationstypecheck *nxlexicalenvironment*)))2180 (do* ((form (nx1prognbody body))2255 (defun nx1envbody (context body oldenv &optional (typecheck (nxdeclarationstypecheck *nxlexicalenvironment*))) 2256 (do* ((form (nx1prognbody context body)) 2181 2257 (typechecks nil) 2182 2258 (env *nxlexicalenvironment* (lexenv.parentenv env))) … … 2198 2274 (unless (eq type t) 2199 2275 (let ((oldbits (nxvarbits var))) 2200 (push (nx1form `(the ,type ,sym)) typechecks)2276 (push (nx1form :value `(the ,type ,sym)) typechecks) 2201 2277 (when (%izerop (logior 2202 2278 (%ilogand2 oldbits … … 2210 2286 2211 2287 2212 (defnx1 nx1let* (let*) (varspecs &body forms)2288 (defnx1 nx1let* (let*) context (varspecs &body forms) 2213 2289 (let* ((vars nil) 2214 2290 (vals nil) … … 2235 2311 (setq vars (nreverse vars)) 2236 2312 (setq vals (nreverse vals)) 2237 (nx1envbody body oldenv)2313 (nx1envbody context body oldenv) 2238 2314 *nxnewp2decls*))) 2239 2315 (nx1checkvarbindings varboundvars) … … 2241 2317 result))))) 2242 2318 2243 (defnx1 nx1multiplevaluebind multiplevaluebind 2319 (defnx1 nx1multiplevaluebind multiplevaluebind context 2244 2320 (varspecs bindform &body forms) 2245 2321 (if (= (length varspecs) 1) 2246 (nx1form `(let* ((,(car varspecs) ,bindform)) ,@forms))2322 (nx1form context `(let* ((,(car varspecs) ,bindform)) ,@forms)) 2247 2323 (let* ((vars nil) 2248 2324 (*nxboundvars* *nxboundvars*) 2249 2325 (oldenv *nxlexicalenvironment*) 2250 (mvform (nx1form bindform)))2326 (mvform (nx1form :value bindform))) 2251 2327 (withnxdeclarations (pending) 2252 2328 (multiplevaluebind (body decls) … … 2260 2336 (nreverse vars) 2261 2337 mvform 2262 (nx1envbody body oldenv)2338 (nx1envbody context body oldenv) 2263 2339 *nxnewp2decls*)))))) 2264 2340 … … 2266 2342 ;;; This isn't intended to be uservisible; there isn't a whole lot of 2267 2343 ;;; sanitychecking applied to the subtag. 2268 (defnx1 nx1%allocmisc ((%allocmisc)) (elementcount subtag &optional (init nil initp))2344 (defnx1 nx1%allocmisc ((%allocmisc)) context (elementcount subtag &optional (init nil initp)) 2269 2345 (if initp ; ensure that "init" is evaluated before miscobj is created. 2270 2346 (makeacode (%nx1operator %makeuvector) 2271 (nx1form elementcount)2272 (nx1form subtag)2273 (nx1form init))2347 (nx1form :value elementcount) 2348 (nx1form :value subtag) 2349 (nx1form :value init)) 2274 2350 (makeacode (%nx1operator %makeuvector) 2275 (nx1form elementcount)2276 (nx1form subtag))))2277 2278 (defnx1 nx1%lispwordref (%lispwordref) (base offset)2351 (nx1form :value elementcount) 2352 (nx1form :value subtag)))) 2353 2354 (defnx1 nx1%lispwordref (%lispwordref) context (base offset) 2279 2355 (makeacode (%nx1operator %lispwordref) 2280 (nx1form base)2281 (nx1form offset)))2282 2283 (defnx1 nx1%singletodouble ((%singletodouble)) (arg)2356 (nx1form :value base) 2357 (nx1form :value offset))) 2358 2359 (defnx1 nx1%singletodouble ((%singletodouble)) context (arg) 2284 2360 (makeacode (%nx1operator %singletodouble) 2285 (nx1form arg)))2286 2287 (defnx1 nx1%doubletosingle ((%doubletosingle)) (arg)2361 (nx1form :value arg))) 2362 2363 (defnx1 nx1%doubletosingle ((%doubletosingle)) context (arg) 2288 2364 (makeacode (%nx1operator %doubletosingle) 2289 (nx1form arg)))2290 2291 (defnx1 nx1%fixnumtodouble ((%fixnumtodouble)) (arg)2365 (nx1form :value arg))) 2366 2367 (defnx1 nx1%fixnumtodouble ((%fixnumtodouble)) context (arg) 2292 2368 (makeacode (%nx1operator %fixnumtodouble) 2293 (nx1form arg)))2294 2295 (defnx1 nx1%fixnumtosingle ((%fixnumtosingle)) (arg)2369 (nx1form :value arg))) 2370 2371 (defnx1 nx1%fixnumtosingle ((%fixnumtosingle)) context (arg) 2296 2372 (makeacode (%nx1operator %fixnumtosingle) 2297 (nx1form arg)))2298 2299 (defnx1 nx1%doublefloat ((%doublefloat)) (&whole whole arg &optional (result nil resultp))2373 (nx1form :value arg))) 2374 2375 (defnx1 nx1%doublefloat ((%doublefloat)) context (&whole whole arg &optional (result nil resultp)) 2300 2376 (declare (ignore result)) 2301 2377 (if resultp 2302 (nx1treatascall whole)2303 (makeacode (%nx1operator %doublefloat) (nx1form arg))))2304 2305 (defnx1 nx1%shortfloat ((%shortfloat)) (&whole whole arg &optional (result nil resultp))2378 (nx1treatascall context whole) 2379 (makeacode (%nx1operator %doublefloat) (nx1form :value arg)))) 2380 2381 (defnx1 nx1%shortfloat ((%shortfloat)) context (&whole whole arg &optional (result nil resultp)) 2306 2382 (declare (ignore result)) 2307 2383 (if resultp 2308 (nx1treatascall whole)2309 (makeacode (%nx1operator %singlefloat) (nx1form arg))))2310 2311 2312 (defnx1 nx1symvector ((%symptr>symvector) (%symvector>symptr)) (arg)2313 (makeacode (%nx1defaultoperator) (nx1form arg)))2314 2315 (defnx1 nx1%ilognot (%ilognot) (n)2384 (nx1treatascall context whole) 2385 (makeacode (%nx1operator %singlefloat) (nx1form :value arg)))) 2386 2387 2388 (defnx1 nx1symvector ((%symptr>symvector) (%symvector>symptr)) context (arg) 2389 (makeacode (%nx1defaultoperator) (nx1form :value arg))) 2390 2391 (defnx1 nx1%ilognot (%ilognot) context (n) 2316 2392 ;; Bootstrapping nonsense. 2317 2393 (if (aref (backendp2dispatch *targetbackend*) … … 2320 2396 'fixnum 2321 2397 (makeacode (%nx1operator %ilognot) 2322 (nx1form n)))2323 (nx1form (macroexpand `(%ilognot ,n)))))2398 (nx1form :value n))) 2399 (nx1form context (macroexpand `(%ilognot ,n))))) 2324 2400 2325 2401 2326 (defnx1 nx1ash (ash) (&whole call &environment env num amt)2402 (defnx1 nx1ash (ash) context (&whole call &environment env num amt) 2327 2403 (flet ((defertobackend () 2328 2404 ;; Bootstrapping nonsense … … 2333 2409 (makeacode 2334 2410 (%nx1operator ash) 2335 (nx1form num)2336 (nx1form amt)))2337 (nx1treatascall c all))))2411 (nx1form :value num) 2412 (nx1form :value amt))) 2413 (nx1treatascall context call)))) 2338 2414 (let* ((unsignednaturaltype *nxtargetnaturaltype*) 2339 2415 (max (targetwordsizecase (32 32) (64 64))) … … 2341 2417 (32 29) 2342 2418 (64 60)))) 2343 (cond ((eq amt 0) (nx1form `(requiretype ,num 'integer) env))2419 (cond ((eq amt 0) (nx1form context `(requiretype ,num 'integer) env)) 2344 2420 ((and (fixnump amt) 2345 2421 (< amt 0)) … … 2348 2424 (makeacode (%nx1operator fixnum) 2349 2425 ( amt)) 2350 (nx1form num))2426 (nx1form :value num)) 2351 2427 (if (nxformtypep num unsignednaturaltype env) 2352 2428 (if (< ( amt) max) 2353 2429 (makeacode (%nx1operator naturalshiftright) 2354 (nx1form num)2430 (nx1form :value num) 2355 2431 (makeacode (%nx1operator fixnum) 2356 2432 ( amt))) 2357 (nx1form `(progn (requiretype ,num 'integer) 0) env))2433 (nx1form context `(progn (requiretype ,num 'integer) 0) env)) 2358 2434 (defertobackend)))) 2359 2435 ((and (fixnump amt) … … 2363 2439 (nxtrustdeclarations env) 2364 2440 (subtypep *nxformtype* 'fixnum)))) 2365 (nx1form `(%ilsl ,amt ,num)))2441 (nx1form context `(%ilsl ,amt ,num))) 2366 2442 ((and (fixnump amt) 2367 2443 (< 0 amt max) … … 2370 2446 (subtypep *nxformtype* unsignednaturaltype)) 2371 2447 (makeacode (%nx1operator naturalshiftleft) 2372 (nx1form num)2373 (nx1form amt)))2448 (nx1form :value num) 2449 (nx1form :value amt))) 2374 2450 ((fixnump num) 2375 2451 (let* ((fieldwidth (1+ (integerlength num))) … … 2377 2453 (maxshift ( (1+ maxbits) fieldwidth))) 2378 2454 (if (nxformtypep amt `(mod ,(1+ maxshift)) env) 2379 (nx1form `(%ilsl ,amt ,num))2455 (nx1form context `(%ilsl ,amt ,num)) 2380 2456 (defertobackend)))) 2381 2457 (t (defertobackend)))))) … … 2386 2462 (nxerror "Bad argument format in ~S ." args)) 2387 2463 2388 (defnx1 nx1evalwhen evalwhen (when &body body)2389 (nx1prognbody (if (or (memq 'eval when) (memq :execute when)) body)))2390 2391 (defnx1 nx1misplaced (declare) (&rest args)2464 (defnx1 nx1evalwhen evalwhen context (when &body body) 2465 (nx1prognbody context (if (or (memq 'eval when) (memq :execute when)) body))) 2466 2467 (defnx1 nx1misplaced (declare) context (&rest args) 2392 2468 (nxerror "~S not expected in ~S." *nxsfname* (cons *nxsfname* args))) 2393 2469
Note: See TracChangeset
for help on using the changeset viewer.